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

Last change on this file since 498 was 453, checked in by Kevin Toppenberg, 16 years ago

Initial upload of TMG-CPRS 1.0.26.69
File size: 32.0 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 Panel1: TPanel;
67 Splitter1: TSplitter;
68 Splitter2: TSplitter;
69 UploadImagesButton: TBitBtn;
70 OpenPictureDialog: TOpenPictureDialog;
71 ButtonPanel: TPanel;
72 CurrentImageMemo: TMemo;
73 MemosPanel: TPanel;
74 UploadImagesMnuAction: TMenuItem;
75 Panel2: TPanel;
76 TabControl: TTabControl;
77 WebBrowser: TWebBrowser;
78 procedure mnuChartTabClick(Sender: TObject);
79 procedure mnuActNewClick(Sender: TObject);
80 procedure timLoadImagesTimer(Sender: TObject);
81 procedure FormCreate(Sender: TObject);
82 procedure FormDestroy(Sender: TObject);
83 procedure FormShow(Sender: TObject);
84 procedure mnuActClick(Sender: TObject);
85 procedure UploadImagesButtonClick(Sender: TObject);
86 procedure FormHide(Sender: TObject);
87 procedure TabControlChange(Sender: TObject);
88 procedure TabControlGetImageIndex(Sender: TObject; TabIndex: Integer;
89 var ImageIndex: Integer);
90 procedure TabControlResize(Sender: TObject);
91 private
92 ImageInfoList : TList;
93 LastDisplayedTIUIEN : AnsiString;
94 CurImageToLoad : integer;
95 InTimerFn : Boolean;
96 procedure EnsureImageListLoaded();
97 procedure ClearImageList();
98 procedure DownloadToCache(ImageIndex : integer);
99 procedure EmptyCache();
100 procedure ClearTabPages();
101 procedure SetupTab(i : integer);
102 procedure UpdateNoteInfoMemo();
103 procedure UpdateImageInfoMemo(Rec: TImageInfo);
104 public
105 CacheDir : AnsiString;
106 NullImageName : AnsiString;
107 function Decode(input: AnsiString) : AnsiString;
108 function Encode(input: AnsiString) : AnsiString;
109 function DownloadFile(FPath,FName,LocalSaveFNamePath: AnsiString): boolean;
110 function UploadFile(LocalFNamePath,FPath,FName: AnsiString): boolean;
111 procedure SplitLinuxFilePath(FullPathName : AnsiString;
112 var Path : AnsiString;
113 var FName : AnsiString);
114 procedure GetImageList();
115 procedure NewNoteSelected(EditIsActive : boolean);
116 published
117 end;
118
119var
120 frmImages: TfrmImages;
121
122
123implementation
124
125{$R *.DFM}
126
127uses fFrame, fVisit, fEncnt, rCore, uCore, fNoteBA, fNoteBD, fSignItem, fEncounterFrame,
128 rPCE, Clipbrd, fNoteCslt, fNotePrt, rVitals, fAddlSigners, fNoteDR, fConsults, uSpell,
129 fTIUView, fTemplateEditor, uReminders, fReminderDialog, uOrders, rConsults, fReminderTree,
130 fNoteProps, fNotesBP, fTemplateFieldEditor, dShared, rTemplates,
131 FIconLegend, fPCEEdit, fNoteIDParents, rSurgery, uSurgery, uTemplates,
132 uAccessibleTreeView, uAccessibleTreeNode, fTemplateDialog, DateUtils,
133 StrUtils {//KT added 1-1-05},
134 mshtml, {//kt added 5-2-05}
135 UploadImages, {//kt added 9/25/05}
136 UPloadProgress, {//kt 10-1-05}
137 rHTMLTools, fNotes; {//kt added 5-27-05 for IsHTMLDocument}
138
139
140procedure TfrmImages.timLoadImagesTimer(Sender: TObject);
141begin
142 inherited;
143 if InTimerFn=false then begin
144 InTimerFn := true;
145 EnsureImageListLoaded(); //only does RPC call if CurImageToLoad = 0
146 if CurImageToLoad <> -1 then begin //-1 means RPC-> no avail images.
147 if CurImageToLoad < ImageInfoList.Count then begin
148 DownloadToCache(CurImageToLoad); //Only load 1 image per timer firing.
149 SetupTab(CurImageToLoad);
150 Inc(CurImageToLoad);
151 if TabControl.TabIndex < 0 then TabControl.TabIndex := 0;
152 TabControlChange(self);
153 end else begin
154 timLoadImages.Enabled := false;
155 end;
156 end;
157 InTimerFn := false;
158 if self.Visible = true then begin
159 timLoadImages.Interval :=100;
160 end else begin
161 timLoadImages.Interval :=30000; //30 sec delay
162 end;
163 end;
164end;
165
166
167{ TPage common methods --------------------------------------------------------------------- }
168procedure TfrmImages.mnuChartTabClick(Sender: TObject);
169{ reroute to Chart Tab menu of the parent form: frmFrame }
170begin
171 inherited;
172 frmFrame.mnuChartTabClick(Sender);
173end;
174
175
176procedure TfrmImages.mnuActNewClick(Sender: TObject);
177const
178 IS_ID_CHILD = False;
179{ switches to current new note or creates a new note if none is being edited already }
180begin
181 inherited;
182end;
183
184procedure TfrmImages.FormCreate(Sender: TObject);
185//var i : integer;
186begin
187 inherited;
188 InTimerFn:=false;
189 LastDisplayedTIUIEN := '0';
190 ImageInfoList := TList.Create;
191 CurImageToLoad := 0;
192 CacheDir := ExtractFilePath(ParamStr(0))+ 'Cache';
193 NullImageName := ExtractFilePath(ParamStr(0)) + 'images\blank.htm';
194 if not DirectoryExists(CacheDir) then ForceDirectories(CacheDir);
195end;
196
197procedure TfrmImages.FormDestroy(Sender: TObject);
198begin
199 inherited;
200 ClearImageList;
201 ImageInfoList.Free;
202 EmptyCache;
203end;
204
205procedure TfrmImages.FormShow(Sender: TObject);
206var
207 TIUIEN : AnsiString;
208
209begin
210 inherited;
211 TIUIEN := IntToStr(frmNotes.lstNotes.ItemID);
212 timLoadImages.Enabled := true;
213 timLoadImages.Interval := 100;
214 if LastDisplayedTIUIEN <> TIUIEN then begin
215 UpdateNoteInfoMemo();
216 LastDisplayedTIUIEN := TIUIEN;
217 end;
218end;
219
220procedure TfrmImages.mnuActClick(Sender: TObject);
221begin
222 inherited;
223
224end;
225
226{ General procedures ----------------------------------------------------------------------- }
227
228procedure TfrmImages.UpdateImageInfoMemo(Rec : TImageInfo);
229var s : AnsiString;
230 i : integer;
231begin
232 CurrentImageMemo.Lines.Clear;
233 if Rec=nil then exit;
234 s := Trim(Rec.ShortDesc);
235 if s <> '' then CurrentImageMemo.Lines.Add('Description: ' + s);
236 s := Rec.ProcName;
237 if s <> '' then CurrentImageMemo.Lines.Add('Procedure: ' + s);
238 s := Rec.DisplayDate;
239 if s <> '' then CurrentImageMemo.Lines.Add('Upload Date: ' + s);
240 //s := Rec.DateTime;
241 //if s <> '' then CurrentImageMemo.Lines.Add('Date/Time: ' + s);
242 if Rec.LongDesc <> nil then begin
243 CurrentImageMemo.Lines.Add('Long Description:');
244 for i := 0 to Rec.LongDesc.Count-1 do begin
245 CurrentImageMemo.Lines.Add(' ' + Rec.LongDesc.Strings[i]);
246 end;
247 end;
248end;
249
250
251procedure TfrmImages.UpdateNoteInfoMemo();
252var
253 NoteInfo,s : AnsiString;
254 //dateS : AnsiString;
255const
256 U='^';
257begin
258 CurrentNoteMemo.Lines.Clear;
259 with frmNotes.lstNotes do begin
260 if ItemIndex > -1 then begin
261 NoteInfo := Items[ItemIndex]
262 (* example NoteInfo:
263 piece# 1: 14321^ //TIU IEN
264 piece# 2: PRESCRIPTION CALL IN^ //Document Title
265 piece# 3: 3050713.0947^ //Date/Time
266 piece# 4: TEST, KILLME D (T0101)^ //Patient
267 piece# 5: 133;JANE A DOE;DOE,JANE A^ //Author
268 piece# 6: Main_Office^ //Location of Visit
269 piece# 7: completed^ //Status of Document
270 piece# 8: Visit: 07/13/05;3050713.094721^ //Date/Time
271 piece# 9...: ;^^1^^^1^' //?
272 *)
273 end else NoteInfo := '';
274 end;
275 if NoteInfo <>'' then begin
276 s := Piece(NoteInfo, U, 2) + ' -- ';
277 s := s + Piece(Piece(NoteInfo, U, 8), ';', 1);
278 CurrentNoteMemo.Lines.Add(s);
279 s := 'Location: ' + Piece(NoteInfo, U, 6) + ' -- ';
280 s := s + 'Note Author: ' + Piece(Piece(NoteInfo, U, 5), ';', 2);
281 CurrentNoteMemo.Lines.Add(s);
282 end;
283end;
284
285procedure TfrmImages.SetupTab(i : integer);
286//i is index in ImageInfoList (array of TImageInfo's)
287var
288 Rec : TImageInfo; //this will be a copy of record, not pointer (I think)
289 Bitmap : TBitmap;
290 index : integer;
291 Ext : AnsiString;
292
293 (*Notice: A TabControl doesn't directly support specifying which
294 images in an ImageList to show for a given tab. To get
295 around this, the help documentation recommends setting up
296 a TabControlGetImageIndex event handler.
297 I am doing this. When the event is called, then RecInfo.TabImageIndex
298 is returned.
299 *)
300
301begin
302 if i < ImageInfoList.Count then begin
303 Rec := TImageInfo(ImageInfoList[i]);
304 if (Rec.TabImageIndex < 1) then begin
305 if FileExists(Rec.CacheThumbFName) then begin
306 Bitmap := TBitmap.Create;
307 Bitmap.Width := 1024; //something big enough to hold any thumbnail.
308 Bitmap.Height := 768;
309 Bitmap.LoadFromFile(Rec.CacheThumbFName);
310 Bitmap.Width := ThumbsImageList.Width; //shrinkage crops image
311 Bitmap.Height := ThumbsImageList.Height;
312 index := ThumbsImageList.Add(Bitmap,nil);
313 TImageInfo(ImageInfoList[i]).TabImageIndex := index;
314 Bitmap.Free;
315 end else begin
316 Ext := LowerCase(ExtractFileExt(Rec.CacheFName));
317 Ext := MidStr(Ext,2,99);
318 if (Ext='jpg')
319 or (Ext='jpeg')
320 or (Ext='png')
321 or (Ext='tif')
322 or (Ext='tiff')
323 or (Ext='gif')
324 or (Ext='bmp') then begin
325 TImageInfo(ImageInfoList[i]).TabImageIndex := 0; //camera image
326 end else
327 if (Ext='pdf') then begin
328 TImageInfo(ImageInfoList[i]).TabImageIndex := 1; //adobe icon
329 end else
330 if (Ext='avi')
331 or (Ext='qt')
332 or (Ext='mpg')
333 or (Ext='mpeg') then begin
334 TImageInfo(ImageInfoList[i]).TabImageIndex := 2; //video icon
335 end else
336 if (Ext='mp3')
337 or (Ext='wma')
338 or (Ext='au')
339 or (Ext='wav') then begin
340 TImageInfo(ImageInfoList[i]).TabImageIndex := 3; //sound icon
341 end else
342 begin
343 TImageInfo(ImageInfoList[i]).TabImageIndex := 4; // misc icon
344 end;
345 end;
346 end;
347 TabControl.Tabs.Add(' '); //add the tab. Thumbnail should exist before this
348 end;
349end;
350
351
352procedure TfrmImages.ClearTabPages();
353begin
354 TabControl.Tabs.Clear;
355 ClearImageList();
356end;
357
358
359procedure TfrmImages.ClearImageList();
360//Note: !! This should also clear any visible images/thumbnails etc.
361var i : integer;
362begin
363 for i := ImageInfoList.Count-1 downto 0 do begin
364 if TImageInfo(ImageInfoList[i]).LongDesc <> nil then begin
365 TImageInfo(ImageInfoList[i]).LongDesc.Free;
366 end;
367 TImageInfo(ImageInfoList[i]).Free;
368 ImageInfoList.Delete(i);
369 end;
370end;
371
372
373procedure TfrmImages.EnsureImageListLoaded();
374begin
375 if CurImageToLoad = 0 then begin
376 GetImageList();
377 if ImageInfoList.Count=0 then CurImageToLoad := -1;
378 end;
379end;
380
381procedure TfrmImages.GetImageList();
382var
383 i,j : integer;
384 s,s2 : AnsiString;
385 Rec : TImageInfo;
386 ImageIEN : integer;
387 TIUIEN : AnsiString;
388 ServerFName : AnsiString;
389 ServerPathName : AnsiString;
390 ImageFPathName : AnsiString; //path on server of image -- original data provided by server
391 ThumbnailFPathName : AnsiString; //path on server of thumbnail -- original data provided by server
392
393begin
394 inherited;
395 ClearImageList;
396 try
397 TIUIEN := IntToStr(frmNotes.lstNotes.ItemID);
398 StatusText('Retrieving images information...');
399 CallV('MAG3 CPRS TIU NOTE', [TIUIEN]);
400 for i:=0 to (RPCBrokerV.Results.Count-1) do begin
401 s :=RPCBrokerV.Results[i];
402 if i=0 then begin
403 if piece(s,'^',1)='0' then break //i.e. abort due to error signal
404 else continue; //ignore rest of header (record #0)
405 end;
406 Rec := TImageInfo.Create; // ImageInfoList will own this.
407 Rec.LongDesc := nil;
408 Rec.TabIndex := -1;
409 Rec.TabImageIndex := 0;
410 s2 := piece(s,'^',2); if s2='' then s2 := '0'; //IEN
411 Rec.IEN := StrToInt(s2);
412 ImageFPathName := piece(s,'^',3); //Image FullPath and name
413 ThumbnailFPathName := piece(s,'^',4); //Abstract FullPath and Name
414 Rec.ShortDesc := piece(s,'^',5); //SHORT DESCRIPTION field
415 s2 := piece(s,'^',6); if s2='' then s2 := '0'; //PROCEDURE/ EXAM DATE/TIME field
416 Rec.DateTime := s2;
417 s2 := piece(s,'^',7); if s2='' then s2 := '0'; //OBJECT TYPE
418 Rec.ImageType := StrToInt(s2);
419 Rec.ProcName := piece(s,'^',8); //PROCEDURE field
420 Rec.DisplayDate := piece(s,'^',9); //Procedure Date in Display format
421 s2 := piece(s,'^',10); if s2='' then s2 := '0'; //PARENT DATA FILE image pointer
422 Rec.ParentDataFileIEN := StrToInt(s2);
423 Rec.AbsType := piece(s,'^',11)[1]; //the ABSTYPE : 'M' magnetic 'W' worm 'O' offline
424 Rec.Accessibility := piece(s,'^',12)[1]; //Image accessibility 'A' accessable or 'O' offline
425 s2 := piece(s,'^',13); if s2='' then s2 := '0'; //Dicom Series number
426 Rec.DicomSeriesNum := StrToInt(s2);
427 s2 := piece(s,'^',14); if s2='' then s2 := '0'; //Dicom Image Number
428 Rec.DicomImageNum := StrToInt(s2);
429 s2 := piece(s,'^',15); if s2='' then s2 := '0'; //Count of images in the group, or 1 if a single image
430 Rec.GroupCount := StrToInt(s2);
431
432 SplitLinuxFilePath(ImageFPathName,ServerPathName,ServerFName);
433 Rec.ServerPathName := ServerPathName;
434 Rec.ServerFName := ServerFName;
435 Rec.CacheFName := CacheDir + '\' + ServerFName;
436 SplitLinuxFilePath(ThumbnailFPathName,ServerPathName,ServerFName);
437 Rec.ServerThumbPathName := ServerPathName;
438 Rec.ServerThumbFName := ServerFName;
439 Rec.CacheThumbFName := CacheDir + '\' + ServerFName;
440 ImageInfoList.Add(Rec); // ImageInfoList will own Rec.
441 end;
442 for i:= 0 to ImageInfoList.Count-1 do begin
443 Rec := TImageInfo(ImageInfoList.Items[i]);
444 ImageIEN := Rec.IEN;
445 CallV('TMG GET IMAGE LONG DESCRIPTION', [ImageIEN]);
446 for j:=0 to (RPCBrokerV.Results.Count-1) do begin
447 if (j>0) then begin
448 if Rec.LongDesc = nil then Rec.LongDesc := TStringList.Create;
449 Rec.LongDesc.Add(RPCBrokerV.Results.Strings[j]);
450 end else begin
451 if RPCBrokerV.Results[j]='' then break;
452 end;
453 end;
454 end;
455 except
456 //Error occurs after note is signed, and frmNotes.lstNotes.ItemID is "inaccessible"
457 on E: Exception do exit;
458 end;
459 StatusText('');
460end;
461
462
463procedure TfrmImages.DownloadToCache(ImageIndex : integer);
464//Loads image specified in ImageInfoList to Cache (unless already present)
465var
466 Rec : TImageInfo;
467 ServerFName : AnsiString;
468 ServerPathName : AnsiString;
469
470begin
471 Rec := TImageInfo(ImageInfoList[ImageIndex]);
472 ServerFName := Rec.ServerFName;
473 ServerPathName := Rec.ServerPathName;
474 if not FileExists(Rec.CacheFName) then begin
475 DownloadFile(ServerPathName,ServerFName,Rec.CacheFName);
476 end;
477 ServerFName := Rec.ServerThumbFName;
478 ServerPathName := Rec.ServerThumbPathName;
479 if not FileExists(Rec.CacheThumbFName) then begin
480 DownloadFile(ServerPathName,ServerFName,Rec.CacheThumbFName);
481 end;
482 Application.ProcessMessages;
483end;
484
485procedure TfrmImages.SplitLinuxFilePath(FullPathName : AnsiString;
486 var Path : AnsiString;
487 var FName : AnsiString);
488var p : integer;
489begin
490 Path := ''; FName := '';
491 repeat
492 p := Pos('/',FullPathName);
493 if p > 0 then begin
494 Path := Path + MidStr(FullPathName,1,p);
495 FullPathName := MidStr(FullPathName,p+1,1000);
496 end else begin
497 FName := FullPathName;
498 FullPathName := '';
499 end;
500 until (FullPathName = '');
501end;
502
503
504function TfrmImages.UploadFile(LocalFNamePath,FPath,FName: AnsiString): boolean;
505const
506 RefreshInterval = 500;
507 BlockSize = 512;
508
509var
510 ReadCount : Word;
511 totalReadCount : Integer;
512 ParamIndex : LongWord;
513 j : word;
514 InFile : TFileStream;
515 LocalOutFile : TFileStream;
516 Buffer : array[0..1024] of byte;
517 RefreshCountdown : integer;
518 OneLine : AnsiString;
519 RPCResult : AnsiString;
520 SavedCursor : TCursor;
521
522begin
523 result := false; //default of failure
524 if not FileExists(LocalFNamePath) then exit;
525 try
526 InFile := TFileStream.Create(LocalFNamePath,fmOpenRead or fmShareCompat);
527 LocalOutFile := TFileStream.Create(CacheDir+'\'+FName,fmCreate or fmOpenWrite); //for local copy
528 //Note: I may well cut this out. Most of the delay occurs during
529 // the RPC call, and I can't make a progress bar change during that...
530 // (or I could, but I'm not going to change the RPC broker...)
531 UploadProgressForm.setMax(InFile.Size);
532 //UploadProgressForm.ResetStartTime;
533 UploadProgressForm.ProgressMsg.Caption := 'Prepairing to upload...';
534 UploadProgressForm.Show;
535 totalReadCount := 0;
536 except
537 // catch failure here... on eError...
538 exit;
539 end;
540
541 StatusText('Uploading full image...');
542 Application.ProcessMessages;
543
544 RPCBrokerV.ClearParameters := true;
545 RPCBrokerV.Param[0].PType := literal;
546 RPCBrokerV.Param[0].Value := FPath;
547 RPCBrokerV.Param[1].PType := literal;
548 RPCBrokerV.Param[1].Value := FName;
549 RPCBrokerV.Param[2].PType := literal;
550 RPCBrokerV.Param[2].Value := '1';
551 //Note: the '1' in the line above is hard-coding in to use
552 //IEN=1 in file 2005.2 (NETWORK LOCATION). This file will
553 //instruct the server which relative path to store the file into
554 //If I want to have more than one NETWORK LOCATION, then I would
555 //need to create another RPC call that would determine which IEN
556 //to use.
557 //(This would be the same as the IEN stored in fields# 2, 2.1, 2.2
558 // of file 2005 (IMAGE). This in turn is originally obtained from
559 //file IMAGING SITE PARAMETERS
560
561 RPCBrokerV.Param[3].PType := list;
562
563 ParamIndex := 0;
564 RefreshCountdown := RefreshInterval;
565 repeat
566 ReadCount := InFile.Read(Buffer,BlockSize);
567 LocalOutFile.Write(Buffer,ReadCount); //for local copy
568 totalReadCount := totalReadCount + ReadCount;
569 UploadProgressForm.updateProgress(totalReadCount);
570 OneLine := '';
571 if ReadCount > 0 then begin
572 SetLength(OneLine,ReadCount);
573 for j := 1 to ReadCount do OneLine[j] := char(Buffer[j-1]);
574 RPCBrokerV.Param[3].Mult[IntToStr(ParamIndex)] := Encode(OneLine);
575 Inc(ParamIndex);
576
577 Dec(RefreshCountdown);
578 if RefreshCountdown < 1 then begin
579 Application.ProcessMessages;
580 RefreshCountdown := RefreshInterval;
581 end;
582
583 end;
584 until (ReadCount < BlockSize);
585
586 RPCBrokerV.remoteprocedure := 'TMG UPLOAD FILE';
587
588 SavedCursor := Screen.Cursor;
589 Screen.Cursor := crHourGlass;
590 UploadProgressForm.ProgressMsg.Caption := 'Uploading file to server...';
591 Application.ProcessMessages;
592
593 CallBroker;
594 Screen.Cursor := SavedCursor;
595 RPCResult := RPCBrokerV.Results[0];
596 result := (Piece(RPCResult,'^',1)='1');
597 UploadProgressForm.Hide;
598 if result=false then begin
599 Application.MessageBox('Error uploading file','Error');
600 end;
601
602 InFile.Free;
603 LocalOutFile.Free;
604 StatusText('');
605end;
606
607
608function TfrmImages.DownloadFile(FPath,FName,LocalSaveFNamePath: AnsiString): boolean;
609var
610 i,count : integer;
611 j : word;
612 OutFile : TFileStream;
613 s : AnsiString;
614 Buffer : array[0..1024] of byte;
615 RefreshCountdown : integer;
616
617const
618 RefreshInterval = 500;
619
620begin
621 if FileExists(LocalSaveFNamePath) then begin
622 DeleteFile(LocalSaveFNamePath);
623 end;
624 Result := true; //default to success;
625 StatusText('Retrieving full image...');
626 //Note: the '1' in the line below is hard-coding in to use
627 //IEN=1 in file 2005.2 (NETWORK LOCATION). This file will
628 //instruct the server which relative path to store the file into
629 //If I want to have more than one NETWORK LOCATION, then I would
630 //need to create another RPC call that would determine which IEN
631 //to use.
632 //(This would be the same as the IEN stored in fields# 2, 2.1, 2.2
633 // of file 2005 (IMAGE). This in turn is originally obtained from
634 //file IMAGING SITE PARAMETERS
635 CallV('TMG DOWNLOAD FILE', [FPath,FName,'1']);
636 Application.ProcessMessages;
637 RefreshCountdown := RefreshInterval;
638 //Note:RPCBrokerV.Results[0]=1 if successful load, =0 if failure
639 if (RPCBrokerV.Results.Count>0) and (RPCBrokerV.Results[0]='1') then begin
640 OutFile := TFileStream.Create(LocalSaveFNamePath,fmCreate);
641 for i:=1 to (RPCBrokerV.Results.Count-1) do begin
642 s :=Decode(RPCBrokerV.Results[i]);
643 count := Length(s);
644 if count>1024 then begin
645 Result := false; //failure of load.
646 break;
647 end;
648 for j := 1 to count do Buffer[j-1] := ord(s[j]);
649 OutFile.Write(Buffer,count);
650 Dec(RefreshCountdown);
651 if RefreshCountdown < 1 then begin
652 Application.ProcessMessages;
653 RefreshCountdown := RefreshInterval;
654 end;
655 end;
656 OutFile.Free;
657 end else begin
658 result := false;
659 end;
660 StatusText('');
661end;
662
663
664function TfrmImages.Encode(Input: AnsiString) : AnsiString;
665//This function is based on ENCODE^RGUTUU, which is match for
666//DECODE^RGUTUU that is used to decode (ascii armouring) on the
667//server side. This is a base64 encoder.
668const
669 //FYI character set is 64 characters (starting as 'A')
670 // (65 characters if intro '=' is counted)
671 CharSet = '=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
672var
673 //Result : AnsiString; // RGZ1 //'Result' is implicitly declared by Pascal
674
675 i : integer; //RGZ2
676 j : integer; //RGZ4
677 PlainTrio : longword; //RGZ3 //unsigned 32-bit
678 EncodedByte : Byte;
679 PlainByte : byte; //RGZ5
680 EncodedQuad : string[4];//RGZ6
681
682begin
683 //e.g. input (10 bytes):
684 // 174 231 193 16 29 251 93 138 4 57
685 // AE E7 C1 10 1D FB 5D 8A 04 39
686 Result := '';
687 i := 1;
688 while i<= Length(Input) do begin //cycle in groups of 3
689 PlainTrio := 0;
690 EncodedQuad := '';
691 //Get 3 bytes, to be converted into 4 characters eventually.
692 //Fill with 0's if needed to make an even 3-byte group.
693 For j:=0 to 2 do begin
694 //e.g. '174'->PlainByte=174
695 if (i+j) <= Length(Input) then PlainByte := ord(Input[i+j])
696 else PlainByte := 0;
697 PlainTrio := (PlainTrio shl 8) or PlainByte;
698 end;
699 //e.g. first 3 bytes--> PlainTrio= $AEE7C1 (10101110 11100111 11000001)
700 //e.g. last 3 bytes--> PlainTrio= $390000 (00111001 00000000 00000000) (note padded 0's)
701
702 //Take each 6 bits and convert into a character.
703 //e.g. first 3 bytes--> (101011 101110 011111 000001)
704 // 43 46 31 1
705
706 //e.g. last 3 bytes-->(001110 010000 000000 000000) (after redivision)
707 // 14 16 0 0 <-- last 2 bytes are padded 0
708 // ^ last 4 bits of '16' are padded 0's
709 For j := 1 to 4 do begin
710 //e.g. $AEE7C1 --> (43+2)=45 (46+2)=48 (31+2)=33 (1+2)=3
711 // r u f b
712
713 //e.g. $39AF00 --> (14+2)=16 (16+2)=18 (0+2)=2 (0+2)=2
714 // O Q A A <-- 2 padded bytes
715 EncodedByte := (PlainTrio and 63)+2; //63=$3F=b0111111; 0->A 1->B etc
716 EncodedQuad := CharSet[EncodedByte]+ EncodedQuad; //string Concat, not math add
717 PlainTrio := PlainTrio shr 6
718 end;
719
720 //Append result with latest quad
721 Result := Result + EncodedQuad;
722 Inc(i,3);
723 end;
724
725 // e.g. result: rufb .... .... OQAA <-- 2 padded bytes (and part of Q is padded also)
726 i := 3-(Length(Input) mod 3); //returns 1,2,or 3 (3 needs to be set to 0)
727 if (i=3) then i:=0; //e.g. input=10 -> i=2
728 j := Length(Result);
729 //i is the number of padded characters that need to be replaced with '='
730 if i>=1 then Result[j] := '='; //replace 1st paddeded char
731 if i>=2 then Result[Length(Result)-1] := '=';//replace 2nd paddeded char
732 // e.g. result: rufb .... .... OQ==
733
734 //results passed out in Result
735end;
736
737
738function TfrmImages.Decode(Input: AnsiString) : AnsiString;
739//This function is based on DECODE^RGUTUU, which is match for
740//ENCODE^RGUTUU that is used to encode (ascii armouring) on the
741//server side. This is a Base64 decoder
742const
743 //FYI character set is 64 characters (starting as 'A')
744 // (65 characters if intro '=' is counted)
745 CharSet = '=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
746
747var
748 //Result : AnsiString; // RGZ1 //'Result' is implicitly declared by Pascal
749 i : integer; //RGZ2
750 PlainTrio : longword; //RGZ3 //unsigned 32-bit
751 j : integer; //RGZ4
752 EncodedChar : char;
753 PlainInt : integer;
754 PlainByte : byte; //RGZ5
755 DecodedTrio : string[3];//RGZ6
756
757begin
758 Result:='';
759 i := 1;
760 //e.g. input: rufb .... .... OQ==
761
762 while i <= Length(Input) Do begin //cycle in groups of 4
763 PlainTrio :=0;
764 DecodedTrio :='';
765 //Get 4 characters, to be converted into 3 bytes.
766 For j :=0 to 3 do begin
767 //e.g. last 4 chars --> 0A==
768 if (i+j) <= Length(Input) then begin
769 EncodedChar := Input[i+j];
770 PlainInt := Pos(EncodedChar,CharSet)-2; //A=0, B=1 etc.
771 if (PlainInt>=0) then PlainByte := (PlainInt and $FF) else PlainByte := 0;
772 end else PlainByte := 0;
773 //e.g. with last 4 characters:
774 //e.g. '0'->14=(b001110) 'Q'->16=(b010000) '='-> -1 -> 0=(b000000) '=' -> 0=(b000000)
775 //e.g.-- So last PlainTrio = 001110 010000 000000 000000 = 00111001 00000000 00000000
776 //Each encoded character contributes 6 bytes to final 3 bytes.
777 //4 chars * 6 bits/char=24 bits --> 24 bits / 8 bits/byte = 3 bytes
778 PlainTrio := (PlainTrio shl 6) or PlainByte; //PlainTrio := PlainTrio*64 + PlainByte;
779 end;
780 //Now take 3 bytes, and add to cumulative output (in same order)
781 For j :=0 to 2 do begin
782 DecodedTrio := Chr(PlainTrio and $FF) + DecodedTrio; //string concat (not math addition)
783 PlainTrio := PlainTrio shr 8; // PlainTrio := PlainTrio div 256
784 end;
785 //e.g. final DecodedTrio = 'chr($39) + chr(0) + chr(0)'
786 Result := Result + DecodedTrio;
787 Inc(i,4);
788 end;
789
790 //Now remove 1 byte from the output for each '=' in input string
791 //(each '=' represents 1 padded 0 added to allow for even groups of 3)
792 for j :=0 to 1 do begin
793 if (Input[Length(Input)-j] = '=') then begin
794 Result := MidStr(Result,1,Length(Result)-1);
795 end;
796 end;
797end;
798
799procedure TfrmImages.NewNoteSelected(EditIsActive : boolean);
800//Will be called by fNotes when a new note has been selected.
801//var
802begin
803 ClearTabPages();
804 CurImageToLoad := 0; //a -1 would signal that no images avail to load.
805 //this will start downloading images after 5 second delay (so that if
806 //user is just browsing past note, this won't waste effort.
807 //If user selects images tab, then load will occur without delay.
808 timLoadImages.Enabled := true;
809 timLoadImages.Interval := 60000; //60 sec delay -- also set in timLoadImagesTimer
810 //Note: OnTimer calls timLoadImagesTimer()
811 UploadImagesButton.Enabled := EditIsActive;
812 UploadImagesMnuAction.Enabled := EditIsActive;
813 WebBrowser.Navigate(NullImageName);
814end;
815
816
817procedure TfrmImages.EmptyCache();
818//This will delete ALL files in the Cache directory
819//Note: This will include the html_note file created by
820// the notes tab.
821var
822 //CacheDir : AnsiString;
823 FoundFile : boolean;
824 FSearch : TSearchRec;
825 Files : TStringList;
826 i : integer;
827 FName : AnsiString;
828
829begin
830 Files := TStringList.Create;
831// CacheDir := ExtractFilePath(ParamStr(0))+ 'Cache';
832 FoundFile := (FindFirst(CacheDir+'\*.*',faAnyFile,FSearch)=0);
833 while FoundFile do Begin
834 FName := FSearch.Name;
835 if (FName <> '.') and (FName <> '..') then begin
836 FName := CacheDir + '\' + FName;
837 Files.Add(FName);
838 end;
839 FoundFile := (FindNext(FSearch)=0);
840 end;
841
842 for i := 0 to Files.Count-1 do begin
843 FName := Files.Strings[i];
844 if DeleteFile(FName) = false then begin
845 raise Exception.Create('Unable to delete file: '+FSearch.Name+#13+'Will try again later...');
846 end;
847 end;
848 Files.Free;
849end;
850
851
852
853procedure TfrmImages.UploadImagesButtonClick(Sender: TObject);
854var
855 Node: TORTreeNode;
856 AddResult : TModalResult;
857begin
858 inherited;
859 AddResult := UploadForm.ShowModal;
860 if not IsAbortResult(AddResult) then begin
861 NewNoteSelected(true); //force a reload to show recently added image.
862 timLoadImages.Interval := 100;
863 Node := TORTreeNode(frmNotes.tvNotes.Selected);
864 case Node.StateIndex of
865 IMG_NO_IMAGES : Node.StateIndex := IMG_1_IMAGE;
866 IMG_1_IMAGE : Node.StateIndex := IMG_2_IMAGES;
867 IMG_2_IMAGES : Node.StateIndex := IMG_MANY_IMAGES;
868 IMG_MANY_IMAGES : Node.StateIndex := IMG_MANY_IMAGES;
869 end;
870 end;
871end;
872
873procedure TfrmImages.FormHide(Sender: TObject);
874begin
875 inherited;
876// Application.MessageBox('Here I can hide images.','title');
877end;
878
879procedure TfrmImages.TabControlChange(Sender: TObject);
880var
881 FileName : AnsiString;
882 Rec : TImageInfo;
883 Selected : integer;
884begin
885 inherited;
886 //here tab has been changed.
887 Selected := TabControl.TabIndex;
888 if Selected > -1 then begin
889 Rec := TImageInfo(ImageInfoList[Selected]);
890 FileName := Rec.CacheFName;
891 UpdateImageInfoMemo(Rec);
892 end else begin
893 FileName := NullImageName;
894 UpdateImageInfoMemo(nil);
895 end;
896 WebBrowser.Navigate(FileName);
897end;
898
899procedure TfrmImages.TabControlGetImageIndex(Sender: TObject;
900 TabIndex: Integer;
901 var ImageIndex: Integer);
902//specify which image to display, from ThumbsImageList
903begin
904 inherited;
905 if (ImageInfoList <> nil) and (TabIndex < ImageInfoList.Count) then begin
906 ImageIndex := TImageInfo(ImageInfoList[TabIndex]).TabImageIndex;
907 end else ImageIndex := 0;
908end;
909
910procedure TfrmImages.TabControlResize(Sender: TObject);
911begin
912 inherited;
913 if TabControl.Width < 80 then begin
914 TabControl.Width := 80;
915 end;
916end;
917
918initialization
919 //put init code here
920
921finalization
922 //put finalization code here
923
924end.
925
Note: See TracBrowser for help on using the repository browser.