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