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

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

update
File size: 45.5 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 RPCResult := RPCBrokerV.Results[0];
705 result := (Piece(RPCResult,'^',1)='1');
706 ImageTransferForm.Hide;
707 if result=false then begin
708 Application.MessageBox('Error uploading file','Error');
709 end;
710
711 InFile.Free;
712 LocalOutFile.Free;
713 StatusText('');
714end;
715
716
717function TfrmImages.DownloadFileViaDropbox(FPath,FName,LocalSaveFNamePath: AnsiString;CurrentImage,TotalImages: Integer): boolean;
718var
719 DropboxFile : AnsiString;
720 CurrentFileSize : Integer;
721 ErrMsg : string;
722begin
723 // CallV('TMG DOWNLOAD FILE DROPBOX', ...);
724 RPCBrokerV.ClearParameters := true;
725 RPCBrokerV.remoteprocedure := 'TMG DOWNLOAD FILE DROPBOX';
726 RPCBrokerV.param[0].PType := literal;
727 RPCBrokerV.param[0].Value := FPath;
728 RPCBrokerV.Param[1].PType := literal;
729 RPCBrokerV.Param[1].Value := FName;
730 RPCBrokerV.Param[2].PType := literal;
731 RPCBrokerV.Param[2].Value := '1'; //see comments in UploadFile re '1' hardcoding
732
733 //RPCBrokerV.Call; //Move file into dropbox.
734 CallBroker;
735 if RPCBrokerV.Results.Count > 0 then begin
736 Result := (Piece(RPCBrokerV.Results[0],'^',1)='1'); //1=success, 0=failure
737 if Result = false then ErrMsg := Piece(RPCBrokerV.Results[0],'^',2);
738 end else begin
739 Result := false;
740 ErrMsg := 'Error communicating with server to retrieve image.';
741 end;
742
743 if Result=true then begin
744 if DirectoryExists(DropboxDir) = False then begin //elh added to ensure a dropbox directory is valid
745 MessageDlg('Invalid Dropbox Directory. Please check your settings and try again.',mtError,[mbOK],0);
746 ImageTransferForm.hide;
747 exit;
748 end;
749 CurrentFileSize := strtoint(Piece(RPCBrokerV.Results[0],'^',3)); //Piece 3 = file size
750 DropboxFile := ExcludeTrailingBackslash(DropboxDir) + '\' + FName;
751 if ImageTransferForm.visible = False then ImageTransferForm.show;
752 while FileSize(DropboxFile) <> CurrentFileSize do sleep(1000); //elh
753 ImageTransferForm.ProgressBar.Max := TotalImages; //elh
754 ImageTransferForm.ProgressBar.Position := CurrentImage+2; //elh
755 if TotalImages = (CurrentImage+2) then begin
756 Sleep(1000);
757 ImageTransferForm.hide;
758 end;
759 //Now move DropBox\FileName --> LocalFileNamePath
760 if MoveFile(pchar(DropboxFile),pchar(LocalSaveFNamePath))=false then begin
761 MessageDlg('Dropbox file transfer failed. Code='+InttoStr(GetLastError),
762 mtError,[mbOK],0);
763 end;
764 end else begin
765 MessageDlg('ERROR: '+ErrMsg,mtError,[mbOK],0);
766 end;
767end;
768
769
770function TfrmImages.DownloadFile(FPath,FName,LocalSaveFNamePath: AnsiString;CurrentImage,TotalImages: Integer): boolean;
771var
772 i,count : integer;
773 j : word;
774 OutFile : TFileStream;
775 s : AnsiString;
776 Buffer : array[0..1024] of byte;
777 RefreshCountdown : integer;
778
779const
780 RefreshInterval = 500;
781
782begin
783 if FileExists(LocalSaveFNamePath) then begin
784 DeleteFile(LocalSaveFNamePath);
785 end;
786 if UseDropBox then begin
787 Result := DownloadFileViaDropBox(FPath,FName,LocalSaveFNamePath,CurrentImage,TotalImages);
788 exit;
789 end;
790 Result := true; //default to success;
791 StatusText('Retrieving full image...');
792 //Note: the '1' in the line below is hard-coding in to use
793 //IEN=1 in file 2005.2 (NETWORK LOCATION). This file will
794 //instruct the server which relative path to store the file into
795 //If I want to have more than one NETWORK LOCATION, then I would
796 //need to create another RPC call that would determine which IEN
797 //to use.
798 //(This would be the same as the IEN stored in fields# 2, 2.1, 2.2
799 // of file 2005 (IMAGE). This in turn is originally obtained from
800 //file IMAGING SITE PARAMETERS
801 CallV('TMG DOWNLOAD FILE', [FPath,FName,'1']);
802 Application.ProcessMessages;
803 RefreshCountdown := RefreshInterval;
804 //Note:RPCBrokerV.Results[0]=1 if successful load, =0 if failure
805 if (RPCBrokerV.Results.Count>0) and (RPCBrokerV.Results[0]='1') then begin
806 OutFile := TFileStream.Create(LocalSaveFNamePath,fmCreate);
807 for i:=1 to (RPCBrokerV.Results.Count-1) do begin
808 s :=Decode(RPCBrokerV.Results[i]);
809 count := Length(s);
810 if count>1024 then begin
811 Result := false; //failure of load.
812 break;
813 end;
814 for j := 1 to count do Buffer[j-1] := ord(s[j]);
815 OutFile.Write(Buffer,count);
816 Dec(RefreshCountdown);
817 if RefreshCountdown < 1 then begin
818 Application.ProcessMessages;
819 RefreshCountdown := RefreshInterval;
820 end;
821 end;
822 OutFile.Free;
823 end else begin
824 result := false;
825 end;
826 StatusText('');
827end;
828
829
830function TfrmImages.Encode(Input: AnsiString) : AnsiString;
831//This function is based on ENCODE^RGUTUU, which is match for
832//DECODE^RGUTUU that is used to decode (ascii armouring) on the
833//server side. This is a base64 encoder.
834const
835 //FYI character set is 64 characters (starting as 'A')
836 // (65 characters if intro '=' is counted)
837 CharSet = '=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
838var
839 //Result : AnsiString; // RGZ1 //'Result' is implicitly declared by Pascal
840
841 i : integer; //RGZ2
842 j : integer; //RGZ4
843 PlainTrio : longword; //RGZ3 //unsigned 32-bit
844 EncodedByte : Byte;
845 PlainByte : byte; //RGZ5
846 EncodedQuad : string[4];//RGZ6
847
848begin
849 //e.g. input (10 bytes):
850 // 174 231 193 16 29 251 93 138 4 57
851 // AE E7 C1 10 1D FB 5D 8A 04 39
852 Result := '';
853 i := 1;
854 while i<= Length(Input) do begin //cycle in groups of 3
855 PlainTrio := 0;
856 EncodedQuad := '';
857 //Get 3 bytes, to be converted into 4 characters eventually.
858 //Fill with 0's if needed to make an even 3-byte group.
859 For j:=0 to 2 do begin
860 //e.g. '174'->PlainByte=174
861 if (i+j) <= Length(Input) then PlainByte := ord(Input[i+j])
862 else PlainByte := 0;
863 PlainTrio := (PlainTrio shl 8) or PlainByte;
864 end;
865 //e.g. first 3 bytes--> PlainTrio= $AEE7C1 (10101110 11100111 11000001)
866 //e.g. last 3 bytes--> PlainTrio= $390000 (00111001 00000000 00000000) (note padded 0's)
867
868 //Take each 6 bits and convert into a character.
869 //e.g. first 3 bytes--> (101011 101110 011111 000001)
870 // 43 46 31 1
871
872 //e.g. last 3 bytes-->(001110 010000 000000 000000) (after redivision)
873 // 14 16 0 0 <-- last 2 bytes are padded 0
874 // ^ last 4 bits of '16' are padded 0's
875 For j := 1 to 4 do begin
876 //e.g. $AEE7C1 --> (43+2)=45 (46+2)=48 (31+2)=33 (1+2)=3
877 // r u f b
878
879 //e.g. $39AF00 --> (14+2)=16 (16+2)=18 (0+2)=2 (0+2)=2
880 // O Q A A <-- 2 padded bytes
881 EncodedByte := (PlainTrio and 63)+2; //63=$3F=b0111111; 0->A 1->B etc
882 EncodedQuad := CharSet[EncodedByte]+ EncodedQuad; //string Concat, not math add
883 PlainTrio := PlainTrio shr 6
884 end;
885
886 //Append result with latest quad
887 Result := Result + EncodedQuad;
888 Inc(i,3);
889 end;
890
891 // e.g. result: rufb .... .... OQAA <-- 2 padded bytes (and part of Q is padded also)
892 i := 3-(Length(Input) mod 3); //returns 1,2,or 3 (3 needs to be set to 0)
893 if (i=3) then i:=0; //e.g. input=10 -> i=2
894 j := Length(Result);
895 //i is the number of padded characters that need to be replaced with '='
896 if i>=1 then Result[j] := '='; //replace 1st paddeded char
897 if i>=2 then Result[Length(Result)-1] := '=';//replace 2nd paddeded char
898 // e.g. result: rufb .... .... OQ==
899
900 //results passed out in Result
901end;
902
903
904function TfrmImages.Decode(Input: AnsiString) : AnsiString;
905//This function is based on DECODE^RGUTUU, which is match for
906//ENCODE^RGUTUU that is used to encode (ascii armouring) on the
907//server side. This is a Base64 decoder
908const
909 //FYI character set is 64 characters (starting as 'A')
910 // (65 characters if intro '=' is counted)
911 CharSet = '=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
912
913var
914 //Result : AnsiString; // RGZ1 //'Result' is implicitly declared by Pascal
915 i : integer; //RGZ2
916 PlainTrio : longword; //RGZ3 //unsigned 32-bit
917 j : integer; //RGZ4
918 EncodedChar : char;
919 PlainInt : integer;
920 PlainByte : byte; //RGZ5
921 DecodedTrio : string[3];//RGZ6
922
923begin
924 Result:='';
925 i := 1;
926 //e.g. input: rufb .... .... OQ==
927
928 while i <= Length(Input) Do begin //cycle in groups of 4
929 PlainTrio :=0;
930 DecodedTrio :='';
931 //Get 4 characters, to be converted into 3 bytes.
932 For j :=0 to 3 do begin
933 //e.g. last 4 chars --> 0A==
934 if (i+j) <= Length(Input) then begin
935 EncodedChar := Input[i+j];
936 PlainInt := Pos(EncodedChar,CharSet)-2; //A=0, B=1 etc.
937 if (PlainInt>=0) then PlainByte := (PlainInt and $FF) else PlainByte := 0;
938 end else PlainByte := 0;
939 //e.g. with last 4 characters:
940 //e.g. '0'->14=(b001110) 'Q'->16=(b010000) '='-> -1 -> 0=(b000000) '=' -> 0=(b000000)
941 //e.g.-- So last PlainTrio = 001110 010000 000000 000000 = 00111001 00000000 00000000
942 //Each encoded character contributes 6 bytes to final 3 bytes.
943 //4 chars * 6 bits/char=24 bits --> 24 bits / 8 bits/byte = 3 bytes
944 PlainTrio := (PlainTrio shl 6) or PlainByte; //PlainTrio := PlainTrio*64 + PlainByte;
945 end;
946 //Now take 3 bytes, and add to cumulative output (in same order)
947 For j :=0 to 2 do begin
948 DecodedTrio := Chr(PlainTrio and $FF) + DecodedTrio; //string concat (not math addition)
949 PlainTrio := PlainTrio shr 8; // PlainTrio := PlainTrio div 256
950 end;
951 //e.g. final DecodedTrio = 'chr($39) + chr(0) + chr(0)'
952 Result := Result + DecodedTrio;
953 Inc(i,4);
954 end;
955
956 //Now remove 1 byte from the output for each '=' in input string
957 //(each '=' represents 1 padded 0 added to allow for even groups of 3)
958 for j :=0 to 1 do begin
959 if (Input[Length(Input)-j] = '=') then begin
960 Result := MidStr(Result,1,Length(Result)-1);
961 end;
962 end;
963end;
964
965procedure TfrmImages.NewNoteSelected(EditIsActive : boolean);
966//Will be called by fNotes when a new note has been selected.
967//var
968begin
969 ClearTabPages();
970 CurImageToLoad := 0; //a -1 would signal that no images avail to load.
971 //this will start downloading images after 5 second delay (so that if
972 //user is just browsing past note, this won't waste effort.
973 //If user selects images tab, then load will occur without delay.
974 timLoadImages.Enabled := true;
975 timLoadImages.Interval := 60000; //60 sec delay -- also set in timLoadImagesTimer
976 //Note: OnTimer calls timLoadImagesTimer()
977 UploadImagesButton.Enabled := EditIsActive;
978 UploadImagesMnuAction.Enabled := EditIsActive;
979 WebBrowser.Navigate(NullImageName);
980end;
981
982
983procedure TfrmImages.EmptyCache();
984//This will delete ALL files in the Cache directory
985//Note: This will include the html_note file created by
986// the notes tab.
987var
988 //CacheDir : AnsiString;
989 FoundFile : boolean;
990 FSearch : TSearchRec;
991 Files : TStringList;
992 i : integer;
993 FName : AnsiString;
994
995begin
996 Files := TStringList.Create;
997// CacheDir := ExtractFilePath(ParamStr(0))+ 'Cache';
998 FoundFile := (FindFirst(CacheDir+'\*.*',faAnyFile,FSearch)=0);
999 while FoundFile do Begin
1000 FName := FSearch.Name;
1001 if (FName <> '.') and (FName <> '..') then begin
1002 FName := CacheDir + '\' + FName;
1003 Files.Add(FName);
1004 end;
1005 FoundFile := (FindNext(FSearch)=0);
1006 end;
1007
1008 for i := 0 to Files.Count-1 do begin
1009 FName := Files.Strings[i];
1010 if DeleteFile(FName) = false then begin
1011 //kt raise Exception.Create('Unable to delete file: '+FSearch.Name+#13+'Will try again later...');
1012 end;
1013 end;
1014 Files.Free;
1015end;
1016
1017
1018
1019procedure TfrmImages.UploadImagesButtonClick(Sender: TObject);
1020var
1021 Node: TORTreeNode;
1022 AddResult : TModalResult;
1023begin
1024 inherited;
1025 AddResult := UploadForm.ShowModal;
1026 if not IsAbortResult(AddResult) then begin
1027 NewNoteSelected(true); //force a reload to show recently added image.
1028 timLoadImages.Interval := 100;
1029 Node := TORTreeNode(frmNotes.tvNotes.Selected);
1030 case Node.StateIndex of
1031 IMG_NO_IMAGES : Node.StateIndex := IMG_1_IMAGE;
1032 IMG_1_IMAGE : Node.StateIndex := IMG_2_IMAGES;
1033 IMG_2_IMAGES : Node.StateIndex := IMG_MANY_IMAGES;
1034 IMG_MANY_IMAGES : Node.StateIndex := IMG_MANY_IMAGES;
1035 end;
1036 end;
1037end;
1038
1039procedure TfrmImages.FormHide(Sender: TObject);
1040begin
1041 inherited;
1042// Application.MessageBox('Here I can hide images.','title');
1043end;
1044
1045procedure TfrmImages.TabControlChange(Sender: TObject);
1046var
1047 FileName : AnsiString;
1048 Rec : TImageInfo;
1049 Selected : integer;
1050begin
1051 inherited;
1052 //here tab has been changed.
1053 Selected := TabControl.TabIndex;
1054 if Selected > -1 then begin
1055 Rec := TImageInfo(ImageInfoList[Selected]);
1056 FileName := Rec.CacheFName;
1057 UpdateImageInfoMemo(Rec);
1058 end else begin
1059 FileName := NullImageName;
1060 UpdateImageInfoMemo(nil);
1061 end;
1062 WebBrowser.Navigate(FileName);
1063end;
1064
1065procedure TfrmImages.TabControlGetImageIndex(Sender: TObject;
1066 TabIndex: Integer;
1067 var ImageIndex: Integer);
1068//specify which image to display, from ThumbsImageList
1069begin
1070 inherited;
1071 if (ImageInfoList <> nil) and (TabIndex < ImageInfoList.Count) then begin
1072 ImageIndex := TImageInfo(ImageInfoList[TabIndex]).TabImageIndex;
1073 end else ImageIndex := 0;
1074end;
1075
1076procedure TfrmImages.TabControlResize(Sender: TObject);
1077begin
1078 inherited;
1079 if TabControl.Width < 80 then begin
1080 TabControl.Width := 80;
1081 end;
1082end;
1083
1084function TfrmImages.CreateBarcode(MsgStr: AnsiString; ImageType: AnsiString): AnsiString;
1085//Create a local barcode file, in .png format, from MsgStr
1086//ImageType is optional, default ='png'. It should NOT contain '.'
1087//Returns file path on local client of new barcode image.
1088//Note: this function is not related to uploading or downloading images
1089// to the server for attaching to progress notes. It is included
1090// in this unit because the functionality used is nearly identical to
1091// the other code.
1092 function UniqueFName : AnsiString;
1093 var FName,tempFName : AnsiString;
1094 count : integer;
1095 begin
1096 FName := 'Barcode-Image';
1097 count := 0;
1098 repeat
1099 tempFName := CacheDir + '\' + FName + '.' + ImageType;
1100 FName := FName + '1';
1101 count := count+1;
1102 until (fileExists(tempFName)=false) or (count> 32);
1103 result := tempFName;
1104 end;
1105
1106var
1107 i,count : integer;
1108 j : word;
1109 OutFile : TFileStream;
1110 s : AnsiString;
1111 Buffer : array[0..1024] of byte;
1112 LocalSaveFNamePath : AnsiString;
1113
1114begin
1115 StatusText('Getting Barcode...');
1116 LocalSaveFNamePath := UniqueFName;
1117 Result := LocalSaveFNamePath; //default to success;
1118
1119 // CallV('TMG BARCODE ENCODE', [MsgStr]);
1120 RPCBrokerV.ClearParameters := true;
1121 RPCBrokerV.remoteprocedure := 'TMG BARCODE ENCODE';
1122 RPCBrokerV.param[0].Value := MsgStr;
1123 RPCBrokerV.param[0].PType := literal;
1124 RPCBrokerV.Param[1].Value := '.X'; //<-- is this needed or used?
1125 RPCBrokerV.Param[1].PType := list;
1126 RPCBrokerV.Param[1].Mult['"IMAGE TYPE"'] := ImageType;
1127 //RPCBrokerV.Call;
1128 CallBroker;
1129
1130 Application.ProcessMessages;
1131 //Note:RPCBrokerV.Results[0]=1 if successful load, =0 if failure
1132 if (RPCBrokerV.Results.Count>0) and (RPCBrokerV.Results[0]='1') then begin
1133 OutFile := TFileStream.Create(LocalSaveFNamePath,fmCreate);
1134 for i:=1 to (RPCBrokerV.Results.Count-1) do begin
1135 s :=Decode(RPCBrokerV.Results[i]);
1136 count := Length(s);
1137 if count>1024 then begin
1138 Result := ''; //failure of load.
1139 break;
1140 end;
1141 for j := 1 to count do Buffer[j-1] := ord(s[j]);
1142 OutFile.Write(Buffer,count);
1143 end;
1144 OutFile.Free;
1145 end else begin
1146 result := '';
1147 end;
1148 StatusText('');
1149end;
1150
1151
1152function TfrmImages.DecodeBarcode(LocalFNamePath,ImageType: AnsiString): AnsiString;
1153//Decode data from barcode on image, or return '' if none
1154//Note: if I could find a cost-effective way of decoding this on client side,
1155// then that code be done here in the function, instead of uploading image
1156// to the server for decoding.
1157const
1158 RefreshInterval = 500;
1159 BlockSize = 512;
1160
1161var
1162 ReadCount : Word;
1163 ParamIndex : LongWord;
1164 j : word;
1165 InFile : TFileStream;
1166 Buffer : array[0..1024] of byte;
1167 RefreshCountdown : integer;
1168 OneLine : AnsiString;
1169 RPCResult : AnsiString;
1170 SavedCursor : TCursor;
1171 totalReadCount : integer;
1172begin
1173 result := ''; //default of failure
1174 if not FileExists(LocalFNamePath) then exit;
1175 try
1176 InFile := TFileStream.Create(LocalFNamePath,fmOpenRead or fmShareCompat);
1177 //Note: I may well cut this out. Most of the delay occurs during
1178 // the RPC call, and I can't make a progress bar change during that...
1179 // (or I could, but I'm not going to change the RPC broker...)
1180 ImageTransferForm.setMax(InFile.Size);
1181 //ImageTransferForm.ResetStartTime;
1182 ImageTransferForm.ProgressMsg.Caption := 'Preparing to upload...';
1183 ImageTransferForm.Show;
1184 totalReadCount := 0;
1185 except
1186 // catch failure here... on eError...
1187 exit;
1188 end;
1189
1190 StatusText('Checking image for barcodes...');
1191 Application.ProcessMessages;
1192
1193 RPCBrokerV.ClearParameters := true;
1194 RPCBrokerV.Param.Clear;
1195 RPCBrokerV.Param[0].PType := list;
1196 ParamIndex := 0;
1197 RefreshCountdown := RefreshInterval;
1198 //Put image data into parameter 0 (ARRAY parameter of RPC on server side)
1199 repeat
1200 ReadCount := InFile.Read(Buffer,BlockSize);
1201 OneLine := '';
1202 totalReadCount := totalReadCount + ReadCount;
1203 ImageTransferForm.updateProgress(totalReadCount);
1204 if ReadCount > 0 then begin
1205 SetLength(OneLine,ReadCount);
1206 for j := 1 to ReadCount do OneLine[j] := char(Buffer[j-1]);
1207 RPCBrokerV.Param[0].Mult[IntToStr(ParamIndex)] := Encode(OneLine);
1208 Inc(ParamIndex);
1209 Dec(RefreshCountdown);
1210 if RefreshCountdown < 1 then begin
1211 Application.ProcessMessages;
1212 RefreshCountdown := RefreshInterval;
1213 end;
1214 end;
1215 until (ReadCount < BlockSize);
1216 RPCBrokerV.Param[1].PType := literal;
1217 RPCBrokerV.Param[1].Value := ImageType;
1218
1219 RPCBrokerV.remoteprocedure := 'TMG BARCODE DECODE';
1220
1221 SavedCursor := Screen.Cursor;
1222 Screen.Cursor := crHourGlass;
1223 ImageTransferForm.ProgressMsg.Caption := 'Uploading file to server...';
1224 Application.ProcessMessages;
1225
1226 CallBroker; //this is the slow step, pass to server and get response.
1227
1228 Screen.Cursor := SavedCursor;
1229 ImageTransferForm.Hide;
1230 //Get result: 1^DecodedMessage, or 0^Error Message
1231 RPCResult := RPCBrokerV.Results[0];
1232 if Piece(RPCResult,'^',1)='0' then begin
1233 MessageDlg(Piece(RPCResult,'^',2),mtError,[mbOK],0);
1234 end else begin
1235 result := Piece(RPCResult,'^',2);
1236 end;
1237
1238 InFile.Free;
1239 StatusText('');
1240end;
1241
1242
1243procedure TfrmImages.EnableAutoScanUploadClick(Sender: TObject);
1244begin
1245 inherited;
1246 AutoScanUpload.Checked := not AutoScanUpload.Checked;
1247 uTMGOptions.WriteBool('Scan Enabled',AutoScanUpload.Checked);
1248end;
1249
1250
1251procedure TfrmImages.PickScanFolderClick(Sender: TObject);
1252var
1253 CurScanDir : string;
1254begin
1255 inherited;
1256 CurScanDir := UploadForm.ScanDir;
1257 OpenDialog.InitialDir := CurScanDir;
1258 MessageDlg('Please pick ANY file in the desired directory.',mtInformation,[mbOK],0);
1259 if OpenDialog.Execute then begin
1260 UploadForm.SetScanDir(ExtractFilePath(OpenDialog.FileName));
1261 end;
1262 AutoScanUpload.Checked := true;
1263end;
1264
1265function TfrmImages.FileSize(fileName : wideString) : Int64;
1266var
1267 sr : TSearchRec;
1268begin
1269 if FindFirst(fileName, faAnyFile, sr ) = 0 then
1270 result := Int64(sr.FindData.nFileSizeHigh) shl Int64(32) + Int64(sr.FindData.nFileSizeLow)
1271 else
1272 result := -1;
1273
1274 FindClose(sr) ;
1275end;
1276
1277initialization
1278 //put init code here
1279
1280finalization
1281 //put finalization code here
1282
1283end.
1284
Note: See TracBrowser for help on using the repository browser.