source: cprs/branches/tmg-cprs/CPRS-Chart/fImages.pas@ 800

Last change on this file since 800 was 800, checked in by Kevin Toppenberg, 14 years ago

Fixing uploads of PDF files
File size: 45.6 KB
Line 
1unit fImages; //kt Entire unit and form added 8/19/05
2{$O-}
3
4interface
5
6uses
7 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
8 fPage, StdCtrls, ExtCtrls, Menus, ComCtrls, ORCtrls, ORFn, uConst, ORDtTm,
9 uPCE, ORClasses, fDrawers, ImgList, rTIU, uTIU, uDocTree, fRptBox, fPrintList,
10 OleCtrls, SHDocVw,
11 ORNet, TRPCB, fHSplit, Buttons, ExtDlgs, DKLang;
12
13type
14 TImageInfo = class
15 private
16 public
17 IEN : int64; //IEN in file# 2005
18 ServerPathName : AnsiString;
19 ServerFName : AnsiString;
20 ServerThumbPathName: AnsiString;
21 ServerThumbFName : AnsiString;
22 //Note: if there is no thumbnail to download, CacheThumbFName will still
23 // contain a file name and path, but a test for FileExists() will wail.
24 CacheThumbFName : AnsiString; // local cache path and File name of thumbnail image
25 CacheFName : AnsiString; // local cache path and File name of image
26 ShortDesc : AnsiString;
27 LongDesc : TStringList; //will be nil unless holds data.
28 DateTime : AnsiString; //fileman format
29 ImageType : Integer;
30 ProcName : AnsiString;
31 DisplayDate : AnsiString;
32 ParentDataFileIEN: int64;
33 AbsType : char; //'M' magnetic 'W' worm 'O' offline
34 Accessibility : char; //'A' accessable or 'O' offline
35 DicomSeriesNum : int64;
36 DicomImageNum : int64;
37 GroupCount : integer;
38 TabIndex : integer;
39 TabImageIndex : integer;
40
41 published
42 end;
43
44 TfrmImages = class(TfrmPage)
45 mnuNotes: TMainMenu;
46 mnuView: TMenuItem;
47 mnuViewChart: TMenuItem;
48 mnuChartReports: TMenuItem;
49 mnuChartLabs: TMenuItem;
50 mnuChartDCSumm: TMenuItem;
51 mnuChartCslts: TMenuItem;
52 mnuChartNotes: TMenuItem;
53 mnuChartOrders: TMenuItem;
54 mnuChartMeds: TMenuItem;
55 mnuChartProbs: TMenuItem;
56 mnuChartCover: TMenuItem;
57 mnuAct: TMenuItem;
58 Z3: TMenuItem;
59 mnuOptions: TMenuItem;
60 timLoadImages: TTimer;
61 N3: TMenuItem;
62 mnuIconLegend: TMenuItem;
63 mnuChartSurgery: TMenuItem;
64 ThumbsImageList: TImageList;
65 CurrentNoteMemo: TMemo;
66 pnlTop: TPanel;
67 HorizSplitter: TSplitter;
68 Splitter2: TSplitter;
69 UploadImagesButton: TBitBtn;
70 OpenPictureDialog: TOpenPictureDialog;
71 ButtonPanel: TPanel;
72 CurrentImageMemo: TMemo;
73 MemosPanel: TPanel;
74 UploadImagesMnuAction: TMenuItem;
75 pnlBottom: TPanel;
76 TabControl: TTabControl;
77 WebBrowser: TWebBrowser;
78 AutoScanUpload: TMenuItem;
79 PickScanFolder: TMenuItem;
80 OpenDialog: TOpenDialog;
81 procedure mnuChartTabClick(Sender: TObject);
82 procedure mnuActNewClick(Sender: TObject);
83 procedure timLoadImagesTimer(Sender: TObject);
84 procedure FormCreate(Sender: TObject);
85 procedure FormDestroy(Sender: TObject);
86 procedure FormShow(Sender: TObject);
87 procedure mnuActClick(Sender: TObject);
88 procedure UploadImagesButtonClick(Sender: TObject);
89 procedure FormHide(Sender: TObject);
90 procedure TabControlChange(Sender: TObject);
91 procedure TabControlGetImageIndex(Sender: TObject; TabIndex: Integer;
92 var ImageIndex: Integer);
93 procedure TabControlResize(Sender: TObject);
94 procedure EnableAutoScanUploadClick(Sender: TObject);
95 procedure PickScanFolderClick(Sender: TObject);
96 private
97 ImageInfoList : TList;
98 LastDisplayedTIUIEN : AnsiString;
99 CurImageToLoad : integer;
100 InTimerFn : Boolean;
101 procedure EnsureImageListLoaded();
102 procedure ClearImageList();
103 procedure DownloadToCache(ImageIndex : integer);
104 procedure EmptyCache();
105 procedure ClearTabPages();
106 procedure SetupTab(i : integer);
107 procedure UpdateNoteInfoMemo();
108 procedure UpdateImageInfoMemo(Rec: TImageInfo);
109 function FileSize(fileName : wideString) : Int64;
110 public
111 CacheDir : AnsiString;
112 UseDropBox : boolean;
113 DropBoxDir : string;
114 NullImageName : AnsiString;
115 function Decode(input: AnsiString) : AnsiString;
116 function Encode(input: AnsiString) : AnsiString;
117 function DownloadFileViaDropbox(FPath,FName,LocalSaveFNamePath: AnsiString;CurrentImage,TotalImages: Integer): boolean;
118 function DownloadFile(FPath,FName,LocalSaveFNamePath: AnsiString;CurrentImage,TotalImages: Integer): boolean;
119 function UploadFileViaDropBox(LocalFNamePath,FPath,FName: AnsiString;CurrentImage,TotalImages: Integer): boolean;
120 function UploadFile(LocalFNamePath,FPath,FName: AnsiString;CurrentImage,TotalImages: Integer): boolean;
121 procedure SplitLinuxFilePath(FullPathName : AnsiString;
122 var Path : AnsiString;
123 var FName : AnsiString);
124 procedure GetImageList();
125 procedure NewNoteSelected(EditIsActive : boolean);
126 function CreateBarcode(MsgStr: AnsiString; ImageType: AnsiString): AnsiString;
127 function DecodeBarcode(LocalFNamePath,ImageType: AnsiString): AnsiString;
128 procedure EnsureImagesDownloaded(ImagesList : TStringList);
129 published
130 end;
131
132var
133 frmImages: TfrmImages;
134
135
136implementation
137
138{$R *.DFM}
139
140uses fFrame, fVisit, fEncnt, rCore, uCore, fNoteBA, fNoteBD, fSignItem, fEncounterFrame,
141 rPCE, Clipbrd, fNoteCslt, fNotePrt, rVitals, fAddlSigners, fNoteDR, fConsults, uSpell,
142 fTIUView, fTemplateEditor, uReminders, fReminderDialog, uOrders, rConsults, fReminderTree,
143 fNoteProps, fNotesBP, fTemplateFieldEditor, dShared, rTemplates,
144 FIconLegend, fPCEEdit, fNoteIDParents, rSurgery, uSurgery, uTemplates,
145 uAccessibleTreeView, uAccessibleTreeNode, fTemplateDialog, DateUtils,
146 StrUtils {//KT added 1-1-05},
147 mshtml, {//kt added 5-2-05}
148 UploadImages, {//kt added 9/25/05}
149 //ImageTransferForm, {//kt 10-1-05}
150 uTMGOptions, //kt 3/10/10
151 rHTMLTools, fNotes, frmImageTransferProgress; {//kt added 5-27-05 for IsHTMLDocument}
152
153
154procedure TfrmImages.timLoadImagesTimer(Sender: TObject);
155//This function's goal is to download images in the background,
156// with one image to be downloaded each time the timer fires
157begin
158 inherited;
159 if InTimerFn=false then begin
160 InTimerFn := true;
161 EnsureImageListLoaded(); //only does RPC call if CurImageToLoad = 0
162 if CurImageToLoad <> -1 then begin //-1 means RPC-> no avail images.
163 if CurImageToLoad < ImageInfoList.Count then begin
164 ImageTransferForm.ProgressMsg.Caption := 'Downloading Images';
165 //if ImageTransferForm.Visible = false then begin
166 // ImageTransferForm.Show;
167 //end;
168 DownloadToCache(CurImageToLoad); //Only load 1 image per timer firing.
169 SetupTab(CurImageToLoad);
170 Inc(CurImageToLoad);
171 if TabControl.TabIndex < 0 then TabControl.TabIndex := 0;
172 TabControlChange(self);
173 end else begin
174 timLoadImages.Enabled := false;
175 //ImageTransferForm.ProgressBar.Position := 100;
176 //Sleep(1000);
177 //ImageTransferForm.Hide;
178 end;
179 end;
180 InTimerFn := false;
181 if self.Visible = true then begin
182 timLoadImages.Interval :=100;
183 end else begin
184 timLoadImages.Interval :=30000; //30 sec delay
185 end;
186 end;
187end;
188
189
190procedure TfrmImages.EnsureImagesDownloaded(ImagesList : TStringList);
191//This function's goal is to download images in the FOREground,
192// But only images matching those passed in ImagesList will be downloaded;
193// The intent is to only download images that have links to them in HTML source
194//Thus, if note has a large amount of images attached to it, but not referenced
195// in HTML code, then they will not be downloaded here. (But will be downloaded
196// later via timLoadImagesTimer
197var i : integer;
198 Rec : TImageInfo;
199
200begin
201 if ImagesList.Count = 0 then exit;
202 GetImageList();
203 if ImageInfoList.Count = 0 then exit;
204 if ImageInfoList.Count > 1 then begin
205 ImageTransferForm.ProgressMsg.Caption := 'Downloading Images';
206 ImageTransferForm.ProgressBar.Min := 0;
207 ImageTransferForm.ProgressBar.Position := 0;
208 ImageTransferForm.ProgressBar.Max := ImageInfoList.Count-1;
209 ImageTransferForm.Show;
210 end;
211 for i := 0 to ImageInfoList.Count-1 do begin
212 ImageTransferForm.ProgressBar.Position := i;
213 Rec := TImageInfo(ImageInfoList[i]);
214 if ImagesList.IndexOf(Rec.ServerFName)>-1 then begin
215 DownloadToCache(i);
216 end;
217 end;
218 ImageTransferForm.Hide;
219end;
220
221
222{ TPage common methods --------------------------------------------------------------------- }
223procedure TfrmImages.mnuChartTabClick(Sender: TObject);
224{ reroute to Chart Tab menu of the parent form: frmFrame }
225begin
226 inherited;
227 frmFrame.mnuChartTabClick(Sender);
228end;
229
230
231procedure TfrmImages.mnuActNewClick(Sender: TObject);
232const
233 IS_ID_CHILD = False;
234{ switches to current new note or creates a new note if none is being edited already }
235begin
236 inherited;
237end;
238
239procedure TfrmImages.FormCreate(Sender: TObject);
240//var i : integer;
241begin
242 inherited;
243 InTimerFn:=false;
244 LastDisplayedTIUIEN := '0';
245 ImageInfoList := TList.Create;
246 CurImageToLoad := 0;
247 CacheDir := ExtractFilePath(ParamStr(0))+ 'Cache';
248 //NullImageName := ExtractFilePath(ParamStr(0)) + 'images\blank.htm';
249 NullImageName := 'about:blank';
250 if not DirectoryExists(CacheDir) then ForceDirectories(CacheDir);
251
252 //UseDropBox := uTMGOptions.ReadBool('Use dropbox directory for transfers',false);
253 if uTMGOptions.ReadInteger('ImageTransferMethod',0) = 0 then begin
254 UseDropBox := True;
255 end else begin
256 UseDropBox := False;
257 end;
258 DropBoxDir := uTMGOptions.ReadString('Dropbox directory','??');
259 if DropBoxDir='??' then begin //just on first run.
260 uTMGOptions.WriteBool('Use dropbox directory for transfers',false);
261 uTMGOptions.WriteString('Dropbox directory','');
262 end;
263 AutoScanUpload.Checked := uTMGOptions.ReadBool('Scan Enabled',false);
264end;
265
266procedure TfrmImages.FormDestroy(Sender: TObject);
267begin
268 inherited;
269 ClearImageList;
270 ImageInfoList.Free;
271 EmptyCache;
272end;
273
274procedure TfrmImages.FormShow(Sender: TObject);
275var
276 TIUIEN : AnsiString;
277
278begin
279 inherited;
280 TIUIEN := IntToStr(frmNotes.lstNotes.ItemID);
281 timLoadImages.Enabled := true;
282 timLoadImages.Interval := 100;
283 if LastDisplayedTIUIEN <> TIUIEN then begin
284 UpdateNoteInfoMemo();
285 LastDisplayedTIUIEN := TIUIEN;
286 end;
287end;
288
289procedure TfrmImages.mnuActClick(Sender: TObject);
290begin
291 inherited;
292
293end;
294
295{ General procedures ----------------------------------------------------------------------- }
296
297procedure TfrmImages.UpdateImageInfoMemo(Rec : TImageInfo);
298var s : AnsiString;
299 i : integer;
300begin
301 CurrentImageMemo.Lines.Clear;
302 if Rec=nil then exit;
303 s := Trim(Rec.ShortDesc);
304 if s <> '' then CurrentImageMemo.Lines.Add('Description: ' + s);
305 s := Rec.ProcName;
306 if s <> '' then CurrentImageMemo.Lines.Add('Procedure: ' + s);
307 s := Rec.DisplayDate;
308 if s <> '' then CurrentImageMemo.Lines.Add('Upload Date: ' + s);
309 //s := Rec.DateTime;
310 //if s <> '' then CurrentImageMemo.Lines.Add('Date/Time: ' + s);
311 if Rec.LongDesc <> nil then begin
312 CurrentImageMemo.Lines.Add('Long Description:');
313 for i := 0 to Rec.LongDesc.Count-1 do begin
314 CurrentImageMemo.Lines.Add(' ' + Rec.LongDesc.Strings[i]);
315 end;
316 end;
317end;
318
319
320procedure TfrmImages.UpdateNoteInfoMemo();
321var
322 NoteInfo,s : AnsiString;
323 //dateS : AnsiString;
324const
325 U='^';
326begin
327 CurrentNoteMemo.Lines.Clear;
328 with frmNotes.lstNotes do begin
329 if ItemIndex > -1 then begin
330 NoteInfo := Items[ItemIndex]
331 (* example NoteInfo:
332 piece# 1: 14321^ //TIU IEN
333 piece# 2: PRESCRIPTION CALL IN^ //Document Title
334 piece# 3: 3050713.0947^ //Date/Time
335 piece# 4: TEST, KILLME D (T0101)^ //Patient
336 piece# 5: 133;JANE A DOE;DOE,JANE A^ //Author
337 piece# 6: Main_Office^ //Location of Visit
338 piece# 7: completed^ //Status of Document
339 piece# 8: Visit: 07/13/05;3050713.094721^ //Date/Time
340 piece# 9...: ;^^1^^^1^' //?
341 *)
342 end else NoteInfo := '';
343 end;
344 if NoteInfo <>'' then begin
345 s := Piece(NoteInfo, U, 2) + ' -- ';
346 s := s + Piece(Piece(NoteInfo, U, 8), ';', 1);
347 CurrentNoteMemo.Lines.Add(s);
348 s := 'Location: ' + Piece(NoteInfo, U, 6) + ' -- ';
349 s := s + 'Note Author: ' + Piece(Piece(NoteInfo, U, 5), ';', 2);
350 CurrentNoteMemo.Lines.Add(s);
351 end;
352end;
353
354procedure TfrmImages.SetupTab(i : integer);
355//i is index in ImageInfoList (array of TImageInfo's)
356var
357 Rec : TImageInfo; //this will be a copy of record, not pointer (I think)
358 Bitmap : TBitmap;
359 index : integer;
360 Ext : AnsiString;
361
362 (*Notice: A TabControl doesn't directly support specifying which
363 images in an ImageList to show for a given tab. To get
364 around this, the help documentation recommends setting up
365 a TabControlGetImageIndex event handler.
366 I am doing this. When the event is called, then RecInfo.TabImageIndex
367 is returned.
368 *)
369
370begin
371 if i < ImageInfoList.Count then begin
372 Rec := TImageInfo(ImageInfoList[i]);
373 if (Rec.TabImageIndex < 1) then begin
374 if FileExists(Rec.CacheThumbFName) then begin
375 Bitmap := TBitmap.Create;
376 Bitmap.Width := 1024; //something big enough to hold any thumbnail.
377 Bitmap.Height := 768;
378 Bitmap.LoadFromFile(Rec.CacheThumbFName);
379 Bitmap.Width := ThumbsImageList.Width; //shrinkage crops image
380 Bitmap.Height := ThumbsImageList.Height;
381 index := ThumbsImageList.Add(Bitmap,nil);
382 TImageInfo(ImageInfoList[i]).TabImageIndex := index;
383 Bitmap.Free;
384 end else begin
385 Ext := LowerCase(ExtractFileExt(Rec.CacheFName));
386 Ext := MidStr(Ext,2,99);
387 if (Ext='jpg')
388 or (Ext='jpeg')
389 or (Ext='png')
390 or (Ext='tif')
391 or (Ext='tiff')
392 or (Ext='gif')
393 or (Ext='bmp') then begin
394 TImageInfo(ImageInfoList[i]).TabImageIndex := 0; //camera image
395 end else
396 if (Ext='pdf') then begin
397 TImageInfo(ImageInfoList[i]).TabImageIndex := 1; //adobe icon
398 end else
399 if (Ext='avi')
400 or (Ext='qt')
401 or (Ext='mpg')
402 or (Ext='mpeg') then begin
403 TImageInfo(ImageInfoList[i]).TabImageIndex := 2; //video icon
404 end else
405 if (Ext='mp3')
406 or (Ext='wma')
407 or (Ext='au')
408 or (Ext='wav') then begin
409 TImageInfo(ImageInfoList[i]).TabImageIndex := 3; //sound icon
410 end else
411 begin
412 TImageInfo(ImageInfoList[i]).TabImageIndex := 4; // misc icon
413 end;
414 end;
415 end;
416 TabControl.Tabs.Add(' '); //add the tab. Thumbnail should exist before this
417 end;
418end;
419
420
421procedure TfrmImages.ClearTabPages();
422begin
423 TabControl.Tabs.Clear;
424 ClearImageList();
425end;
426
427
428procedure TfrmImages.ClearImageList();
429//Note: !! This should also clear any visible images/thumbnails etc.
430var i : integer;
431begin
432 for i := ImageInfoList.Count-1 downto 0 do begin
433 if TImageInfo(ImageInfoList[i]).LongDesc <> nil then begin
434 TImageInfo(ImageInfoList[i]).LongDesc.Free;
435 end;
436 TImageInfo(ImageInfoList[i]).Free;
437 ImageInfoList.Delete(i);
438 end;
439end;
440
441
442procedure TfrmImages.EnsureImageListLoaded();
443begin
444 if CurImageToLoad = 0 then begin
445 GetImageList();
446 if ImageInfoList.Count=0 then CurImageToLoad := -1;
447 end;
448end;
449
450procedure TfrmImages.GetImageList();
451var
452 i,j : integer;
453 s,s2 : AnsiString;
454 Rec : TImageInfo;
455 ImageIEN : integer;
456 TIUIEN : AnsiString;
457 ServerFName : AnsiString;
458 ServerPathName : AnsiString;
459 ImageFPathName : AnsiString; //path on server of image -- original data provided by server
460 ThumbnailFPathName : AnsiString; //path on server of thumbnail -- original data provided by server
461
462begin
463 inherited;
464 ClearImageList;
465 try
466 TIUIEN := IntToStr(frmNotes.lstNotes.ItemID);
467
468 except
469 //Error occurs after note is signed, and frmNotes.lstNotes.ItemID is "inaccessible"
470 on E: Exception do exit;
471 end;
472 //----MOVED
473 StatusText('Retrieving images information...');
474 CallV('MAG3 CPRS TIU NOTE', [TIUIEN]);
475 for i:=0 to (RPCBrokerV.Results.Count-1) do begin
476 s :=RPCBrokerV.Results[i];
477 if i=0 then begin
478 if piece(s,'^',1)='0' then break //i.e. abort due to error signal
479 else continue; //ignore rest of header (record #0)
480 end;
481 if Pos('-1~',s)>0 then continue; //abort if error signal.
482 Rec := TImageInfo.Create; // ImageInfoList will own this.
483 Rec.LongDesc := nil;
484 Rec.TabIndex := -1;
485 Rec.TabImageIndex := 0;
486 s2 := piece(s,'^',2); if s2='' then s2 := '0'; //IEN
487 Rec.IEN := StrToInt(s2);
488 ImageFPathName := piece(s,'^',3); //Image FullPath and name
489 ThumbnailFPathName := piece(s,'^',4); //Abstract FullPath and Name
490 Rec.ShortDesc := piece(s,'^',5); //SHORT DESCRIPTION field
491 s2 := piece(s,'^',6); if s2='' then s2 := '0'; //PROCEDURE/ EXAM DATE/TIME field
492 Rec.DateTime := s2;
493 s2 := piece(s,'^',7); if s2='' then s2 := '0'; //OBJECT TYPE
494 Rec.ImageType := StrToInt(s2);
495 Rec.ProcName := piece(s,'^',8); //PROCEDURE field
496 Rec.DisplayDate := piece(s,'^',9); //Procedure Date in Display format
497 s2 := piece(s,'^',10); if s2='' then s2 := '0'; //PARENT DATA FILE image pointer
498 Rec.ParentDataFileIEN := StrToInt(s2);
499 Rec.AbsType := piece(s,'^',11)[1]; //the ABSTYPE : 'M' magnetic 'W' worm 'O' offline
500 s2 := piece(s,'^',12); if s2='' then s2 :='O';
501 Rec.Accessibility := s2[1]; //Image accessibility 'A' accessable or 'O' offline
502 s2 := piece(s,'^',13); if s2='' then s2 := '0'; //Dicom Series number
503 Rec.DicomSeriesNum := StrToInt(s2);
504 s2 := piece(s,'^',14); if s2='' then s2 := '0'; //Dicom Image Number
505 Rec.DicomImageNum := StrToInt(s2);
506 s2 := piece(s,'^',15); if s2='' then s2 := '0'; //Count of images in the group, or 1 if a single image
507 Rec.GroupCount := StrToInt(s2);
508
509 SplitLinuxFilePath(ImageFPathName,ServerPathName,ServerFName);
510 Rec.ServerPathName := ServerPathName;
511 Rec.ServerFName := ServerFName;
512 Rec.CacheFName := CacheDir + '\' + ServerFName;
513 SplitLinuxFilePath(ThumbnailFPathName,ServerPathName,ServerFName);
514 Rec.ServerThumbPathName := ServerPathName;
515 Rec.ServerThumbFName := ServerFName;
516 Rec.CacheThumbFName := CacheDir + '\' + ServerFName;
517 ImageInfoList.Add(Rec); // ImageInfoList will own Rec.
518 end;
519 for i:= 0 to ImageInfoList.Count-1 do begin
520 Rec := TImageInfo(ImageInfoList.Items[i]);
521 ImageIEN := Rec.IEN;
522 CallV('TMG GET IMAGE LONG DESCRIPTION', [ImageIEN]);
523 for j:=0 to (RPCBrokerV.Results.Count-1) do begin
524 if (j>0) then begin
525 if Rec.LongDesc = nil then Rec.LongDesc := TStringList.Create;
526 Rec.LongDesc.Add(RPCBrokerV.Results.Strings[j]);
527 end else begin
528 if RPCBrokerV.Results[j]='' then break;
529 end;
530 end;
531 end;
532 //----END MOVED
533 StatusText('');
534end;
535
536
537procedure TfrmImages.DownloadToCache(ImageIndex : integer);
538//Loads image specified in ImageInfoList to Cache (unless already present)
539var
540 Rec : TImageInfo;
541 ServerFName : AnsiString;
542 ServerPathName : AnsiString;
543
544begin
545 Rec := TImageInfo(ImageInfoList[ImageIndex]);
546 ServerFName := Rec.ServerFName;
547 ServerPathName := Rec.ServerPathName;
548 if not FileExists(Rec.CacheFName) then begin
549 DownloadFile(ServerPathName,ServerFName,Rec.CacheFName,(ImageIndex*2)-1,ImageInfoList.Count*2);
550 end;
551 ServerFName := Rec.ServerThumbFName;
552 ServerPathName := Rec.ServerThumbPathName;
553 if not FileExists(Rec.CacheThumbFName) then begin
554 DownloadFile(ServerPathName,ServerFName,Rec.CacheThumbFName,ImageIndex*2,ImageInfoList.Count*2);
555 end;
556 Application.ProcessMessages;
557end;
558
559procedure TfrmImages.SplitLinuxFilePath(FullPathName : AnsiString;
560 var Path : AnsiString;
561 var FName : AnsiString);
562var p : integer;
563begin
564 Path := ''; FName := '';
565 repeat
566 p := Pos('/',FullPathName);
567 if p > 0 then begin
568 Path := Path + MidStr(FullPathName,1,p);
569 FullPathName := MidStr(FullPathName,p+1,1000);
570 end else begin
571 FName := FullPathName;
572 FullPathName := '';
573 end;
574 until (FullPathName = '');
575end;
576
577
578function TfrmImages.UploadFileViaDropBox(LocalFNamePath,FPath,FName: AnsiString;CurrentImage,TotalImages: Integer): boolean;
579var
580 DropboxFile : AnsiString;
581begin
582 //First copy LocalFileNamePath --> DropBox\FileName
583 DropboxFile := ExcludeTrailingBackslash(DropboxDir) + '\' + FName;
584 if CopyFile(pchar(LocalFNamePath),pchar(DropboxFile),false)=false then begin
585 MessageDlg('Dropbox file transfer failed. Code='+InttoStr(GetLastError),
586 mtError,[mbOK],0);
587 result := false;
588 exit;
589 end;
590
591 // CallV('TMG UPLOAD FILE DROPBOX', ...);
592 RPCBrokerV.ClearParameters := true;
593 RPCBrokerV.remoteprocedure := 'TMG UPLOAD FILE DROPBOX';
594 RPCBrokerV.param[0].PType := literal;
595 RPCBrokerV.param[0].Value := FPath;
596 RPCBrokerV.Param[1].PType := literal;
597 RPCBrokerV.Param[1].Value := FName;
598 RPCBrokerV.Param[2].PType := literal;
599 RPCBrokerV.Param[2].Value := '1'; //see comments in UploadFile re '1' hardcoding
600
601 //RPCBrokerV.Call; //Move file into dropbox.
602 CallBroker;
603 if RPCBrokerV.Results.Count>0 then begin
604 Result := (Piece(RPCBrokerV.Results[0],'^',1)='1'); //1=success, 0=failure
605 end else Result := false;
606end;
607
608
609function TfrmImages.UploadFile(LocalFNamePath,FPath,FName: AnsiString;CurrentImage,TotalImages: Integer): boolean;
610const
611 RefreshInterval = 500;
612 BlockSize = 512;
613
614var
615 ReadCount : Word;
616 totalReadCount : Integer;
617 ParamIndex : LongWord;
618 j : word;
619 InFile : TFileStream;
620 LocalOutFile : TFileStream;
621 Buffer : array[0..1024] of byte;
622 RefreshCountdown : integer;
623 OneLine : AnsiString;
624 RPCResult : AnsiString;
625 SavedCursor : TCursor;
626
627begin
628 result := false; //default of failure
629 if not FileExists(LocalFNamePath) then exit;
630 if UseDropBox then begin
631 Result := UploadFileViaDropBox(LocalFNamePath,FPath,FName,CurrentImage,TotalImages);
632 exit;
633 end;
634 try
635 InFile := TFileStream.Create(LocalFNamePath,fmOpenRead or fmShareCompat);
636 LocalOutFile := TFileStream.Create(CacheDir+'\'+FName,fmCreate or fmOpenWrite); //for local copy
637 //Note: I may well cut this out. Most of the delay occurs during
638 // the RPC call, and I can't make a progress bar change during that...
639 // (or I could, but I'm not going to change the RPC broker...)
640 ImageTransferForm.setMax(InFile.Size);
641 //ImageTransferForm.ResetStartTime;
642 ImageTransferForm.ProgressMsg.Caption := 'Preparing to upload...';
643 ImageTransferForm.Show;
644 totalReadCount := 0;
645 except
646 // catch failure here... on eError...
647 exit;
648 end;
649
650 StatusText('Uploading full image...');
651 Application.ProcessMessages;
652
653 RPCBrokerV.ClearParameters := true;
654 RPCBrokerV.Param[0].PType := literal;
655 RPCBrokerV.Param[0].Value := FPath;
656 RPCBrokerV.Param[1].PType := literal;
657 RPCBrokerV.Param[1].Value := FName;
658 RPCBrokerV.Param[2].PType := literal;
659 RPCBrokerV.Param[2].Value := '1';
660 //Note: the '1' in the line above is hard-coding in to use
661 //IEN=1 in file 2005.2 (NETWORK LOCATION). This file will
662 //instruct the server which relative path to store the file into
663 //If I want to have more than one NETWORK LOCATION, then I would
664 //need to create another RPC call that would determine which IEN
665 //to use.
666 //(This would be the same as the IEN stored in fields# 2, 2.1, 2.2
667 // of file 2005 (IMAGE). This in turn is originally obtained from
668 //file IMAGING SITE PARAMETERS
669
670 RPCBrokerV.Param[3].PType := list;
671
672 ParamIndex := 0;
673 RefreshCountdown := RefreshInterval;
674 repeat
675 ReadCount := InFile.Read(Buffer,BlockSize);
676 LocalOutFile.Write(Buffer,ReadCount); //for local copy
677 totalReadCount := totalReadCount + ReadCount;
678 ImageTransferForm.updateProgress(totalReadCount);
679 OneLine := '';
680 if ReadCount > 0 then begin
681 SetLength(OneLine,ReadCount);
682 for j := 1 to ReadCount do OneLine[j] := char(Buffer[j-1]);
683 RPCBrokerV.Param[3].Mult[IntToStr(ParamIndex)] := Encode(OneLine);
684 Inc(ParamIndex);
685
686 Dec(RefreshCountdown);
687 if RefreshCountdown < 1 then begin
688 Application.ProcessMessages;
689 RefreshCountdown := RefreshInterval;
690 end;
691
692 end;
693 until (ReadCount < BlockSize);
694
695 RPCBrokerV.remoteprocedure := 'TMG UPLOAD FILE';
696
697 SavedCursor := Screen.Cursor;
698 Screen.Cursor := crHourGlass;
699 ImageTransferForm.ProgressMsg.Caption := 'Uploading file to server...';
700 Application.ProcessMessages;
701
702 CallBroker;
703 Screen.Cursor := SavedCursor;
704 if RPCBrokerV.Results.Count > 0 then begin
705 RPCResult := RPCBrokerV.Results[0];
706 end else RPCResult := '';
707 result := (Piece(RPCResult,'^',1)='1');
708 ImageTransferForm.Hide;
709 if result=false then begin
710 Application.MessageBox('Error uploading file','Error');
711 end;
712
713 InFile.Free;
714 LocalOutFile.Free;
715 StatusText('');
716end;
717
718
719function TfrmImages.DownloadFileViaDropbox(FPath,FName,LocalSaveFNamePath: AnsiString;CurrentImage,TotalImages: Integer): boolean;
720var
721 DropboxFile : AnsiString;
722 CurrentFileSize : Integer;
723 ErrMsg : string;
724begin
725 // CallV('TMG DOWNLOAD FILE DROPBOX', ...);
726 RPCBrokerV.ClearParameters := true;
727 RPCBrokerV.remoteprocedure := 'TMG DOWNLOAD FILE DROPBOX';
728 RPCBrokerV.param[0].PType := literal;
729 RPCBrokerV.param[0].Value := FPath;
730 RPCBrokerV.Param[1].PType := literal;
731 RPCBrokerV.Param[1].Value := FName;
732 RPCBrokerV.Param[2].PType := literal;
733 RPCBrokerV.Param[2].Value := '1'; //see comments in UploadFile re '1' hardcoding
734
735 //RPCBrokerV.Call; //Move file into dropbox.
736 CallBroker;
737 if RPCBrokerV.Results.Count > 0 then begin
738 Result := (Piece(RPCBrokerV.Results[0],'^',1)='1'); //1=success, 0=failure
739 if Result = false then ErrMsg := Piece(RPCBrokerV.Results[0],'^',2);
740 end else begin
741 Result := false;
742 ErrMsg := 'Error communicating with server to retrieve image.';
743 end;
744
745 if Result=true then begin
746 if DirectoryExists(DropboxDir) = False then begin //elh added to ensure a dropbox directory is valid
747 MessageDlg('Invalid Dropbox Directory. Please check your settings and try again.',mtError,[mbOK],0);
748 ImageTransferForm.hide;
749 exit;
750 end;
751 CurrentFileSize := strtoint(Piece(RPCBrokerV.Results[0],'^',3)); //Piece 3 = file size
752 DropboxFile := ExcludeTrailingBackslash(DropboxDir) + '\' + FName;
753 if ImageTransferForm.visible = False then ImageTransferForm.show;
754 while FileSize(DropboxFile) <> CurrentFileSize do sleep(1000); //elh
755 ImageTransferForm.ProgressBar.Max := TotalImages; //elh
756 ImageTransferForm.ProgressBar.Position := CurrentImage+2; //elh
757 if TotalImages = (CurrentImage+2) then begin
758 Sleep(1000);
759 ImageTransferForm.hide;
760 end;
761 //Now move DropBox\FileName --> LocalFileNamePath
762 if MoveFile(pchar(DropboxFile),pchar(LocalSaveFNamePath))=false then begin
763 MessageDlg('Dropbox file transfer failed. Code='+InttoStr(GetLastError),
764 mtError,[mbOK],0);
765 end;
766 end else begin
767 MessageDlg('ERROR: '+ErrMsg,mtError,[mbOK],0);
768 end;
769end;
770
771
772function TfrmImages.DownloadFile(FPath,FName,LocalSaveFNamePath: AnsiString;CurrentImage,TotalImages: Integer): boolean;
773var
774 i,count : integer;
775 j : word;
776 OutFile : TFileStream;
777 s : AnsiString;
778 Buffer : array[0..1024] of byte;
779 RefreshCountdown : integer;
780
781const
782 RefreshInterval = 500;
783
784begin
785 if FileExists(LocalSaveFNamePath) then begin
786 DeleteFile(LocalSaveFNamePath);
787 end;
788 if UseDropBox then begin
789 Result := DownloadFileViaDropBox(FPath,FName,LocalSaveFNamePath,CurrentImage,TotalImages);
790 exit;
791 end;
792 Result := true; //default to success;
793 StatusText('Retrieving full image...');
794 //Note: the '1' in the line below is hard-coding in to use
795 //IEN=1 in file 2005.2 (NETWORK LOCATION). This file will
796 //instruct the server which relative path to store the file into
797 //If I want to have more than one NETWORK LOCATION, then I would
798 //need to create another RPC call that would determine which IEN
799 //to use.
800 //(This would be the same as the IEN stored in fields# 2, 2.1, 2.2
801 // of file 2005 (IMAGE). This in turn is originally obtained from
802 //file IMAGING SITE PARAMETERS
803 CallV('TMG DOWNLOAD FILE', [FPath,FName,'1']);
804 Application.ProcessMessages;
805 RefreshCountdown := RefreshInterval;
806 //Note:RPCBrokerV.Results[0]=1 if successful load, =0 if failure
807 if (RPCBrokerV.Results.Count>0) and (RPCBrokerV.Results[0]='1') then begin
808 OutFile := TFileStream.Create(LocalSaveFNamePath,fmCreate);
809 for i:=1 to (RPCBrokerV.Results.Count-1) do begin
810 s :=Decode(RPCBrokerV.Results[i]);
811 count := Length(s);
812 if count>1024 then begin
813 Result := false; //failure of load.
814 break;
815 end;
816 for j := 1 to count do Buffer[j-1] := ord(s[j]);
817 OutFile.Write(Buffer,count);
818 Dec(RefreshCountdown);
819 if RefreshCountdown < 1 then begin
820 Application.ProcessMessages;
821 RefreshCountdown := RefreshInterval;
822 end;
823 end;
824 OutFile.Free;
825 end else begin
826 result := false;
827 end;
828 StatusText('');
829end;
830
831
832function TfrmImages.Encode(Input: AnsiString) : AnsiString;
833//This function is based on ENCODE^RGUTUU, which is match for
834//DECODE^RGUTUU that is used to decode (ascii armouring) on the
835//server side. This is a base64 encoder.
836const
837 //FYI character set is 64 characters (starting as 'A')
838 // (65 characters if intro '=' is counted)
839 CharSet = '=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
840var
841 //Result : AnsiString; // RGZ1 //'Result' is implicitly declared by Pascal
842
843 i : integer; //RGZ2
844 j : integer; //RGZ4
845 PlainTrio : longword; //RGZ3 //unsigned 32-bit
846 EncodedByte : Byte;
847 PlainByte : byte; //RGZ5
848 EncodedQuad : string[4];//RGZ6
849
850begin
851 //e.g. input (10 bytes):
852 // 174 231 193 16 29 251 93 138 4 57
853 // AE E7 C1 10 1D FB 5D 8A 04 39
854 Result := '';
855 i := 1;
856 while i<= Length(Input) do begin //cycle in groups of 3
857 PlainTrio := 0;
858 EncodedQuad := '';
859 //Get 3 bytes, to be converted into 4 characters eventually.
860 //Fill with 0's if needed to make an even 3-byte group.
861 For j:=0 to 2 do begin
862 //e.g. '174'->PlainByte=174
863 if (i+j) <= Length(Input) then PlainByte := ord(Input[i+j])
864 else PlainByte := 0;
865 PlainTrio := (PlainTrio shl 8) or PlainByte;
866 end;
867 //e.g. first 3 bytes--> PlainTrio= $AEE7C1 (10101110 11100111 11000001)
868 //e.g. last 3 bytes--> PlainTrio= $390000 (00111001 00000000 00000000) (note padded 0's)
869
870 //Take each 6 bits and convert into a character.
871 //e.g. first 3 bytes--> (101011 101110 011111 000001)
872 // 43 46 31 1
873
874 //e.g. last 3 bytes-->(001110 010000 000000 000000) (after redivision)
875 // 14 16 0 0 <-- last 2 bytes are padded 0
876 // ^ last 4 bits of '16' are padded 0's
877 For j := 1 to 4 do begin
878 //e.g. $AEE7C1 --> (43+2)=45 (46+2)=48 (31+2)=33 (1+2)=3
879 // r u f b
880
881 //e.g. $39AF00 --> (14+2)=16 (16+2)=18 (0+2)=2 (0+2)=2
882 // O Q A A <-- 2 padded bytes
883 EncodedByte := (PlainTrio and 63)+2; //63=$3F=b0111111; 0->A 1->B etc
884 EncodedQuad := CharSet[EncodedByte]+ EncodedQuad; //string Concat, not math add
885 PlainTrio := PlainTrio shr 6
886 end;
887
888 //Append result with latest quad
889 Result := Result + EncodedQuad;
890 Inc(i,3);
891 end;
892
893 // e.g. result: rufb .... .... OQAA <-- 2 padded bytes (and part of Q is padded also)
894 i := 3-(Length(Input) mod 3); //returns 1,2,or 3 (3 needs to be set to 0)
895 if (i=3) then i:=0; //e.g. input=10 -> i=2
896 j := Length(Result);
897 //i is the number of padded characters that need to be replaced with '='
898 if i>=1 then Result[j] := '='; //replace 1st paddeded char
899 if i>=2 then Result[Length(Result)-1] := '=';//replace 2nd paddeded char
900 // e.g. result: rufb .... .... OQ==
901
902 //results passed out in Result
903end;
904
905
906function TfrmImages.Decode(Input: AnsiString) : AnsiString;
907//This function is based on DECODE^RGUTUU, which is match for
908//ENCODE^RGUTUU that is used to encode (ascii armouring) on the
909//server side. This is a Base64 decoder
910const
911 //FYI character set is 64 characters (starting as 'A')
912 // (65 characters if intro '=' is counted)
913 CharSet = '=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
914
915var
916 //Result : AnsiString; // RGZ1 //'Result' is implicitly declared by Pascal
917 i : integer; //RGZ2
918 PlainTrio : longword; //RGZ3 //unsigned 32-bit
919 j : integer; //RGZ4
920 EncodedChar : char;
921 PlainInt : integer;
922 PlainByte : byte; //RGZ5
923 DecodedTrio : string[3];//RGZ6
924
925begin
926 Result:='';
927 i := 1;
928 //e.g. input: rufb .... .... OQ==
929
930 while i <= Length(Input) Do begin //cycle in groups of 4
931 PlainTrio :=0;
932 DecodedTrio :='';
933 //Get 4 characters, to be converted into 3 bytes.
934 For j :=0 to 3 do begin
935 //e.g. last 4 chars --> 0A==
936 if (i+j) <= Length(Input) then begin
937 EncodedChar := Input[i+j];
938 PlainInt := Pos(EncodedChar,CharSet)-2; //A=0, B=1 etc.
939 if (PlainInt>=0) then PlainByte := (PlainInt and $FF) else PlainByte := 0;
940 end else PlainByte := 0;
941 //e.g. with last 4 characters:
942 //e.g. '0'->14=(b001110) 'Q'->16=(b010000) '='-> -1 -> 0=(b000000) '=' -> 0=(b000000)
943 //e.g.-- So last PlainTrio = 001110 010000 000000 000000 = 00111001 00000000 00000000
944 //Each encoded character contributes 6 bytes to final 3 bytes.
945 //4 chars * 6 bits/char=24 bits --> 24 bits / 8 bits/byte = 3 bytes
946 PlainTrio := (PlainTrio shl 6) or PlainByte; //PlainTrio := PlainTrio*64 + PlainByte;
947 end;
948 //Now take 3 bytes, and add to cumulative output (in same order)
949 For j :=0 to 2 do begin
950 DecodedTrio := Chr(PlainTrio and $FF) + DecodedTrio; //string concat (not math addition)
951 PlainTrio := PlainTrio shr 8; // PlainTrio := PlainTrio div 256
952 end;
953 //e.g. final DecodedTrio = 'chr($39) + chr(0) + chr(0)'
954 Result := Result + DecodedTrio;
955 Inc(i,4);
956 end;
957
958 //Now remove 1 byte from the output for each '=' in input string
959 //(each '=' represents 1 padded 0 added to allow for even groups of 3)
960 for j :=0 to 1 do begin
961 if (Input[Length(Input)-j] = '=') then begin
962 Result := MidStr(Result,1,Length(Result)-1);
963 end;
964 end;
965end;
966
967procedure TfrmImages.NewNoteSelected(EditIsActive : boolean);
968//Will be called by fNotes when a new note has been selected.
969//var
970begin
971 ClearTabPages();
972 CurImageToLoad := 0; //a -1 would signal that no images avail to load.
973 //this will start downloading images after 5 second delay (so that if
974 //user is just browsing past note, this won't waste effort.
975 //If user selects images tab, then load will occur without delay.
976 timLoadImages.Enabled := true;
977 timLoadImages.Interval := 60000; //60 sec delay -- also set in timLoadImagesTimer
978 //Note: OnTimer calls timLoadImagesTimer()
979 UploadImagesButton.Enabled := EditIsActive;
980 UploadImagesMnuAction.Enabled := EditIsActive;
981 WebBrowser.Navigate(NullImageName);
982end;
983
984
985procedure TfrmImages.EmptyCache();
986//This will delete ALL files in the Cache directory
987//Note: This will include the html_note file created by
988// the notes tab.
989var
990 //CacheDir : AnsiString;
991 FoundFile : boolean;
992 FSearch : TSearchRec;
993 Files : TStringList;
994 i : integer;
995 FName : AnsiString;
996
997begin
998 Files := TStringList.Create;
999// CacheDir := ExtractFilePath(ParamStr(0))+ 'Cache';
1000 FoundFile := (FindFirst(CacheDir+'\*.*',faAnyFile,FSearch)=0);
1001 while FoundFile do Begin
1002 FName := FSearch.Name;
1003 if (FName <> '.') and (FName <> '..') then begin
1004 FName := CacheDir + '\' + FName;
1005 Files.Add(FName);
1006 end;
1007 FoundFile := (FindNext(FSearch)=0);
1008 end;
1009
1010 for i := 0 to Files.Count-1 do begin
1011 FName := Files.Strings[i];
1012 if DeleteFile(FName) = false then begin
1013 //kt raise Exception.Create('Unable to delete file: '+FSearch.Name+#13+'Will try again later...');
1014 end;
1015 end;
1016 Files.Free;
1017end;
1018
1019
1020
1021procedure TfrmImages.UploadImagesButtonClick(Sender: TObject);
1022var
1023 Node: TORTreeNode;
1024 AddResult : TModalResult;
1025begin
1026 inherited;
1027 AddResult := UploadForm.ShowModal;
1028 if not IsAbortResult(AddResult) then begin
1029 NewNoteSelected(true); //force a reload to show recently added image.
1030 timLoadImages.Interval := 100;
1031 Node := TORTreeNode(frmNotes.tvNotes.Selected);
1032 case Node.StateIndex of
1033 IMG_NO_IMAGES : Node.StateIndex := IMG_1_IMAGE;
1034 IMG_1_IMAGE : Node.StateIndex := IMG_2_IMAGES;
1035 IMG_2_IMAGES : Node.StateIndex := IMG_MANY_IMAGES;
1036 IMG_MANY_IMAGES : Node.StateIndex := IMG_MANY_IMAGES;
1037 end;
1038 end;
1039end;
1040
1041procedure TfrmImages.FormHide(Sender: TObject);
1042begin
1043 inherited;
1044// Application.MessageBox('Here I can hide images.','title');
1045end;
1046
1047procedure TfrmImages.TabControlChange(Sender: TObject);
1048var
1049 FileName : AnsiString;
1050 Rec : TImageInfo;
1051 Selected : integer;
1052begin
1053 inherited;
1054 //here tab has been changed.
1055 Selected := TabControl.TabIndex;
1056 if Selected > -1 then begin
1057 Rec := TImageInfo(ImageInfoList[Selected]);
1058 FileName := Rec.CacheFName;
1059 UpdateImageInfoMemo(Rec);
1060 end else begin
1061 FileName := NullImageName;
1062 UpdateImageInfoMemo(nil);
1063 end;
1064 WebBrowser.Navigate(FileName);
1065end;
1066
1067procedure TfrmImages.TabControlGetImageIndex(Sender: TObject;
1068 TabIndex: Integer;
1069 var ImageIndex: Integer);
1070//specify which image to display, from ThumbsImageList
1071begin
1072 inherited;
1073 if (ImageInfoList <> nil) and (TabIndex < ImageInfoList.Count) then begin
1074 ImageIndex := TImageInfo(ImageInfoList[TabIndex]).TabImageIndex;
1075 end else ImageIndex := 0;
1076end;
1077
1078procedure TfrmImages.TabControlResize(Sender: TObject);
1079begin
1080 inherited;
1081 if TabControl.Width < 80 then begin
1082 TabControl.Width := 80;
1083 end;
1084end;
1085
1086function TfrmImages.CreateBarcode(MsgStr: AnsiString; ImageType: AnsiString): AnsiString;
1087//Create a local barcode file, in .png format, from MsgStr
1088//ImageType is optional, default ='png'. It should NOT contain '.'
1089//Returns file path on local client of new barcode image.
1090//Note: this function is not related to uploading or downloading images
1091// to the server for attaching to progress notes. It is included
1092// in this unit because the functionality used is nearly identical to
1093// the other code.
1094 function UniqueFName : AnsiString;
1095 var FName,tempFName : AnsiString;
1096 count : integer;
1097 begin
1098 FName := 'Barcode-Image';
1099 count := 0;
1100 repeat
1101 tempFName := CacheDir + '\' + FName + '.' + ImageType;
1102 FName := FName + '1';
1103 count := count+1;
1104 until (fileExists(tempFName)=false) or (count> 32);
1105 result := tempFName;
1106 end;
1107
1108var
1109 i,count : integer;
1110 j : word;
1111 OutFile : TFileStream;
1112 s : AnsiString;
1113 Buffer : array[0..1024] of byte;
1114 LocalSaveFNamePath : AnsiString;
1115
1116begin
1117 StatusText('Getting Barcode...');
1118 LocalSaveFNamePath := UniqueFName;
1119 Result := LocalSaveFNamePath; //default to success;
1120
1121 // CallV('TMG BARCODE ENCODE', [MsgStr]);
1122 RPCBrokerV.ClearParameters := true;
1123 RPCBrokerV.remoteprocedure := 'TMG BARCODE ENCODE';
1124 RPCBrokerV.param[0].Value := MsgStr;
1125 RPCBrokerV.param[0].PType := literal;
1126 RPCBrokerV.Param[1].Value := '.X'; //<-- is this needed or used?
1127 RPCBrokerV.Param[1].PType := list;
1128 RPCBrokerV.Param[1].Mult['"IMAGE TYPE"'] := ImageType;
1129 //RPCBrokerV.Call;
1130 CallBroker;
1131
1132 Application.ProcessMessages;
1133 //Note:RPCBrokerV.Results[0]=1 if successful load, =0 if failure
1134 if (RPCBrokerV.Results.Count>0) and (RPCBrokerV.Results[0]='1') then begin
1135 OutFile := TFileStream.Create(LocalSaveFNamePath,fmCreate);
1136 for i:=1 to (RPCBrokerV.Results.Count-1) do begin
1137 s :=Decode(RPCBrokerV.Results[i]);
1138 count := Length(s);
1139 if count>1024 then begin
1140 Result := ''; //failure of load.
1141 break;
1142 end;
1143 for j := 1 to count do Buffer[j-1] := ord(s[j]);
1144 OutFile.Write(Buffer,count);
1145 end;
1146 OutFile.Free;
1147 end else begin
1148 result := '';
1149 end;
1150 StatusText('');
1151end;
1152
1153
1154function TfrmImages.DecodeBarcode(LocalFNamePath,ImageType: AnsiString): AnsiString;
1155//Decode data from barcode on image, or return '' if none
1156//Note: if I could find a cost-effective way of decoding this on client side,
1157// then that code be done here in the function, instead of uploading image
1158// to the server for decoding.
1159const
1160 RefreshInterval = 500;
1161 BlockSize = 512;
1162
1163var
1164 ReadCount : Word;
1165 ParamIndex : LongWord;
1166 j : word;
1167 InFile : TFileStream;
1168 Buffer : array[0..1024] of byte;
1169 RefreshCountdown : integer;
1170 OneLine : AnsiString;
1171 RPCResult : AnsiString;
1172 SavedCursor : TCursor;
1173 totalReadCount : integer;
1174begin
1175 result := ''; //default of failure
1176 if not FileExists(LocalFNamePath) then exit;
1177 try
1178 InFile := TFileStream.Create(LocalFNamePath,fmOpenRead or fmShareCompat);
1179 //Note: I may well cut this out. Most of the delay occurs during
1180 // the RPC call, and I can't make a progress bar change during that...
1181 // (or I could, but I'm not going to change the RPC broker...)
1182 ImageTransferForm.setMax(InFile.Size);
1183 //ImageTransferForm.ResetStartTime;
1184 ImageTransferForm.ProgressMsg.Caption := 'Preparing to upload...';
1185 ImageTransferForm.Show;
1186 totalReadCount := 0;
1187 except
1188 // catch failure here... on eError...
1189 exit;
1190 end;
1191
1192 StatusText('Checking image for barcodes...');
1193 Application.ProcessMessages;
1194
1195 RPCBrokerV.ClearParameters := true;
1196 RPCBrokerV.Param.Clear;
1197 RPCBrokerV.Param[0].PType := list;
1198 ParamIndex := 0;
1199 RefreshCountdown := RefreshInterval;
1200 //Put image data into parameter 0 (ARRAY parameter of RPC on server side)
1201 repeat
1202 ReadCount := InFile.Read(Buffer,BlockSize);
1203 OneLine := '';
1204 totalReadCount := totalReadCount + ReadCount;
1205 ImageTransferForm.updateProgress(totalReadCount);
1206 if ReadCount > 0 then begin
1207 SetLength(OneLine,ReadCount);
1208 for j := 1 to ReadCount do OneLine[j] := char(Buffer[j-1]);
1209 RPCBrokerV.Param[0].Mult[IntToStr(ParamIndex)] := Encode(OneLine);
1210 Inc(ParamIndex);
1211 Dec(RefreshCountdown);
1212 if RefreshCountdown < 1 then begin
1213 Application.ProcessMessages;
1214 RefreshCountdown := RefreshInterval;
1215 end;
1216 end;
1217 until (ReadCount < BlockSize);
1218 RPCBrokerV.Param[1].PType := literal;
1219 RPCBrokerV.Param[1].Value := ImageType;
1220
1221 RPCBrokerV.remoteprocedure := 'TMG BARCODE DECODE';
1222
1223 SavedCursor := Screen.Cursor;
1224 Screen.Cursor := crHourGlass;
1225 ImageTransferForm.ProgressMsg.Caption := 'Uploading file to server...';
1226 Application.ProcessMessages;
1227
1228 CallBroker; //this is the slow step, pass to server and get response.
1229
1230 Screen.Cursor := SavedCursor;
1231 ImageTransferForm.Hide;
1232 //Get result: 1^DecodedMessage, or 0^Error Message
1233 RPCResult := RPCBrokerV.Results[0];
1234 if Piece(RPCResult,'^',1)='0' then begin
1235 MessageDlg(Piece(RPCResult,'^',2),mtError,[mbOK],0);
1236 end else begin
1237 result := Piece(RPCResult,'^',2);
1238 end;
1239
1240 InFile.Free;
1241 StatusText('');
1242end;
1243
1244
1245procedure TfrmImages.EnableAutoScanUploadClick(Sender: TObject);
1246begin
1247 inherited;
1248 AutoScanUpload.Checked := not AutoScanUpload.Checked;
1249 uTMGOptions.WriteBool('Scan Enabled',AutoScanUpload.Checked);
1250end;
1251
1252
1253procedure TfrmImages.PickScanFolderClick(Sender: TObject);
1254var
1255 CurScanDir : string;
1256begin
1257 inherited;
1258 CurScanDir := UploadForm.ScanDir;
1259 OpenDialog.InitialDir := CurScanDir;
1260 MessageDlg('Please pick ANY file in the desired directory.',mtInformation,[mbOK],0);
1261 if OpenDialog.Execute then begin
1262 UploadForm.SetScanDir(ExtractFilePath(OpenDialog.FileName));
1263 end;
1264 AutoScanUpload.Checked := true;
1265end;
1266
1267function TfrmImages.FileSize(fileName : wideString) : Int64;
1268var
1269 sr : TSearchRec;
1270begin
1271 if FindFirst(fileName, faAnyFile, sr ) = 0 then
1272 result := Int64(sr.FindData.nFileSizeHigh) shl Int64(32) + Int64(sr.FindData.nFileSizeLow)
1273 else
1274 result := -1;
1275
1276 FindClose(sr) ;
1277end;
1278
1279initialization
1280 //put init code here
1281
1282finalization
1283 //put finalization code here
1284
1285end.
1286
Note: See TracBrowser for help on using the repository browser.