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

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

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