[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 |
|
---|
[801] | 44 | TImgTransferMethod = (itmDropbox,itmDirect,itmRPC);
|
---|
| 45 |
|
---|
[453] | 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;
|
---|
[729] | 68 | pnlTop: TPanel;
|
---|
| 69 | HorizSplitter: TSplitter;
|
---|
[453] | 70 | Splitter2: TSplitter;
|
---|
| 71 | UploadImagesButton: TBitBtn;
|
---|
| 72 | OpenPictureDialog: TOpenPictureDialog;
|
---|
| 73 | ButtonPanel: TPanel;
|
---|
| 74 | CurrentImageMemo: TMemo;
|
---|
| 75 | MemosPanel: TPanel;
|
---|
| 76 | UploadImagesMnuAction: TMenuItem;
|
---|
[729] | 77 | pnlBottom: TPanel;
|
---|
[453] | 78 | TabControl: TTabControl;
|
---|
| 79 | WebBrowser: TWebBrowser;
|
---|
[729] | 80 | AutoScanUpload: TMenuItem;
|
---|
| 81 | PickScanFolder: TMenuItem;
|
---|
| 82 | OpenDialog: TOpenDialog;
|
---|
[453] | 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);
|
---|
[729] | 96 | procedure EnableAutoScanUploadClick(Sender: TObject);
|
---|
| 97 | procedure PickScanFolderClick(Sender: TObject);
|
---|
[453] | 98 | private
|
---|
| 99 | ImageInfoList : TList;
|
---|
| 100 | LastDisplayedTIUIEN : AnsiString;
|
---|
[801] | 101 | ImageIndexLastDownloaded : integer;
|
---|
[453] | 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);
|
---|
[729] | 110 | function FileSize(fileName : wideString) : Int64;
|
---|
[801] | 111 | function GetImagesCount : integer;
|
---|
| 112 | function GetImageInfo(Index : integer) : TImageInfo;
|
---|
| 113 | procedure SetupTimer;
|
---|
[453] | 114 | public
|
---|
| 115 | CacheDir : AnsiString;
|
---|
[801] | 116 | TransferMethod : TImgTransferMethod;
|
---|
[738] | 117 | DropBoxDir : string;
|
---|
[453] | 118 | NullImageName : AnsiString;
|
---|
[809] | 119 | NumImagesAvailableOnServer : integer;
|
---|
[801] | 120 | DownloadImagesInBackground : boolean;
|
---|
[453] | 121 | function Decode(input: AnsiString) : AnsiString;
|
---|
| 122 | function Encode(input: AnsiString) : AnsiString;
|
---|
[729] | 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;
|
---|
[453] | 127 | procedure SplitLinuxFilePath(FullPathName : AnsiString;
|
---|
| 128 | var Path : AnsiString;
|
---|
| 129 | var FName : AnsiString);
|
---|
| 130 | procedure GetImageList();
|
---|
| 131 | procedure NewNoteSelected(EditIsActive : boolean);
|
---|
[729] | 132 | function CreateBarcode(MsgStr: AnsiString; ImageType: AnsiString): AnsiString;
|
---|
| 133 | function DecodeBarcode(LocalFNamePath,ImageType: AnsiString): AnsiString;
|
---|
[793] | 134 | procedure EnsureImagesDownloaded(ImagesList : TStringList);
|
---|
[801] | 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;
|
---|
[453] | 140 | published
|
---|
| 141 | end;
|
---|
| 142 |
|
---|
[801] | 143 | Const
|
---|
| 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 |
|
---|
[453] | 157 | var
|
---|
| 158 | frmImages: TfrmImages;
|
---|
| 159 |
|
---|
| 160 |
|
---|
| 161 | implementation
|
---|
| 162 |
|
---|
| 163 | {$R *.DFM}
|
---|
| 164 |
|
---|
| 165 | uses 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}
|
---|
[729] | 174 | //ImageTransferForm, {//kt 10-1-05}
|
---|
| 175 | uTMGOptions, //kt 3/10/10
|
---|
| 176 | rHTMLTools, fNotes, frmImageTransferProgress; {//kt added 5-27-05 for IsHTMLDocument}
|
---|
[453] | 177 |
|
---|
| 178 |
|
---|
| 179 | procedure TfrmImages.timLoadImagesTimer(Sender: TObject);
|
---|
[793] | 180 | //This function's goal is to download images in the background,
|
---|
| 181 | // with one image to be downloaded each time the timer fires
|
---|
[453] | 182 | begin
|
---|
| 183 | inherited;
|
---|
[801] | 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;
|
---|
| 195 | end;
|
---|
| 196 |
|
---|
| 197 | procedure TfrmImages.SetupTimer;
|
---|
| 198 | begin
|
---|
| 199 | if DownloadImagesInBackground then begin
|
---|
| 200 | timLoadImages.Interval := IMAGE_DOWNLOAD_DELAY_BACKGROUND;
|
---|
| 201 | end else begin
|
---|
| 202 | timLoadImages.Interval := IMAGE_DOWNLOAD_DELAY_FOREGROUND;
|
---|
[453] | 203 | end;
|
---|
[801] | 204 | timLoadImages.Enabled := true;
|
---|
[453] | 205 | end;
|
---|
| 206 |
|
---|
[793] | 207 | procedure 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
|
---|
| 214 | var i : integer;
|
---|
| 215 | Rec : TImageInfo;
|
---|
| 216 |
|
---|
| 217 | begin
|
---|
| 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;
|
---|
| 236 | end;
|
---|
| 237 |
|
---|
[801] | 238 | procedure TfrmImages.EnsureALLImagesDownloaded;
|
---|
| 239 | //This function's goal is to download ALL images in the FOREground.
|
---|
| 240 | begin
|
---|
| 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;
|
---|
| 251 | end;
|
---|
[793] | 252 |
|
---|
[453] | 253 | { TPage common methods --------------------------------------------------------------------- }
|
---|
| 254 | procedure TfrmImages.mnuChartTabClick(Sender: TObject);
|
---|
| 255 | { reroute to Chart Tab menu of the parent form: frmFrame }
|
---|
| 256 | begin
|
---|
| 257 | inherited;
|
---|
| 258 | frmFrame.mnuChartTabClick(Sender);
|
---|
| 259 | end;
|
---|
| 260 |
|
---|
| 261 |
|
---|
| 262 | procedure TfrmImages.mnuActNewClick(Sender: TObject);
|
---|
| 263 | const
|
---|
| 264 | IS_ID_CHILD = False;
|
---|
| 265 | { switches to current new note or creates a new note if none is being edited already }
|
---|
| 266 | begin
|
---|
| 267 | inherited;
|
---|
| 268 | end;
|
---|
| 269 |
|
---|
| 270 | procedure TfrmImages.FormCreate(Sender: TObject);
|
---|
| 271 | //var i : integer;
|
---|
| 272 | begin
|
---|
| 273 | inherited;
|
---|
| 274 | LastDisplayedTIUIEN := '0';
|
---|
| 275 | ImageInfoList := TList.Create;
|
---|
[801] | 276 | ClearImageList(); //sets up other needed variables.
|
---|
| 277 | DownloadImagesInBackground := true;
|
---|
[453] | 278 | CacheDir := ExtractFilePath(ParamStr(0))+ 'Cache';
|
---|
[793] | 279 | //NullImageName := ExtractFilePath(ParamStr(0)) + 'images\blank.htm';
|
---|
| 280 | NullImageName := 'about:blank';
|
---|
[453] | 281 | if not DirectoryExists(CacheDir) then ForceDirectories(CacheDir);
|
---|
[729] | 282 |
|
---|
[801] | 283 | TransferMethod := TImgTransferMethod(uTMGOptions.ReadInteger('ImageTransferMethod',2));
|
---|
| 284 | {if uTMGOptions.ReadInteger('ImageTransferMethod',0) = 0 then begin
|
---|
[738] | 285 | UseDropBox := True;
|
---|
| 286 | end else begin
|
---|
| 287 | UseDropBox := False;
|
---|
[801] | 288 | end;}
|
---|
[729] | 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);
|
---|
[453] | 295 | end;
|
---|
| 296 |
|
---|
| 297 | procedure TfrmImages.FormDestroy(Sender: TObject);
|
---|
| 298 | begin
|
---|
| 299 | inherited;
|
---|
| 300 | ClearImageList;
|
---|
| 301 | ImageInfoList.Free;
|
---|
| 302 | EmptyCache;
|
---|
| 303 | end;
|
---|
| 304 |
|
---|
| 305 | procedure TfrmImages.FormShow(Sender: TObject);
|
---|
[801] | 306 | var TIUIEN : AnsiString;
|
---|
[453] | 307 | begin
|
---|
| 308 | inherited;
|
---|
| 309 | TIUIEN := IntToStr(frmNotes.lstNotes.ItemID);
|
---|
[801] | 310 | DownloadImagesInBackground := false;
|
---|
| 311 | SetupTimer;
|
---|
[453] | 312 | if LastDisplayedTIUIEN <> TIUIEN then begin
|
---|
| 313 | UpdateNoteInfoMemo();
|
---|
| 314 | LastDisplayedTIUIEN := TIUIEN;
|
---|
| 315 | end;
|
---|
| 316 | end;
|
---|
| 317 |
|
---|
| 318 | procedure TfrmImages.mnuActClick(Sender: TObject);
|
---|
| 319 | begin
|
---|
| 320 | inherited;
|
---|
| 321 |
|
---|
| 322 | end;
|
---|
| 323 |
|
---|
| 324 | { General procedures ----------------------------------------------------------------------- }
|
---|
| 325 |
|
---|
| 326 | procedure TfrmImages.UpdateImageInfoMemo(Rec : TImageInfo);
|
---|
| 327 | var s : AnsiString;
|
---|
| 328 | i : integer;
|
---|
| 329 | begin
|
---|
| 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;
|
---|
| 346 | end;
|
---|
| 347 |
|
---|
| 348 |
|
---|
| 349 | procedure TfrmImages.UpdateNoteInfoMemo();
|
---|
| 350 | var
|
---|
| 351 | NoteInfo,s : AnsiString;
|
---|
| 352 | //dateS : AnsiString;
|
---|
| 353 | const
|
---|
| 354 | U='^';
|
---|
| 355 | begin
|
---|
| 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;
|
---|
| 381 | end;
|
---|
| 382 |
|
---|
| 383 | procedure TfrmImages.SetupTab(i : integer);
|
---|
| 384 | //i is index in ImageInfoList (array of TImageInfo's)
|
---|
| 385 | var
|
---|
| 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 |
|
---|
| 399 | begin
|
---|
| 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);
|
---|
[801] | 411 | //TImageInfo(ImageInfoList[i]).TabImageIndex := index;
|
---|
| 412 | Rec.TabImageIndex := index;
|
---|
[453] | 413 | Bitmap.Free;
|
---|
| 414 | end else begin
|
---|
[801] | 415 | Rec.TabImageIndex := ThumbnailIndexForFName(Rec.CacheFName);
|
---|
[453] | 416 | end;
|
---|
| 417 | end;
|
---|
| 418 | TabControl.Tabs.Add(' '); //add the tab. Thumbnail should exist before this
|
---|
| 419 | end;
|
---|
| 420 | end;
|
---|
| 421 |
|
---|
[801] | 422 | function TfrmImages.ThumbnailIndexForFName (FName : string) : integer;
|
---|
| 423 | var
|
---|
| 424 | index : integer;
|
---|
| 425 | Ext : AnsiString;
|
---|
| 426 | begin
|
---|
| 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;
|
---|
| 457 | end;
|
---|
[453] | 458 |
|
---|
[801] | 459 |
|
---|
| 460 | procedure TfrmImages.GetThumbnailBitmapForFName (FName : string; Bitmap : TBitmap);
|
---|
| 461 | var index: integer;
|
---|
| 462 | begin
|
---|
| 463 | index := ThumbnailIndexForFName(FName);
|
---|
| 464 | ThumbsImageList.GetBitmap(index,Bitmap);
|
---|
| 465 | end;
|
---|
| 466 |
|
---|
| 467 |
|
---|
[453] | 468 | procedure TfrmImages.ClearTabPages();
|
---|
| 469 | begin
|
---|
| 470 | TabControl.Tabs.Clear;
|
---|
| 471 | ClearImageList();
|
---|
| 472 | end;
|
---|
| 473 |
|
---|
| 474 |
|
---|
| 475 | procedure TfrmImages.ClearImageList();
|
---|
| 476 | //Note: !! This should also clear any visible images/thumbnails etc.
|
---|
| 477 | var i : integer;
|
---|
| 478 | begin
|
---|
| 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;
|
---|
[801] | 486 | NumImagesAvailableOnServer := NOT_YET_CHECKED_SERVER;
|
---|
| 487 | ImageIndexLastDownloaded := -1;
|
---|
[453] | 488 | end;
|
---|
| 489 |
|
---|
| 490 |
|
---|
| 491 | procedure TfrmImages.EnsureImageListLoaded();
|
---|
| 492 | begin
|
---|
[801] | 493 | if NumImagesAvailableOnServer = NOT_YET_CHECKED_SERVER then begin
|
---|
[453] | 494 | GetImageList();
|
---|
| 495 | end;
|
---|
| 496 | end;
|
---|
| 497 |
|
---|
| 498 | procedure TfrmImages.GetImageList();
|
---|
[801] | 499 | //Sets up ImageInfoList
|
---|
[453] | 500 | var
|
---|
| 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 |
|
---|
| 511 | begin
|
---|
| 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;
|
---|
[729] | 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;
|
---|
[453] | 580 | StatusText('');
|
---|
[801] | 581 | NumImagesAvailableOnServer := ImageInfoList.Count;
|
---|
[453] | 582 | end;
|
---|
| 583 |
|
---|
| 584 |
|
---|
| 585 | procedure TfrmImages.DownloadToCache(ImageIndex : integer);
|
---|
| 586 | //Loads image specified in ImageInfoList to Cache (unless already present)
|
---|
| 587 | var
|
---|
| 588 | Rec : TImageInfo;
|
---|
| 589 | ServerFName : AnsiString;
|
---|
| 590 | ServerPathName : AnsiString;
|
---|
| 591 |
|
---|
| 592 | begin
|
---|
| 593 | Rec := TImageInfo(ImageInfoList[ImageIndex]);
|
---|
| 594 | ServerFName := Rec.ServerFName;
|
---|
| 595 | ServerPathName := Rec.ServerPathName;
|
---|
| 596 | if not FileExists(Rec.CacheFName) then begin
|
---|
[729] | 597 | DownloadFile(ServerPathName,ServerFName,Rec.CacheFName,(ImageIndex*2)-1,ImageInfoList.Count*2);
|
---|
[453] | 598 | end;
|
---|
| 599 | ServerFName := Rec.ServerThumbFName;
|
---|
| 600 | ServerPathName := Rec.ServerThumbPathName;
|
---|
| 601 | if not FileExists(Rec.CacheThumbFName) then begin
|
---|
[729] | 602 | DownloadFile(ServerPathName,ServerFName,Rec.CacheThumbFName,ImageIndex*2,ImageInfoList.Count*2);
|
---|
[453] | 603 | end;
|
---|
| 604 | Application.ProcessMessages;
|
---|
| 605 | end;
|
---|
| 606 |
|
---|
| 607 | procedure TfrmImages.SplitLinuxFilePath(FullPathName : AnsiString;
|
---|
| 608 | var Path : AnsiString;
|
---|
| 609 | var FName : AnsiString);
|
---|
| 610 | var p : integer;
|
---|
| 611 | begin
|
---|
| 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 = '');
|
---|
| 623 | end;
|
---|
| 624 |
|
---|
| 625 |
|
---|
[729] | 626 | function TfrmImages.UploadFileViaDropBox(LocalFNamePath,FPath,FName: AnsiString;CurrentImage,TotalImages: Integer): boolean;
|
---|
| 627 | var
|
---|
| 628 | DropboxFile : AnsiString;
|
---|
| 629 | begin
|
---|
| 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 |
|
---|
[793] | 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;
|
---|
[729] | 654 | end;
|
---|
| 655 |
|
---|
| 656 |
|
---|
| 657 | function TfrmImages.UploadFile(LocalFNamePath,FPath,FName: AnsiString;CurrentImage,TotalImages: Integer): boolean;
|
---|
[453] | 658 | const
|
---|
| 659 | RefreshInterval = 500;
|
---|
| 660 | BlockSize = 512;
|
---|
| 661 |
|
---|
| 662 | var
|
---|
| 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 |
|
---|
| 675 | begin
|
---|
| 676 | result := false; //default of failure
|
---|
| 677 | if not FileExists(LocalFNamePath) then exit;
|
---|
[801] | 678 | //if UseDropBox then begin
|
---|
| 679 | if TransferMethod = itmDropbox then begin
|
---|
[729] | 680 | Result := UploadFileViaDropBox(LocalFNamePath,FPath,FName,CurrentImage,TotalImages);
|
---|
| 681 | exit;
|
---|
| 682 | end;
|
---|
[801] | 683 | //LATER add support for itmDirect mode
|
---|
[453] | 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...)
|
---|
[729] | 690 | ImageTransferForm.setMax(InFile.Size);
|
---|
| 691 | ImageTransferForm.ProgressMsg.Caption := 'Preparing to upload...';
|
---|
| 692 | ImageTransferForm.Show;
|
---|
[453] | 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;
|
---|
[729] | 727 | ImageTransferForm.updateProgress(totalReadCount);
|
---|
[453] | 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;
|
---|
[729] | 748 | ImageTransferForm.ProgressMsg.Caption := 'Uploading file to server...';
|
---|
[453] | 749 | Application.ProcessMessages;
|
---|
| 750 |
|
---|
| 751 | CallBroker;
|
---|
| 752 | Screen.Cursor := SavedCursor;
|
---|
[800] | 753 | if RPCBrokerV.Results.Count > 0 then begin
|
---|
| 754 | RPCResult := RPCBrokerV.Results[0];
|
---|
| 755 | end else RPCResult := '';
|
---|
[453] | 756 | result := (Piece(RPCResult,'^',1)='1');
|
---|
[729] | 757 | ImageTransferForm.Hide;
|
---|
[453] | 758 | if result=false then begin
|
---|
| 759 | Application.MessageBox('Error uploading file','Error');
|
---|
| 760 | end;
|
---|
| 761 |
|
---|
| 762 | InFile.Free;
|
---|
| 763 | LocalOutFile.Free;
|
---|
| 764 | StatusText('');
|
---|
| 765 | end;
|
---|
| 766 |
|
---|
| 767 |
|
---|
[729] | 768 | function TfrmImages.DownloadFileViaDropbox(FPath,FName,LocalSaveFNamePath: AnsiString;CurrentImage,TotalImages: Integer): boolean;
|
---|
[453] | 769 | var
|
---|
[729] | 770 | DropboxFile : AnsiString;
|
---|
| 771 | CurrentFileSize : Integer;
|
---|
[735] | 772 | ErrMsg : string;
|
---|
[729] | 773 | begin
|
---|
| 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 |
|
---|
[793] | 784 | //RPCBrokerV.Call; //Move file into dropbox.
|
---|
| 785 | CallBroker;
|
---|
[735] | 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;
|
---|
[729] | 793 |
|
---|
| 794 | if Result=true then begin
|
---|
[793] | 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;
|
---|
[735] | 800 | CurrentFileSize := strtoint(Piece(RPCBrokerV.Results[0],'^',3)); //Piece 3 = file size
|
---|
[729] | 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;
|
---|
[735] | 815 | end else begin
|
---|
| 816 | MessageDlg('ERROR: '+ErrMsg,mtError,[mbOK],0);
|
---|
[729] | 817 | end;
|
---|
| 818 | end;
|
---|
| 819 |
|
---|
| 820 |
|
---|
| 821 | function TfrmImages.DownloadFile(FPath,FName,LocalSaveFNamePath: AnsiString;CurrentImage,TotalImages: Integer): boolean;
|
---|
| 822 | var
|
---|
[453] | 823 | i,count : integer;
|
---|
| 824 | j : word;
|
---|
| 825 | OutFile : TFileStream;
|
---|
| 826 | s : AnsiString;
|
---|
| 827 | Buffer : array[0..1024] of byte;
|
---|
| 828 | RefreshCountdown : integer;
|
---|
| 829 |
|
---|
| 830 | const
|
---|
| 831 | RefreshInterval = 500;
|
---|
| 832 |
|
---|
| 833 | begin
|
---|
| 834 | if FileExists(LocalSaveFNamePath) then begin
|
---|
| 835 | DeleteFile(LocalSaveFNamePath);
|
---|
| 836 | end;
|
---|
[801] | 837 | //if UseDropBox then begin
|
---|
| 838 | if TransferMethod = itmDropbox then begin
|
---|
[729] | 839 | Result := DownloadFileViaDropBox(FPath,FName,LocalSaveFNamePath,CurrentImage,TotalImages);
|
---|
| 840 | exit;
|
---|
| 841 | end;
|
---|
[801] | 842 | //LATER add support for itmDirect mode
|
---|
[453] | 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('');
|
---|
| 880 | end;
|
---|
| 881 |
|
---|
| 882 |
|
---|
| 883 | function 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.
|
---|
| 887 | const
|
---|
| 888 | //FYI character set is 64 characters (starting as 'A')
|
---|
| 889 | // (65 characters if intro '=' is counted)
|
---|
| 890 | CharSet = '=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
|
---|
| 891 | var
|
---|
| 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 |
|
---|
| 901 | begin
|
---|
| 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
|
---|
| 954 | end;
|
---|
| 955 |
|
---|
| 956 |
|
---|
| 957 | function 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
|
---|
| 961 | const
|
---|
| 962 | //FYI character set is 64 characters (starting as 'A')
|
---|
| 963 | // (65 characters if intro '=' is counted)
|
---|
| 964 | CharSet = '=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
|
---|
| 965 |
|
---|
| 966 | var
|
---|
| 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 |
|
---|
| 976 | begin
|
---|
| 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;
|
---|
| 1016 | end;
|
---|
| 1017 |
|
---|
| 1018 | procedure TfrmImages.NewNoteSelected(EditIsActive : boolean);
|
---|
| 1019 | //Will be called by fNotes when a new note has been selected.
|
---|
| 1020 | //var
|
---|
| 1021 | begin
|
---|
| 1022 | ClearTabPages();
|
---|
[801] | 1023 | DownloadImagesInBackground := true;
|
---|
| 1024 | SetupTimer;
|
---|
| 1025 | //This will start downloading images after few second delay (so that if
|
---|
[453] | 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);
|
---|
| 1032 | end;
|
---|
| 1033 |
|
---|
| 1034 |
|
---|
| 1035 | procedure 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.
|
---|
| 1039 | var
|
---|
| 1040 | //CacheDir : AnsiString;
|
---|
| 1041 | FoundFile : boolean;
|
---|
| 1042 | FSearch : TSearchRec;
|
---|
| 1043 | Files : TStringList;
|
---|
| 1044 | i : integer;
|
---|
| 1045 | FName : AnsiString;
|
---|
| 1046 |
|
---|
| 1047 | begin
|
---|
| 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
|
---|
[612] | 1063 | //kt raise Exception.Create('Unable to delete file: '+FSearch.Name+#13+'Will try again later...');
|
---|
[453] | 1064 | end;
|
---|
| 1065 | end;
|
---|
| 1066 | Files.Free;
|
---|
| 1067 | end;
|
---|
| 1068 |
|
---|
| 1069 |
|
---|
| 1070 |
|
---|
| 1071 | procedure TfrmImages.UploadImagesButtonClick(Sender: TObject);
|
---|
| 1072 | var
|
---|
| 1073 | Node: TORTreeNode;
|
---|
| 1074 | AddResult : TModalResult;
|
---|
| 1075 | begin
|
---|
| 1076 | inherited;
|
---|
| 1077 | AddResult := UploadForm.ShowModal;
|
---|
| 1078 | if not IsAbortResult(AddResult) then begin
|
---|
| 1079 | NewNoteSelected(true); //force a reload to show recently added image.
|
---|
[801] | 1080 | timLoadImages.Interval := IMAGE_DOWNLOAD_DELAY_FOREGROUND;
|
---|
[453] | 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;
|
---|
| 1089 | end;
|
---|
| 1090 |
|
---|
| 1091 | procedure TfrmImages.FormHide(Sender: TObject);
|
---|
| 1092 | begin
|
---|
| 1093 | inherited;
|
---|
[801] | 1094 | DownloadImagesInBackground := true;
|
---|
| 1095 |
|
---|
[453] | 1096 | // Application.MessageBox('Here I can hide images.','title');
|
---|
| 1097 | end;
|
---|
| 1098 |
|
---|
| 1099 | procedure TfrmImages.TabControlChange(Sender: TObject);
|
---|
| 1100 | var
|
---|
| 1101 | FileName : AnsiString;
|
---|
| 1102 | Rec : TImageInfo;
|
---|
| 1103 | Selected : integer;
|
---|
| 1104 | begin
|
---|
| 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);
|
---|
| 1117 | end;
|
---|
| 1118 |
|
---|
| 1119 | procedure TfrmImages.TabControlGetImageIndex(Sender: TObject;
|
---|
| 1120 | TabIndex: Integer;
|
---|
| 1121 | var ImageIndex: Integer);
|
---|
| 1122 | //specify which image to display, from ThumbsImageList
|
---|
| 1123 | begin
|
---|
| 1124 | inherited;
|
---|
| 1125 | if (ImageInfoList <> nil) and (TabIndex < ImageInfoList.Count) then begin
|
---|
| 1126 | ImageIndex := TImageInfo(ImageInfoList[TabIndex]).TabImageIndex;
|
---|
| 1127 | end else ImageIndex := 0;
|
---|
| 1128 | end;
|
---|
| 1129 |
|
---|
| 1130 | procedure TfrmImages.TabControlResize(Sender: TObject);
|
---|
| 1131 | begin
|
---|
| 1132 | inherited;
|
---|
| 1133 | if TabControl.Width < 80 then begin
|
---|
| 1134 | TabControl.Width := 80;
|
---|
| 1135 | end;
|
---|
| 1136 | end;
|
---|
| 1137 |
|
---|
[729] | 1138 | function 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 |
|
---|
| 1160 | var
|
---|
| 1161 | i,count : integer;
|
---|
| 1162 | j : word;
|
---|
| 1163 | OutFile : TFileStream;
|
---|
| 1164 | s : AnsiString;
|
---|
| 1165 | Buffer : array[0..1024] of byte;
|
---|
| 1166 | LocalSaveFNamePath : AnsiString;
|
---|
| 1167 |
|
---|
| 1168 | begin
|
---|
| 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;
|
---|
[793] | 1181 | //RPCBrokerV.Call;
|
---|
| 1182 | CallBroker;
|
---|
[729] | 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('');
|
---|
| 1203 | end;
|
---|
| 1204 |
|
---|
| 1205 |
|
---|
| 1206 | function 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.
|
---|
| 1211 | const
|
---|
| 1212 | RefreshInterval = 500;
|
---|
| 1213 | BlockSize = 512;
|
---|
| 1214 |
|
---|
| 1215 | var
|
---|
| 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;
|
---|
| 1226 | begin
|
---|
| 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('');
|
---|
| 1294 | end;
|
---|
| 1295 |
|
---|
| 1296 |
|
---|
| 1297 | procedure TfrmImages.EnableAutoScanUploadClick(Sender: TObject);
|
---|
| 1298 | begin
|
---|
| 1299 | inherited;
|
---|
| 1300 | AutoScanUpload.Checked := not AutoScanUpload.Checked;
|
---|
| 1301 | uTMGOptions.WriteBool('Scan Enabled',AutoScanUpload.Checked);
|
---|
| 1302 | end;
|
---|
| 1303 |
|
---|
| 1304 |
|
---|
| 1305 | procedure TfrmImages.PickScanFolderClick(Sender: TObject);
|
---|
| 1306 | var
|
---|
| 1307 | CurScanDir : string;
|
---|
| 1308 | begin
|
---|
| 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;
|
---|
| 1317 | end;
|
---|
| 1318 |
|
---|
| 1319 | function TfrmImages.FileSize(fileName : wideString) : Int64;
|
---|
| 1320 | var
|
---|
| 1321 | sr : TSearchRec;
|
---|
| 1322 | begin
|
---|
| 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) ;
|
---|
| 1329 | end;
|
---|
| 1330 |
|
---|
[801] | 1331 | function TfrmImages.GetImagesCount : integer;
|
---|
| 1332 | //Returns number of images possible, not just those already downloaded.
|
---|
| 1333 | begin
|
---|
| 1334 | EnsureImageListLoaded();
|
---|
| 1335 | Result := NumImagesAvailableOnServer;
|
---|
| 1336 | end;
|
---|
| 1337 |
|
---|
| 1338 | function TfrmImages.GetImageInfo(Index : integer) : TImageInfo;
|
---|
| 1339 | begin
|
---|
| 1340 | if (Index > -1) and (Index < ImageInfoList.Count) then begin
|
---|
| 1341 | Result := TImageInfo(ImageInfoList[Index]);
|
---|
| 1342 | end else begin
|
---|
| 1343 | Result := nil;
|
---|
| 1344 | end;
|
---|
| 1345 | end;
|
---|
| 1346 |
|
---|
| 1347 |
|
---|
| 1348 |
|
---|
[453] | 1349 | initialization
|
---|
| 1350 | //put init code here
|
---|
| 1351 |
|
---|
| 1352 | finalization
|
---|
| 1353 | //put finalization code here
|
---|
| 1354 |
|
---|
| 1355 | end.
|
---|
| 1356 |
|
---|