[453] | 1 | unit fImages; //kt Entire unit and form added 8/19/05
|
---|
| 2 | {$O-}
|
---|
| 3 |
|
---|
| 4 | interface
|
---|
| 5 |
|
---|
| 6 | uses
|
---|
| 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 |
|
---|
| 13 | type
|
---|
| 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;
|
---|
[729] | 66 | pnlTop: TPanel;
|
---|
| 67 | HorizSplitter: TSplitter;
|
---|
[453] | 68 | Splitter2: TSplitter;
|
---|
| 69 | UploadImagesButton: TBitBtn;
|
---|
| 70 | OpenPictureDialog: TOpenPictureDialog;
|
---|
| 71 | ButtonPanel: TPanel;
|
---|
| 72 | CurrentImageMemo: TMemo;
|
---|
| 73 | MemosPanel: TPanel;
|
---|
| 74 | UploadImagesMnuAction: TMenuItem;
|
---|
[729] | 75 | pnlBottom: TPanel;
|
---|
[453] | 76 | TabControl: TTabControl;
|
---|
| 77 | WebBrowser: TWebBrowser;
|
---|
[729] | 78 | AutoScanUpload: TMenuItem;
|
---|
| 79 | PickScanFolder: TMenuItem;
|
---|
| 80 | OpenDialog: TOpenDialog;
|
---|
[453] | 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);
|
---|
[729] | 94 | procedure EnableAutoScanUploadClick(Sender: TObject);
|
---|
| 95 | procedure PickScanFolderClick(Sender: TObject);
|
---|
[453] | 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);
|
---|
[729] | 109 | function FileSize(fileName : wideString) : Int64;
|
---|
[453] | 110 | public
|
---|
| 111 | CacheDir : AnsiString;
|
---|
[738] | 112 | UseDropBox : boolean;
|
---|
| 113 | DropBoxDir : string;
|
---|
[453] | 114 | NullImageName : AnsiString;
|
---|
| 115 | function Decode(input: AnsiString) : AnsiString;
|
---|
| 116 | function Encode(input: AnsiString) : AnsiString;
|
---|
[729] | 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;
|
---|
[453] | 121 | procedure SplitLinuxFilePath(FullPathName : AnsiString;
|
---|
| 122 | var Path : AnsiString;
|
---|
| 123 | var FName : AnsiString);
|
---|
| 124 | procedure GetImageList();
|
---|
| 125 | procedure NewNoteSelected(EditIsActive : boolean);
|
---|
[729] | 126 | function CreateBarcode(MsgStr: AnsiString; ImageType: AnsiString): AnsiString;
|
---|
| 127 | function DecodeBarcode(LocalFNamePath,ImageType: AnsiString): AnsiString;
|
---|
[793] | 128 | procedure EnsureImagesDownloaded(ImagesList : TStringList);
|
---|
[453] | 129 | published
|
---|
| 130 | end;
|
---|
| 131 |
|
---|
| 132 | var
|
---|
| 133 | frmImages: TfrmImages;
|
---|
| 134 |
|
---|
| 135 |
|
---|
| 136 | implementation
|
---|
| 137 |
|
---|
| 138 | {$R *.DFM}
|
---|
| 139 |
|
---|
| 140 | uses 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}
|
---|
[729] | 149 | //ImageTransferForm, {//kt 10-1-05}
|
---|
| 150 | uTMGOptions, //kt 3/10/10
|
---|
| 151 | rHTMLTools, fNotes, frmImageTransferProgress; {//kt added 5-27-05 for IsHTMLDocument}
|
---|
[453] | 152 |
|
---|
| 153 |
|
---|
| 154 | procedure TfrmImages.timLoadImagesTimer(Sender: TObject);
|
---|
[793] | 155 | //This function's goal is to download images in the background,
|
---|
| 156 | // with one image to be downloaded each time the timer fires
|
---|
[453] | 157 | begin
|
---|
| 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
|
---|
[729] | 164 | ImageTransferForm.ProgressMsg.Caption := 'Downloading Images';
|
---|
| 165 | //if ImageTransferForm.Visible = false then begin
|
---|
| 166 | // ImageTransferForm.Show;
|
---|
| 167 | //end;
|
---|
[453] | 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;
|
---|
[729] | 175 | //ImageTransferForm.ProgressBar.Position := 100;
|
---|
| 176 | //Sleep(1000);
|
---|
| 177 | //ImageTransferForm.Hide;
|
---|
[453] | 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;
|
---|
| 187 | end;
|
---|
| 188 |
|
---|
| 189 |
|
---|
[793] | 190 | procedure 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
|
---|
| 197 | var i : integer;
|
---|
| 198 | Rec : TImageInfo;
|
---|
| 199 |
|
---|
| 200 | begin
|
---|
| 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;
|
---|
| 219 | end;
|
---|
| 220 |
|
---|
| 221 |
|
---|
[453] | 222 | { TPage common methods --------------------------------------------------------------------- }
|
---|
| 223 | procedure TfrmImages.mnuChartTabClick(Sender: TObject);
|
---|
| 224 | { reroute to Chart Tab menu of the parent form: frmFrame }
|
---|
| 225 | begin
|
---|
| 226 | inherited;
|
---|
| 227 | frmFrame.mnuChartTabClick(Sender);
|
---|
| 228 | end;
|
---|
| 229 |
|
---|
| 230 |
|
---|
| 231 | procedure TfrmImages.mnuActNewClick(Sender: TObject);
|
---|
| 232 | const
|
---|
| 233 | IS_ID_CHILD = False;
|
---|
| 234 | { switches to current new note or creates a new note if none is being edited already }
|
---|
| 235 | begin
|
---|
| 236 | inherited;
|
---|
| 237 | end;
|
---|
| 238 |
|
---|
| 239 | procedure TfrmImages.FormCreate(Sender: TObject);
|
---|
| 240 | //var i : integer;
|
---|
| 241 | begin
|
---|
| 242 | inherited;
|
---|
| 243 | InTimerFn:=false;
|
---|
| 244 | LastDisplayedTIUIEN := '0';
|
---|
| 245 | ImageInfoList := TList.Create;
|
---|
| 246 | CurImageToLoad := 0;
|
---|
| 247 | CacheDir := ExtractFilePath(ParamStr(0))+ 'Cache';
|
---|
[793] | 248 | //NullImageName := ExtractFilePath(ParamStr(0)) + 'images\blank.htm';
|
---|
| 249 | NullImageName := 'about:blank';
|
---|
[453] | 250 | if not DirectoryExists(CacheDir) then ForceDirectories(CacheDir);
|
---|
[729] | 251 |
|
---|
[738] | 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;
|
---|
[729] | 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);
|
---|
[453] | 264 | end;
|
---|
| 265 |
|
---|
| 266 | procedure TfrmImages.FormDestroy(Sender: TObject);
|
---|
| 267 | begin
|
---|
| 268 | inherited;
|
---|
| 269 | ClearImageList;
|
---|
| 270 | ImageInfoList.Free;
|
---|
| 271 | EmptyCache;
|
---|
| 272 | end;
|
---|
| 273 |
|
---|
| 274 | procedure TfrmImages.FormShow(Sender: TObject);
|
---|
| 275 | var
|
---|
| 276 | TIUIEN : AnsiString;
|
---|
[729] | 277 |
|
---|
[453] | 278 | begin
|
---|
| 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;
|
---|
| 287 | end;
|
---|
| 288 |
|
---|
| 289 | procedure TfrmImages.mnuActClick(Sender: TObject);
|
---|
| 290 | begin
|
---|
| 291 | inherited;
|
---|
| 292 |
|
---|
| 293 | end;
|
---|
| 294 |
|
---|
| 295 | { General procedures ----------------------------------------------------------------------- }
|
---|
| 296 |
|
---|
| 297 | procedure TfrmImages.UpdateImageInfoMemo(Rec : TImageInfo);
|
---|
| 298 | var s : AnsiString;
|
---|
| 299 | i : integer;
|
---|
| 300 | begin
|
---|
| 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;
|
---|
| 317 | end;
|
---|
| 318 |
|
---|
| 319 |
|
---|
| 320 | procedure TfrmImages.UpdateNoteInfoMemo();
|
---|
| 321 | var
|
---|
| 322 | NoteInfo,s : AnsiString;
|
---|
| 323 | //dateS : AnsiString;
|
---|
| 324 | const
|
---|
| 325 | U='^';
|
---|
| 326 | begin
|
---|
| 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;
|
---|
| 352 | end;
|
---|
| 353 |
|
---|
| 354 | procedure TfrmImages.SetupTab(i : integer);
|
---|
| 355 | //i is index in ImageInfoList (array of TImageInfo's)
|
---|
| 356 | var
|
---|
| 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 |
|
---|
| 370 | begin
|
---|
| 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;
|
---|
| 418 | end;
|
---|
| 419 |
|
---|
| 420 |
|
---|
| 421 | procedure TfrmImages.ClearTabPages();
|
---|
| 422 | begin
|
---|
| 423 | TabControl.Tabs.Clear;
|
---|
| 424 | ClearImageList();
|
---|
| 425 | end;
|
---|
| 426 |
|
---|
| 427 |
|
---|
| 428 | procedure TfrmImages.ClearImageList();
|
---|
| 429 | //Note: !! This should also clear any visible images/thumbnails etc.
|
---|
| 430 | var i : integer;
|
---|
| 431 | begin
|
---|
| 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;
|
---|
| 439 | end;
|
---|
| 440 |
|
---|
| 441 |
|
---|
| 442 | procedure TfrmImages.EnsureImageListLoaded();
|
---|
| 443 | begin
|
---|
| 444 | if CurImageToLoad = 0 then begin
|
---|
| 445 | GetImageList();
|
---|
| 446 | if ImageInfoList.Count=0 then CurImageToLoad := -1;
|
---|
| 447 | end;
|
---|
| 448 | end;
|
---|
| 449 |
|
---|
| 450 | procedure TfrmImages.GetImageList();
|
---|
| 451 | var
|
---|
| 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 |
|
---|
| 462 | begin
|
---|
| 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;
|
---|
[729] | 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
|
---|
[453] | 533 | StatusText('');
|
---|
| 534 | end;
|
---|
| 535 |
|
---|
| 536 |
|
---|
| 537 | procedure TfrmImages.DownloadToCache(ImageIndex : integer);
|
---|
| 538 | //Loads image specified in ImageInfoList to Cache (unless already present)
|
---|
| 539 | var
|
---|
| 540 | Rec : TImageInfo;
|
---|
| 541 | ServerFName : AnsiString;
|
---|
| 542 | ServerPathName : AnsiString;
|
---|
| 543 |
|
---|
| 544 | begin
|
---|
| 545 | Rec := TImageInfo(ImageInfoList[ImageIndex]);
|
---|
| 546 | ServerFName := Rec.ServerFName;
|
---|
| 547 | ServerPathName := Rec.ServerPathName;
|
---|
| 548 | if not FileExists(Rec.CacheFName) then begin
|
---|
[729] | 549 | DownloadFile(ServerPathName,ServerFName,Rec.CacheFName,(ImageIndex*2)-1,ImageInfoList.Count*2);
|
---|
[453] | 550 | end;
|
---|
| 551 | ServerFName := Rec.ServerThumbFName;
|
---|
| 552 | ServerPathName := Rec.ServerThumbPathName;
|
---|
| 553 | if not FileExists(Rec.CacheThumbFName) then begin
|
---|
[729] | 554 | DownloadFile(ServerPathName,ServerFName,Rec.CacheThumbFName,ImageIndex*2,ImageInfoList.Count*2);
|
---|
[453] | 555 | end;
|
---|
| 556 | Application.ProcessMessages;
|
---|
| 557 | end;
|
---|
| 558 |
|
---|
| 559 | procedure TfrmImages.SplitLinuxFilePath(FullPathName : AnsiString;
|
---|
| 560 | var Path : AnsiString;
|
---|
| 561 | var FName : AnsiString);
|
---|
| 562 | var p : integer;
|
---|
| 563 | begin
|
---|
| 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 = '');
|
---|
| 575 | end;
|
---|
| 576 |
|
---|
| 577 |
|
---|
[729] | 578 | function TfrmImages.UploadFileViaDropBox(LocalFNamePath,FPath,FName: AnsiString;CurrentImage,TotalImages: Integer): boolean;
|
---|
| 579 | var
|
---|
| 580 | DropboxFile : AnsiString;
|
---|
| 581 | begin
|
---|
| 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 |
|
---|
[793] | 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;
|
---|
[729] | 606 | end;
|
---|
| 607 |
|
---|
| 608 |
|
---|
| 609 | function TfrmImages.UploadFile(LocalFNamePath,FPath,FName: AnsiString;CurrentImage,TotalImages: Integer): boolean;
|
---|
[453] | 610 | const
|
---|
| 611 | RefreshInterval = 500;
|
---|
| 612 | BlockSize = 512;
|
---|
| 613 |
|
---|
| 614 | var
|
---|
| 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 |
|
---|
| 627 | begin
|
---|
| 628 | result := false; //default of failure
|
---|
| 629 | if not FileExists(LocalFNamePath) then exit;
|
---|
[729] | 630 | if UseDropBox then begin
|
---|
| 631 | Result := UploadFileViaDropBox(LocalFNamePath,FPath,FName,CurrentImage,TotalImages);
|
---|
| 632 | exit;
|
---|
| 633 | end;
|
---|
[453] | 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...)
|
---|
[729] | 640 | ImageTransferForm.setMax(InFile.Size);
|
---|
| 641 | //ImageTransferForm.ResetStartTime;
|
---|
| 642 | ImageTransferForm.ProgressMsg.Caption := 'Preparing to upload...';
|
---|
| 643 | ImageTransferForm.Show;
|
---|
[453] | 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;
|
---|
[729] | 678 | ImageTransferForm.updateProgress(totalReadCount);
|
---|
[453] | 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;
|
---|
[729] | 699 | ImageTransferForm.ProgressMsg.Caption := 'Uploading file to server...';
|
---|
[453] | 700 | Application.ProcessMessages;
|
---|
| 701 |
|
---|
| 702 | CallBroker;
|
---|
| 703 | Screen.Cursor := SavedCursor;
|
---|
| 704 | RPCResult := RPCBrokerV.Results[0];
|
---|
| 705 | result := (Piece(RPCResult,'^',1)='1');
|
---|
[729] | 706 | ImageTransferForm.Hide;
|
---|
[453] | 707 | if result=false then begin
|
---|
| 708 | Application.MessageBox('Error uploading file','Error');
|
---|
| 709 | end;
|
---|
| 710 |
|
---|
| 711 | InFile.Free;
|
---|
| 712 | LocalOutFile.Free;
|
---|
| 713 | StatusText('');
|
---|
| 714 | end;
|
---|
| 715 |
|
---|
| 716 |
|
---|
[729] | 717 | function TfrmImages.DownloadFileViaDropbox(FPath,FName,LocalSaveFNamePath: AnsiString;CurrentImage,TotalImages: Integer): boolean;
|
---|
[453] | 718 | var
|
---|
[729] | 719 | DropboxFile : AnsiString;
|
---|
| 720 | CurrentFileSize : Integer;
|
---|
[735] | 721 | ErrMsg : string;
|
---|
[729] | 722 | begin
|
---|
| 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 |
|
---|
[793] | 733 | //RPCBrokerV.Call; //Move file into dropbox.
|
---|
| 734 | CallBroker;
|
---|
[735] | 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;
|
---|
[729] | 742 |
|
---|
| 743 | if Result=true then begin
|
---|
[793] | 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;
|
---|
[735] | 749 | CurrentFileSize := strtoint(Piece(RPCBrokerV.Results[0],'^',3)); //Piece 3 = file size
|
---|
[729] | 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;
|
---|
[735] | 764 | end else begin
|
---|
| 765 | MessageDlg('ERROR: '+ErrMsg,mtError,[mbOK],0);
|
---|
[729] | 766 | end;
|
---|
| 767 | end;
|
---|
| 768 |
|
---|
| 769 |
|
---|
| 770 | function TfrmImages.DownloadFile(FPath,FName,LocalSaveFNamePath: AnsiString;CurrentImage,TotalImages: Integer): boolean;
|
---|
| 771 | var
|
---|
[453] | 772 | i,count : integer;
|
---|
| 773 | j : word;
|
---|
| 774 | OutFile : TFileStream;
|
---|
| 775 | s : AnsiString;
|
---|
| 776 | Buffer : array[0..1024] of byte;
|
---|
| 777 | RefreshCountdown : integer;
|
---|
| 778 |
|
---|
| 779 | const
|
---|
| 780 | RefreshInterval = 500;
|
---|
| 781 |
|
---|
| 782 | begin
|
---|
| 783 | if FileExists(LocalSaveFNamePath) then begin
|
---|
| 784 | DeleteFile(LocalSaveFNamePath);
|
---|
| 785 | end;
|
---|
[729] | 786 | if UseDropBox then begin
|
---|
| 787 | Result := DownloadFileViaDropBox(FPath,FName,LocalSaveFNamePath,CurrentImage,TotalImages);
|
---|
| 788 | exit;
|
---|
| 789 | end;
|
---|
[453] | 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('');
|
---|
| 827 | end;
|
---|
| 828 |
|
---|
| 829 |
|
---|
| 830 | function 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.
|
---|
| 834 | const
|
---|
| 835 | //FYI character set is 64 characters (starting as 'A')
|
---|
| 836 | // (65 characters if intro '=' is counted)
|
---|
| 837 | CharSet = '=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
|
---|
| 838 | var
|
---|
| 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 |
|
---|
| 848 | begin
|
---|
| 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
|
---|
| 901 | end;
|
---|
| 902 |
|
---|
| 903 |
|
---|
| 904 | function 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
|
---|
| 908 | const
|
---|
| 909 | //FYI character set is 64 characters (starting as 'A')
|
---|
| 910 | // (65 characters if intro '=' is counted)
|
---|
| 911 | CharSet = '=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
|
---|
| 912 |
|
---|
| 913 | var
|
---|
| 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 |
|
---|
| 923 | begin
|
---|
| 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;
|
---|
| 963 | end;
|
---|
| 964 |
|
---|
| 965 | procedure TfrmImages.NewNoteSelected(EditIsActive : boolean);
|
---|
| 966 | //Will be called by fNotes when a new note has been selected.
|
---|
| 967 | //var
|
---|
| 968 | begin
|
---|
| 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);
|
---|
| 980 | end;
|
---|
| 981 |
|
---|
| 982 |
|
---|
| 983 | procedure 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.
|
---|
| 987 | var
|
---|
| 988 | //CacheDir : AnsiString;
|
---|
| 989 | FoundFile : boolean;
|
---|
| 990 | FSearch : TSearchRec;
|
---|
| 991 | Files : TStringList;
|
---|
| 992 | i : integer;
|
---|
| 993 | FName : AnsiString;
|
---|
| 994 |
|
---|
| 995 | begin
|
---|
| 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
|
---|
[612] | 1011 | //kt raise Exception.Create('Unable to delete file: '+FSearch.Name+#13+'Will try again later...');
|
---|
[453] | 1012 | end;
|
---|
| 1013 | end;
|
---|
| 1014 | Files.Free;
|
---|
| 1015 | end;
|
---|
| 1016 |
|
---|
| 1017 |
|
---|
| 1018 |
|
---|
| 1019 | procedure TfrmImages.UploadImagesButtonClick(Sender: TObject);
|
---|
| 1020 | var
|
---|
| 1021 | Node: TORTreeNode;
|
---|
| 1022 | AddResult : TModalResult;
|
---|
| 1023 | begin
|
---|
| 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;
|
---|
| 1037 | end;
|
---|
| 1038 |
|
---|
| 1039 | procedure TfrmImages.FormHide(Sender: TObject);
|
---|
| 1040 | begin
|
---|
| 1041 | inherited;
|
---|
| 1042 | // Application.MessageBox('Here I can hide images.','title');
|
---|
| 1043 | end;
|
---|
| 1044 |
|
---|
| 1045 | procedure TfrmImages.TabControlChange(Sender: TObject);
|
---|
| 1046 | var
|
---|
| 1047 | FileName : AnsiString;
|
---|
| 1048 | Rec : TImageInfo;
|
---|
| 1049 | Selected : integer;
|
---|
| 1050 | begin
|
---|
| 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);
|
---|
| 1063 | end;
|
---|
| 1064 |
|
---|
| 1065 | procedure TfrmImages.TabControlGetImageIndex(Sender: TObject;
|
---|
| 1066 | TabIndex: Integer;
|
---|
| 1067 | var ImageIndex: Integer);
|
---|
| 1068 | //specify which image to display, from ThumbsImageList
|
---|
| 1069 | begin
|
---|
| 1070 | inherited;
|
---|
| 1071 | if (ImageInfoList <> nil) and (TabIndex < ImageInfoList.Count) then begin
|
---|
| 1072 | ImageIndex := TImageInfo(ImageInfoList[TabIndex]).TabImageIndex;
|
---|
| 1073 | end else ImageIndex := 0;
|
---|
| 1074 | end;
|
---|
| 1075 |
|
---|
| 1076 | procedure TfrmImages.TabControlResize(Sender: TObject);
|
---|
| 1077 | begin
|
---|
| 1078 | inherited;
|
---|
| 1079 | if TabControl.Width < 80 then begin
|
---|
| 1080 | TabControl.Width := 80;
|
---|
| 1081 | end;
|
---|
| 1082 | end;
|
---|
| 1083 |
|
---|
[729] | 1084 | function 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 |
|
---|
| 1106 | var
|
---|
| 1107 | i,count : integer;
|
---|
| 1108 | j : word;
|
---|
| 1109 | OutFile : TFileStream;
|
---|
| 1110 | s : AnsiString;
|
---|
| 1111 | Buffer : array[0..1024] of byte;
|
---|
| 1112 | LocalSaveFNamePath : AnsiString;
|
---|
| 1113 |
|
---|
| 1114 | begin
|
---|
| 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;
|
---|
[793] | 1127 | //RPCBrokerV.Call;
|
---|
| 1128 | CallBroker;
|
---|
[729] | 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('');
|
---|
| 1149 | end;
|
---|
| 1150 |
|
---|
| 1151 |
|
---|
| 1152 | function 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.
|
---|
| 1157 | const
|
---|
| 1158 | RefreshInterval = 500;
|
---|
| 1159 | BlockSize = 512;
|
---|
| 1160 |
|
---|
| 1161 | var
|
---|
| 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;
|
---|
| 1172 | begin
|
---|
| 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('');
|
---|
| 1240 | end;
|
---|
| 1241 |
|
---|
| 1242 |
|
---|
| 1243 | procedure TfrmImages.EnableAutoScanUploadClick(Sender: TObject);
|
---|
| 1244 | begin
|
---|
| 1245 | inherited;
|
---|
| 1246 | AutoScanUpload.Checked := not AutoScanUpload.Checked;
|
---|
| 1247 | uTMGOptions.WriteBool('Scan Enabled',AutoScanUpload.Checked);
|
---|
| 1248 | end;
|
---|
| 1249 |
|
---|
| 1250 |
|
---|
| 1251 | procedure TfrmImages.PickScanFolderClick(Sender: TObject);
|
---|
| 1252 | var
|
---|
| 1253 | CurScanDir : string;
|
---|
| 1254 | begin
|
---|
| 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;
|
---|
| 1263 | end;
|
---|
| 1264 |
|
---|
| 1265 | function TfrmImages.FileSize(fileName : wideString) : Int64;
|
---|
| 1266 | var
|
---|
| 1267 | sr : TSearchRec;
|
---|
| 1268 | begin
|
---|
| 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) ;
|
---|
| 1275 | end;
|
---|
| 1276 |
|
---|
[453] | 1277 | initialization
|
---|
| 1278 | //put init code here
|
---|
| 1279 |
|
---|
| 1280 | finalization
|
---|
| 1281 | //put finalization code here
|
---|
| 1282 |
|
---|
| 1283 | end.
|
---|
| 1284 |
|
---|