unit fImages; //kt Entire unit and form added 8/19/05 {$O-} interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, fPage, StdCtrls, ExtCtrls, Menus, ComCtrls, ORCtrls, ORFn, uConst, ORDtTm, uPCE, ORClasses, fDrawers, ImgList, rTIU, uTIU, uDocTree, fRptBox, fPrintList, OleCtrls, SHDocVw, ORNet, TRPCB, fHSplit, Buttons, ExtDlgs, DKLang; type TImgDelMode = (idmNone,idmDelete,idmRetract); //NOTE: DO NOT change order TImageInfo = class private public IEN : int64; //IEN in file# 2005 ServerPathName : AnsiString; ServerFName : AnsiString; ServerThumbPathName: AnsiString; ServerThumbFName : AnsiString; //Note: if there is no thumbnail to download, CacheThumbFName will still // contain a file name and path, but a test for FileExists() will wail. CacheThumbFName : AnsiString; // local cache path and File name of thumbnail image CacheFName : AnsiString; // local cache path and File name of image ShortDesc : AnsiString; LongDesc : TStringList; //will be nil unless holds data. DateTime : AnsiString; //fileman format ImageType : Integer; ProcName : AnsiString; DisplayDate : AnsiString; ParentDataFileIEN: int64; AbsType : char; //'M' magnetic 'W' worm 'O' offline Accessibility : char; //'A' accessable or 'O' offline DicomSeriesNum : int64; DicomImageNum : int64; GroupCount : integer; TabIndex : integer; TabImageIndex : integer; published end; TImgTransferMethod = (itmDropbox,itmDirect,itmRPC); TfrmImages = class(TfrmPage) mnuNotes: TMainMenu; mnuView: TMenuItem; mnuViewChart: TMenuItem; mnuChartReports: TMenuItem; mnuChartLabs: TMenuItem; mnuChartDCSumm: TMenuItem; mnuChartCslts: TMenuItem; mnuChartNotes: TMenuItem; mnuChartOrders: TMenuItem; mnuChartMeds: TMenuItem; mnuChartProbs: TMenuItem; mnuChartCover: TMenuItem; mnuAct: TMenuItem; Z3: TMenuItem; mnuOptions: TMenuItem; timLoadImages: TTimer; N3: TMenuItem; mnuIconLegend: TMenuItem; mnuChartSurgery: TMenuItem; ThumbsImageList: TImageList; CurrentNoteMemo: TMemo; pnlTop: TPanel; HorizSplitter: TSplitter; Splitter2: TSplitter; UploadImagesButton: TBitBtn; OpenPictureDialog: TOpenPictureDialog; ButtonPanel: TPanel; CurrentImageMemo: TMemo; MemosPanel: TPanel; UploadImagesMnuAction: TMenuItem; pnlBottom: TPanel; TabControl: TTabControl; WebBrowser: TWebBrowser; AutoScanUpload: TMenuItem; PickScanFolder: TMenuItem; OpenDialog: TOpenDialog; mnuPopup: TPopupMenu; mnuPopDeleteImage: TMenuItem; mnuDeleteImage: TMenuItem; procedure mnuChartTabClick(Sender: TObject); procedure mnuActNewClick(Sender: TObject); procedure timLoadImagesTimer(Sender: TObject); procedure FormCreate(Sender: TObject); procedure FormDestroy(Sender: TObject); procedure FormShow(Sender: TObject); procedure mnuActClick(Sender: TObject); procedure UploadImagesButtonClick(Sender: TObject); procedure FormHide(Sender: TObject); procedure TabControlChange(Sender: TObject); procedure TabControlGetImageIndex(Sender: TObject; TabIndex: Integer; var ImageIndex: Integer); procedure TabControlResize(Sender: TObject); procedure EnableAutoScanUploadClick(Sender: TObject); procedure PickScanFolderClick(Sender: TObject); procedure TabControlMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure mnuPopupPopup(Sender: TObject); procedure mnuPopDeleteImageClick(Sender: TObject); procedure mnuDeleteImageClick(Sender: TObject); private ImageInfoList : TList; LastDisplayedTIUIEN : AnsiString; ImageIndexLastDownloaded : integer; FDeleteImageIndex : integer; FEditIsActive : boolean; FImageDeleteMode : TImgDelMode; procedure EnsureImageListLoaded(); procedure ClearImageList(); procedure DownloadToCache(ImageIndex : integer); procedure EmptyCache(); procedure ClearTabPages(); procedure SetupTab(i : integer); procedure UpdateNoteInfoMemo(); procedure UpdateImageInfoMemo(Rec: TImageInfo); function FileSize(fileName : wideString) : Int64; function GetImagesCount : integer; function GetImageInfo(Index : integer) : TImageInfo; procedure SetupTimer; function CanDeleteImages : boolean; procedure DeleteImageIndex(ImageIndex : integer; DeleteMode : TImgDelMode; boolPromptUser: boolean); procedure DeleteImage(var DeleteSts: TActionRec; ImageFileName: string; ImageIEN, DocIEN: Integer; DeleteMode : TImgDelMode; const Reason: string); public CacheDir : AnsiString; TransferMethod : TImgTransferMethod; DropBoxDir : string; NullImageName : AnsiString; NumImagesAvailableOnServer : integer; DownloadImagesInBackground : boolean; function Decode(input: AnsiString) : AnsiString; function Encode(input: AnsiString) : AnsiString; function DownloadFileViaDropbox(FPath,FName,LocalSaveFNamePath: AnsiString;CurrentImage,TotalImages: Integer): boolean; function DownloadFile(FPath,FName,LocalSaveFNamePath: AnsiString;CurrentImage,TotalImages: Integer): boolean; function UploadFileViaDropBox(LocalFNamePath,FPath,FName: AnsiString;CurrentImage,TotalImages: Integer): boolean; function UploadFile(LocalFNamePath,FPath,FName: AnsiString;CurrentImage,TotalImages: Integer): boolean; procedure SplitLinuxFilePath(FullPathName : AnsiString; var Path : AnsiString; var FName : AnsiString); procedure GetImageList(); procedure NewNoteSelected(EditIsActive : boolean); function CreateBarcode(MsgStr: AnsiString; ImageType: AnsiString): AnsiString; function DecodeBarcode(LocalFNamePath,ImageType: AnsiString): AnsiString; procedure EnsureImagesDownloaded(ImagesList : TStringList); procedure EnsureALLImagesDownloaded; procedure DeleteAll(DeleteMode: TImgDelMode); property ImagesCount : integer read GetImagesCount; property ImageInfo[index : integer] : TImageInfo read GetImageInfo; procedure GetThumbnailBitmapForFName (FName : string; Bitmap : TBitmap); function ThumbnailIndexForFName (FName : string) : integer; published end; Const IMAGE_TRANSFER_METHODS : Array[itmDropbox..itmRPC] of string[32] = ( 'Dropbox Transfer', 'Direct Access', 'Embedded in RPCs'); IMAGE_DOWNLOAD_DELAY_BACKGROUND = 30000; IMAGE_DOWNLOAD_DELAY_FOREGROUND = 100; NOT_YET_CHECKED_SERVER = -2; //NOTE: If order is changed in ThumbsImageList, these numbers should be changed IMAGE_INDEX_IMAGE = 0; IMAGE_INDEX_ADOBE = 1; IMAGE_INDEX_VIDEO = 2; IMAGE_INDEX_SOUND = 3; IMAGE_INDEX_MISC = 4; var frmImages: TfrmImages; implementation {$R *.DFM} uses fFrame, fVisit, fEncnt, rCore, uCore, fNoteBA, fNoteBD, fSignItem, fEncounterFrame, rPCE, Clipbrd, fNoteCslt, fNotePrt, rVitals, fAddlSigners, fNoteDR, fConsults, uSpell, fTIUView, fTemplateEditor, uReminders, fReminderDialog, uOrders, rConsults, fReminderTree, fNoteProps, fNotesBP, fTemplateFieldEditor, dShared, rTemplates, FIconLegend, fPCEEdit, fNoteIDParents, rSurgery, uSurgery, uTemplates, uAccessibleTreeView, uAccessibleTreeNode, fTemplateDialog, DateUtils, StrUtils, mshtml, UploadImages, uTMGOptions, //kt 3/10/10 rHTMLTools, fNotes, frmImageTransferProgress, fImagePickExisting; {//kt added 5-27-05 for IsHTMLDocument} procedure TfrmImages.FormCreate(Sender: TObject); //var i : integer; begin inherited; LastDisplayedTIUIEN := '0'; FDeleteImageIndex := -1; ImageInfoList := TList.Create; ClearImageList(); //sets up other needed variables. DownloadImagesInBackground := true; CacheDir := ExtractFilePath(ParamStr(0))+ 'Cache'; NullImageName := 'about:blank'; if not DirectoryExists(CacheDir) then ForceDirectories(CacheDir); TransferMethod := TImgTransferMethod(uTMGOptions.ReadInteger('ImageTransferMethod',2)); DropBoxDir := uTMGOptions.ReadString('Dropbox directory','??'); if DropBoxDir='??' then begin //just on first run. uTMGOptions.WriteBool('Use dropbox directory for transfers',false); uTMGOptions.WriteString('Dropbox directory',''); end; AutoScanUpload.Checked := uTMGOptions.ReadBool('Scan Enabled',false); end; procedure TfrmImages.FormDestroy(Sender: TObject); begin inherited; ClearImageList; ImageInfoList.Free; EmptyCache; end; procedure TfrmImages.FormShow(Sender: TObject); var TIUIEN : AnsiString; begin inherited; mnuDeleteImage.Enabled := CanDeleteImages; TIUIEN := IntToStr(frmNotes.lstNotes.ItemID); DownloadImagesInBackground := false; SetupTimer; if LastDisplayedTIUIEN <> TIUIEN then begin UpdateNoteInfoMemo(); LastDisplayedTIUIEN := TIUIEN; end; end; procedure TfrmImages.timLoadImagesTimer(Sender: TObject); //This function's goal is to download images in the background, // with one image to be downloaded each time the timer fires begin inherited; timLoadImages.Enabled := false; EnsureImageListLoaded(); if NumImagesAvailableOnServer = 0 then exit; if (ImageIndexLastDownloaded >= (ImageInfoList.Count-1)) then exit; ImageTransferForm.ProgressMsg.Caption := 'Downloading Images'; DownloadToCache(ImageIndexLastDownloaded+1); //Only load 1 image per timer firing. SetupTab(ImageIndexLastDownloaded+1); Inc(ImageIndexLastDownloaded); if TabControl.TabIndex < 0 then TabControl.TabIndex := 0; TabControlChange(self); SetupTimer; end; procedure TfrmImages.SetupTimer; begin if DownloadImagesInBackground then begin timLoadImages.Interval := IMAGE_DOWNLOAD_DELAY_BACKGROUND; end else begin timLoadImages.Interval := IMAGE_DOWNLOAD_DELAY_FOREGROUND; end; timLoadImages.Enabled := true; end; procedure TfrmImages.EnsureImagesDownloaded(ImagesList : TStringList); //This function's goal is to download images in the FOREground, // But only images matching those passed in ImagesList will be downloaded; // The intent is to only download images that have links to them in HTML source //Thus, if note has a large amount of images attached to it, but not referenced // in HTML code, then they will not be downloaded here. (But will be downloaded // later via timLoadImagesTimer var i : integer; Rec : TImageInfo; begin if ImagesList.Count = 0 then exit; GetImageList(); if ImageInfoList.Count = 0 then exit; if ImageInfoList.Count > 1 then begin ImageTransferForm.ProgressMsg.Caption := 'Downloading Images'; ImageTransferForm.ProgressBar.Min := 0; ImageTransferForm.ProgressBar.Position := 0; ImageTransferForm.ProgressBar.Max := ImageInfoList.Count-1; ImageTransferForm.Show; end; for i := 0 to ImageInfoList.Count-1 do begin ImageTransferForm.ProgressBar.Position := i; Rec := TImageInfo(ImageInfoList[i]); if ImagesList.IndexOf(Rec.ServerFName)>-1 then begin DownloadToCache(i); end; end; ImageTransferForm.Hide; end; procedure TfrmImages.EnsureALLImagesDownloaded; //This function's goal is to download ALL images in the FOREground. begin EnsureImageListLoaded(); if NumImagesAvailableOnServer = 0 then exit; ImageTransferForm.ProgressMsg.Caption := 'Downloading Images'; while (ImageIndexLastDownloaded < (ImageInfoList.Count-1)) do begin DownloadToCache(ImageIndexLastDownloaded+1); //Only load 1 image per timer firing. SetupTab(ImageIndexLastDownloaded+1); Inc(ImageIndexLastDownloaded); if TabControl.TabIndex < 0 then TabControl.TabIndex := 0; TabControlChange(self); end; end; { TPage common methods --------------------------------------------------------------------- } procedure TfrmImages.mnuChartTabClick(Sender: TObject); { reroute to Chart Tab menu of the parent form: frmFrame } begin inherited; frmFrame.mnuChartTabClick(Sender); end; procedure TfrmImages.mnuActNewClick(Sender: TObject); const IS_ID_CHILD = False; { switches to current new note or creates a new note if none is being edited already } begin inherited; end; procedure TfrmImages.mnuActClick(Sender: TObject); begin inherited; end; { General procedures ----------------------------------------------------------------------- } procedure TfrmImages.UpdateImageInfoMemo(Rec : TImageInfo); var s : AnsiString; i : integer; begin CurrentImageMemo.Lines.Clear; if Rec=nil then exit; s := Trim(Rec.ShortDesc); if s <> '' then CurrentImageMemo.Lines.Add('Description: ' + s); s := Rec.ProcName; if s <> '' then CurrentImageMemo.Lines.Add('Procedure: ' + s); s := Rec.DisplayDate; if s <> '' then CurrentImageMemo.Lines.Add('Upload Date: ' + s); //s := Rec.DateTime; //if s <> '' then CurrentImageMemo.Lines.Add('Date/Time: ' + s); if Rec.LongDesc <> nil then begin CurrentImageMemo.Lines.Add('Long Description:'); for i := 0 to Rec.LongDesc.Count-1 do begin CurrentImageMemo.Lines.Add(' ' + Rec.LongDesc.Strings[i]); end; end; end; procedure TfrmImages.UpdateNoteInfoMemo(); var NoteInfo,s : AnsiString; //dateS : AnsiString; const U='^'; begin CurrentNoteMemo.Lines.Clear; with frmNotes.lstNotes do begin if ItemIndex > -1 then begin NoteInfo := Items[ItemIndex] (* example NoteInfo: piece# 1: 14321^ //TIU IEN piece# 2: PRESCRIPTION CALL IN^ //Document Title piece# 3: 3050713.0947^ //Date/Time piece# 4: TEST, KILLME D (T0101)^ //Patient piece# 5: 133;JANE A DOE;DOE,JANE A^ //Author piece# 6: Main_Office^ //Location of Visit piece# 7: completed^ //Status of Document piece# 8: Visit: 07/13/05;3050713.094721^ //Date/Time piece# 9...: ;^^1^^^1^' //? *) end else NoteInfo := ''; end; if NoteInfo <>'' then begin s := Piece(NoteInfo, U, 2) + ' -- '; s := s + Piece(Piece(NoteInfo, U, 8), ';', 1); CurrentNoteMemo.Lines.Add(s); s := 'Location: ' + Piece(NoteInfo, U, 6) + ' -- '; s := s + 'Note Author: ' + Piece(Piece(NoteInfo, U, 5), ';', 2); CurrentNoteMemo.Lines.Add(s); end; end; procedure TfrmImages.SetupTab(i : integer); //i is index in ImageInfoList (array of TImageInfo's) var Rec : TImageInfo; //this will be a copy of record, not pointer (I think) Bitmap : TBitmap; index : integer; Ext : AnsiString; (*Notice: A TabControl doesn't directly support specifying which images in an ImageList to show for a given tab. To get around this, the help documentation recommends setting up a TabControlGetImageIndex event handler. I am doing this. When the event is called, then RecInfo.TabImageIndex is returned. *) begin if i < ImageInfoList.Count then begin Rec := TImageInfo(ImageInfoList[i]); if (Rec.TabImageIndex < 1) then begin if FileExists(Rec.CacheThumbFName) then begin Bitmap := TBitmap.Create; Bitmap.Width := 1024; //something big enough to hold any thumbnail. Bitmap.Height := 768; Bitmap.LoadFromFile(Rec.CacheThumbFName); Bitmap.Width := ThumbsImageList.Width; //shrinkage crops image Bitmap.Height := ThumbsImageList.Height; index := ThumbsImageList.Add(Bitmap,nil); //TImageInfo(ImageInfoList[i]).TabImageIndex := index; Rec.TabImageIndex := index; Bitmap.Free; end else begin Rec.TabImageIndex := ThumbnailIndexForFName(Rec.CacheFName); end; end; TabControl.Tabs.Add(' '); //add the tab. Thumbnail should exist before this end; end; function TfrmImages.ThumbnailIndexForFName (FName : string) : integer; var index : integer; Ext : AnsiString; begin Result := 4; //default Ext := LowerCase(ExtractFileExt(FName)); Ext := MidStr(Ext,2,99); if (Ext='jpg') or (Ext='jpeg') or (Ext='png') or (Ext='tif') or (Ext='tiff') or (Ext='gif') or (Ext='bmp') then begin Result := IMAGE_INDEX_IMAGE; //camera image end else if (Ext='pdf') then begin Result := IMAGE_INDEX_ADOBE; //adobe icon end else if (Ext='avi') or (Ext='qt') or (Ext='mpg') or (Ext='mpeg') then begin Result := IMAGE_INDEX_VIDEO; //video icon end else if (Ext='mp3') or (Ext='wma') or (Ext='au') or (Ext='wav') then begin Result := IMAGE_INDEX_SOUND; //sound icon end else begin Result := IMAGE_INDEX_MISC; // misc icon end; end; procedure TfrmImages.GetThumbnailBitmapForFName (FName : string; Bitmap : TBitmap); var index: integer; begin index := ThumbnailIndexForFName(FName); ThumbsImageList.GetBitmap(index,Bitmap); end; procedure TfrmImages.ClearTabPages(); begin TabControl.Tabs.Clear; ClearImageList(); end; procedure TfrmImages.ClearImageList(); //Note: !! This should also clear any visible images/thumbnails etc. //Note: Need to remove thumbnail image from image list. var i : integer; begin for i := ImageInfoList.Count-1 downto 0 do begin if TImageInfo(ImageInfoList[i]).LongDesc <> nil then begin TImageInfo(ImageInfoList[i]).LongDesc.Free; end; TImageInfo(ImageInfoList[i]).Free; ImageInfoList.Delete(i); end; NumImagesAvailableOnServer := NOT_YET_CHECKED_SERVER; ImageIndexLastDownloaded := -1; end; procedure TfrmImages.EnsureImageListLoaded(); begin if NumImagesAvailableOnServer = NOT_YET_CHECKED_SERVER then begin GetImageList(); end; end; procedure TfrmImages.GetImageList(); //Sets up ImageInfoList var i,j : integer; s,s2 : AnsiString; Rec : TImageInfo; ImageIEN : integer; TIUIEN : AnsiString; ServerFName : AnsiString; ServerPathName : AnsiString; ImageFPathName : AnsiString; //path on server of image -- original data provided by server ThumbnailFPathName : AnsiString; //path on server of thumbnail -- original data provided by server begin inherited; ClearImageList; try TIUIEN := IntToStr(frmNotes.lstNotes.ItemID); except //Error occurs after note is signed, and frmNotes.lstNotes.ItemID is "inaccessible" on E: Exception do exit; end; StatusText('Retrieving images information...'); CallV('MAG3 CPRS TIU NOTE', [TIUIEN]); for i:=0 to (RPCBrokerV.Results.Count-1) do begin s :=RPCBrokerV.Results[i]; if i=0 then begin if piece(s,'^',1)='0' then break //i.e. abort due to error signal else continue; //ignore rest of header (record #0) end; if Pos('-1~',s)>0 then continue; //abort if error signal. Rec := TImageInfo.Create; // ImageInfoList will own this. Rec.LongDesc := nil; Rec.TabIndex := -1; Rec.TabImageIndex := 0; s2 := piece(s,'^',2); if s2='' then s2 := '0'; //IEN Rec.IEN := StrToInt(s2); ImageFPathName := piece(s,'^',3); //Image FullPath and name ThumbnailFPathName := piece(s,'^',4); //Abstract FullPath and Name Rec.ShortDesc := piece(s,'^',5); //SHORT DESCRIPTION field s2 := piece(s,'^',6); if s2='' then s2 := '0'; //PROCEDURE/ EXAM DATE/TIME field Rec.DateTime := s2; s2 := piece(s,'^',7); if s2='' then s2 := '0'; //OBJECT TYPE Rec.ImageType := StrToInt(s2); Rec.ProcName := piece(s,'^',8); //PROCEDURE field Rec.DisplayDate := piece(s,'^',9); //Procedure Date in Display format s2 := piece(s,'^',10); if s2='' then s2 := '0'; //PARENT DATA FILE image pointer Rec.ParentDataFileIEN := StrToInt(s2); Rec.AbsType := piece(s,'^',11)[1]; //the ABSTYPE : 'M' magnetic 'W' worm 'O' offline s2 := piece(s,'^',12); if s2='' then s2 :='O'; Rec.Accessibility := s2[1]; //Image accessibility 'A' accessable or 'O' offline s2 := piece(s,'^',13); if s2='' then s2 := '0'; //Dicom Series number Rec.DicomSeriesNum := StrToInt(s2); s2 := piece(s,'^',14); if s2='' then s2 := '0'; //Dicom Image Number Rec.DicomImageNum := StrToInt(s2); s2 := piece(s,'^',15); if s2='' then s2 := '0'; //Count of images in the group, or 1 if a single image Rec.GroupCount := StrToInt(s2); SplitLinuxFilePath(ImageFPathName,ServerPathName,ServerFName); Rec.ServerPathName := ServerPathName; Rec.ServerFName := ServerFName; Rec.CacheFName := CacheDir + '\' + ServerFName; SplitLinuxFilePath(ThumbnailFPathName,ServerPathName,ServerFName); Rec.ServerThumbPathName := ServerPathName; Rec.ServerThumbFName := ServerFName; Rec.CacheThumbFName := CacheDir + '\' + ServerFName; ImageInfoList.Add(Rec); // ImageInfoList will own Rec. end; for i:= 0 to ImageInfoList.Count-1 do begin Rec := TImageInfo(ImageInfoList.Items[i]); ImageIEN := Rec.IEN; CallV('TMG GET IMAGE LONG DESCRIPTION', [ImageIEN]); for j:=0 to (RPCBrokerV.Results.Count-1) do begin if (j>0) then begin if Rec.LongDesc = nil then Rec.LongDesc := TStringList.Create; Rec.LongDesc.Add(RPCBrokerV.Results.Strings[j]); end else begin if RPCBrokerV.Results[j]='' then break; end; end; end; StatusText(''); NumImagesAvailableOnServer := ImageInfoList.Count; end; procedure TfrmImages.DownloadToCache(ImageIndex : integer); //Loads image specified in ImageInfoList to Cache (unless already present) var Rec : TImageInfo; ServerFName : AnsiString; ServerPathName : AnsiString; begin Rec := TImageInfo(ImageInfoList[ImageIndex]); ServerFName := Rec.ServerFName; ServerPathName := Rec.ServerPathName; if not FileExists(Rec.CacheFName) then begin DownloadFile(ServerPathName,ServerFName,Rec.CacheFName,(ImageIndex*2)-1,ImageInfoList.Count*2); end; ServerFName := Rec.ServerThumbFName; ServerPathName := Rec.ServerThumbPathName; if not FileExists(Rec.CacheThumbFName) then begin DownloadFile(ServerPathName,ServerFName,Rec.CacheThumbFName,ImageIndex*2,ImageInfoList.Count*2); end; Application.ProcessMessages; end; procedure TfrmImages.SplitLinuxFilePath(FullPathName : AnsiString; var Path : AnsiString; var FName : AnsiString); var p : integer; begin Path := ''; FName := ''; repeat p := Pos('/',FullPathName); if p > 0 then begin Path := Path + MidStr(FullPathName,1,p); FullPathName := MidStr(FullPathName,p+1,1000); end else begin FName := FullPathName; FullPathName := ''; end; until (FullPathName = ''); end; function TfrmImages.UploadFileViaDropBox(LocalFNamePath,FPath,FName: AnsiString;CurrentImage,TotalImages: Integer): boolean; var DropboxFile : AnsiString; begin //First copy LocalFileNamePath --> DropBox\FileName DropboxFile := ExcludeTrailingBackslash(DropboxDir) + '\' + FName; if CopyFile(pchar(LocalFNamePath),pchar(DropboxFile),false)=false then begin MessageDlg('Dropbox file transfer failed. Code='+InttoStr(GetLastError), mtError,[mbOK],0); result := false; exit; end; CallV('TMG UPLOAD FILE DROPBOX', [FPath,FName]); //Move file into dropbox. { RPCBrokerV.ClearParameters := true; RPCBrokerV.remoteprocedure := 'TMG UPLOAD FILE DROPBOX'; RPCBrokerV.param[0].PType := literal; RPCBrokerV.param[0].Value := FPath; RPCBrokerV.Param[1].PType := literal; RPCBrokerV.Param[1].Value := FName; RPCBrokerV.Param[2].PType := literal; RPCBrokerV.Param[2].Value := '1'; //see comments in UploadFile re '1' hardcoding CallBroker; //Move file into dropbox. } if RPCBrokerV.Results.Count>0 then begin Result := (Piece(RPCBrokerV.Results[0],'^',1)='1'); //1=success, 0=failure end else Result := false; end; function TfrmImages.UploadFile(LocalFNamePath,FPath,FName: AnsiString;CurrentImage,TotalImages: Integer): boolean; const RefreshInterval = 500; BlockSize = 512; var ReadCount : Word; totalReadCount : Integer; ParamIndex : LongWord; j : word; InFile : TFileStream; LocalOutFile : TFileStream; Buffer : array[0..1024] of byte; RefreshCountdown : integer; OneLine : AnsiString; RPCResult : AnsiString; SavedCursor : TCursor; begin result := false; //default of failure if not FileExists(LocalFNamePath) then exit; //if UseDropBox then begin if TransferMethod = itmDropbox then begin Result := UploadFileViaDropBox(LocalFNamePath,FPath,FName,CurrentImage,TotalImages); exit; end; //LATER add support for itmDirect mode try InFile := TFileStream.Create(LocalFNamePath,fmOpenRead or fmShareCompat); LocalOutFile := TFileStream.Create(CacheDir+'\'+FName,fmCreate or fmOpenWrite); //for local copy //Note: I may well cut this out. Most of the delay occurs during // the RPC call, and I can't make a progress bar change during that... // (or I could, but I'm not going to change the RPC broker...) ImageTransferForm.setMax(InFile.Size); ImageTransferForm.ProgressMsg.Caption := 'Preparing to upload...'; ImageTransferForm.Show; totalReadCount := 0; except // catch failure here... on eError... exit; end; StatusText('Uploading full image...'); Application.ProcessMessages; RPCBrokerV.remoteprocedure := 'TMG UPLOAD FILE'; RPCBrokerV.ClearParameters := true; RPCBrokerV.Param[0].PType := literal; RPCBrokerV.Param[0].Value := FPath; RPCBrokerV.Param[1].PType := literal; RPCBrokerV.Param[1].Value := FName; RPCBrokerV.Param[2].PType := literal; RPCBrokerV.Param[2].Value := ''; //kt 7/11/10 //RPCBrokerV.Param[2].Value := '1'; //Specifying a NETWORK LOCATION is now depreciated. RPCBrokerV.Param[3].PType := list; ParamIndex := 0; RefreshCountdown := RefreshInterval; repeat ReadCount := InFile.Read(Buffer,BlockSize); LocalOutFile.Write(Buffer,ReadCount); //for local copy totalReadCount := totalReadCount + ReadCount; ImageTransferForm.updateProgress(totalReadCount); OneLine := ''; if ReadCount > 0 then begin SetLength(OneLine,ReadCount); for j := 1 to ReadCount do OneLine[j] := char(Buffer[j-1]); RPCBrokerV.Param[3].Mult[IntToStr(ParamIndex)] := Encode(OneLine); Inc(ParamIndex); Dec(RefreshCountdown); if RefreshCountdown < 1 then begin Application.ProcessMessages; RefreshCountdown := RefreshInterval; end; end; until (ReadCount < BlockSize); SavedCursor := Screen.Cursor; Screen.Cursor := crHourGlass; ImageTransferForm.ProgressMsg.Caption := 'Uploading file to server...'; Application.ProcessMessages; CallBroker; Screen.Cursor := SavedCursor; if RPCBrokerV.Results.Count > 0 then begin RPCResult := RPCBrokerV.Results[0]; end else RPCResult := ''; result := (Piece(RPCResult,'^',1)='1'); ImageTransferForm.Hide; if result=false then begin Application.MessageBox('Error uploading file','Error'); end; InFile.Free; LocalOutFile.Free; StatusText(''); end; function TfrmImages.DownloadFileViaDropbox(FPath,FName,LocalSaveFNamePath: AnsiString;CurrentImage,TotalImages: Integer): boolean; var DropboxFile : AnsiString; CurrentFileSize : Integer; ErrMsg : string; begin CallV('TMG DOWNLOAD FILE DROPBOX', [FPath,FName]); //Move file into dropbox. {RPCBrokerV.ClearParameters := true; RPCBrokerV.remoteprocedure := 'TMG DOWNLOAD FILE DROPBOX'; RPCBrokerV.param[0].PType := literal; RPCBrokerV.param[0].Value := FPath; RPCBrokerV.Param[1].PType := literal; RPCBrokerV.Param[1].Value := FName; RPCBrokerV.Param[2].PType := literal; RPCBrokerV.Param[2].Value := '1'; //see comments in UploadFile re '1' hardcoding CallBroker; } if RPCBrokerV.Results.Count > 0 then begin Result := (Piece(RPCBrokerV.Results[0],'^',1)='1'); //1=success, 0=failure if Result = false then ErrMsg := Piece(RPCBrokerV.Results[0],'^',2); end else begin Result := false; ErrMsg := 'Error communicating with server to retrieve image.'; end; if Result=true then begin if DirectoryExists(DropboxDir) = False then begin //elh added to ensure a dropbox directory is valid MessageDlg('Invalid Dropbox Directory. Please check your settings and try again.',mtError,[mbOK],0); ImageTransferForm.hide; exit; end; CurrentFileSize := strtoint(Piece(RPCBrokerV.Results[0],'^',3)); //Piece 3 = file size DropboxFile := ExcludeTrailingBackslash(DropboxDir) + '\' + FName; if ImageTransferForm.visible = False then ImageTransferForm.show; while FileSize(DropboxFile) <> CurrentFileSize do sleep(1000); //elh ImageTransferForm.ProgressBar.Max := TotalImages; //elh ImageTransferForm.ProgressBar.Position := CurrentImage+2; //elh if TotalImages = (CurrentImage+2) then begin Sleep(1000); ImageTransferForm.hide; end; //Now move DropBox\FileName --> LocalFileNamePath if MoveFile(pchar(DropboxFile),pchar(LocalSaveFNamePath))=false then begin MessageDlg('Dropbox file transfer failed. Code='+InttoStr(GetLastError), mtError,[mbOK],0); end; end else begin MessageDlg('ERROR: '+ErrMsg,mtError,[mbOK],0); end; end; function TfrmImages.DownloadFile(FPath,FName,LocalSaveFNamePath: AnsiString;CurrentImage,TotalImages: Integer): boolean; var i,count : integer; j : word; OutFile : TFileStream; s : AnsiString; Buffer : array[0..1024] of byte; RefreshCountdown : integer; const RefreshInterval = 500; begin if FileExists(LocalSaveFNamePath) then begin DeleteFile(LocalSaveFNamePath); end; if TransferMethod = itmDropbox then begin Result := DownloadFileViaDropBox(FPath,FName,LocalSaveFNamePath,CurrentImage,TotalImages); exit; end; //LATER add support for itmDirect mode Result := true; //default to success; StatusText('Retrieving full image...'); //kt CallV('TMG DOWNLOAD FILE', [FPath,FName,'1']); //kt 7/10/10 Specifying a NETWORK LOCATION is depreciated. CallV('TMG DOWNLOAD FILE', [FPath,FName]); Application.ProcessMessages; RefreshCountdown := RefreshInterval; //Note:RPCBrokerV.Results[0]=1 if successful load, =0 if failure if (RPCBrokerV.Results.Count>0) and (RPCBrokerV.Results[0]='1') then begin OutFile := TFileStream.Create(LocalSaveFNamePath,fmCreate); for i:=1 to (RPCBrokerV.Results.Count-1) do begin s :=Decode(RPCBrokerV.Results[i]); count := Length(s); if count>1024 then begin Result := false; //failure of load. break; end; for j := 1 to count do Buffer[j-1] := ord(s[j]); OutFile.Write(Buffer,count); Dec(RefreshCountdown); if RefreshCountdown < 1 then begin Application.ProcessMessages; RefreshCountdown := RefreshInterval; end; end; OutFile.Free; end else begin result := false; end; StatusText(''); end; function TfrmImages.Encode(Input: AnsiString) : AnsiString; //This function is based on ENCODE^RGUTUU, which is match for //DECODE^RGUTUU that is used to decode (ascii armouring) on the //server side. This is a base64 encoder. const //FYI character set is 64 characters (starting as 'A') // (65 characters if intro '=' is counted) CharSet = '=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; var //Result : AnsiString; // RGZ1 //'Result' is implicitly declared by Pascal i : integer; //RGZ2 j : integer; //RGZ4 PlainTrio : longword; //RGZ3 //unsigned 32-bit EncodedByte : Byte; PlainByte : byte; //RGZ5 EncodedQuad : string[4];//RGZ6 begin //e.g. input (10 bytes): // 174 231 193 16 29 251 93 138 4 57 // AE E7 C1 10 1D FB 5D 8A 04 39 Result := ''; i := 1; while i<= Length(Input) do begin //cycle in groups of 3 PlainTrio := 0; EncodedQuad := ''; //Get 3 bytes, to be converted into 4 characters eventually. //Fill with 0's if needed to make an even 3-byte group. For j:=0 to 2 do begin //e.g. '174'->PlainByte=174 if (i+j) <= Length(Input) then PlainByte := ord(Input[i+j]) else PlainByte := 0; PlainTrio := (PlainTrio shl 8) or PlainByte; end; //e.g. first 3 bytes--> PlainTrio= $AEE7C1 (10101110 11100111 11000001) //e.g. last 3 bytes--> PlainTrio= $390000 (00111001 00000000 00000000) (note padded 0's) //Take each 6 bits and convert into a character. //e.g. first 3 bytes--> (101011 101110 011111 000001) // 43 46 31 1 //e.g. last 3 bytes-->(001110 010000 000000 000000) (after redivision) // 14 16 0 0 <-- last 2 bytes are padded 0 // ^ last 4 bits of '16' are padded 0's For j := 1 to 4 do begin //e.g. $AEE7C1 --> (43+2)=45 (46+2)=48 (31+2)=33 (1+2)=3 // r u f b //e.g. $39AF00 --> (14+2)=16 (16+2)=18 (0+2)=2 (0+2)=2 // O Q A A <-- 2 padded bytes EncodedByte := (PlainTrio and 63)+2; //63=$3F=b0111111; 0->A 1->B etc EncodedQuad := CharSet[EncodedByte]+ EncodedQuad; //string Concat, not math add PlainTrio := PlainTrio shr 6 end; //Append result with latest quad Result := Result + EncodedQuad; Inc(i,3); end; // e.g. result: rufb .... .... OQAA <-- 2 padded bytes (and part of Q is padded also) i := 3-(Length(Input) mod 3); //returns 1,2,or 3 (3 needs to be set to 0) if (i=3) then i:=0; //e.g. input=10 -> i=2 j := Length(Result); //i is the number of padded characters that need to be replaced with '=' if i>=1 then Result[j] := '='; //replace 1st paddeded char if i>=2 then Result[Length(Result)-1] := '=';//replace 2nd paddeded char // e.g. result: rufb .... .... OQ== //results passed out in Result end; function TfrmImages.Decode(Input: AnsiString) : AnsiString; //This function is based on DECODE^RGUTUU, which is match for //ENCODE^RGUTUU that is used to encode (ascii armouring) on the //server side. This is a Base64 decoder const //FYI character set is 64 characters (starting as 'A') // (65 characters if intro '=' is counted) CharSet = '=ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; var //Result : AnsiString; //RGZ1 //'Result' is implicitly declared by Pascal i : integer; //RGZ2 PlainTrio : longword; //RGZ3 //unsigned 32-bit j : integer; //RGZ4 EncodedChar : char; PlainInt : integer; PlainByte : byte; //RGZ5 DecodedTrio : string[3];//RGZ6 begin Result:=''; i := 1; //e.g. input: rufb .... .... OQ== while i <= Length(Input) Do begin //cycle in groups of 4 PlainTrio :=0; DecodedTrio :=''; //Get 4 characters, to be converted into 3 bytes. For j :=0 to 3 do begin //e.g. last 4 chars --> 0A== if (i+j) <= Length(Input) then begin EncodedChar := Input[i+j]; PlainInt := Pos(EncodedChar,CharSet)-2; //A=0, B=1 etc. if (PlainInt>=0) then PlainByte := (PlainInt and $FF) else PlainByte := 0; end else PlainByte := 0; //e.g. with last 4 characters: //e.g. '0'->14=(b001110) 'Q'->16=(b010000) '='-> -1 -> 0=(b000000) '=' -> 0=(b000000) //e.g.-- So last PlainTrio = 001110 010000 000000 000000 = 00111001 00000000 00000000 //Each encoded character contributes 6 bytes to final 3 bytes. //4 chars * 6 bits/char=24 bits --> 24 bits / 8 bits/byte = 3 bytes PlainTrio := (PlainTrio shl 6) or PlainByte; //PlainTrio := PlainTrio*64 + PlainByte; end; //Now take 3 bytes, and add to cumulative output (in same order) For j :=0 to 2 do begin DecodedTrio := Chr(PlainTrio and $FF) + DecodedTrio; //string concat (not math addition) PlainTrio := PlainTrio shr 8; // PlainTrio := PlainTrio div 256 end; //e.g. final DecodedTrio = 'chr($39) + chr(0) + chr(0)' Result := Result + DecodedTrio; Inc(i,4); end; //Now remove 1 byte from the output for each '=' in input string //(each '=' represents 1 padded 0 added to allow for even groups of 3) for j :=0 to 1 do begin if (Input[Length(Input)-j] = '=') then begin Result := MidStr(Result,1,Length(Result)-1); end; end; end; procedure TfrmImages.NewNoteSelected(EditIsActive : boolean); //Will be called by fNotes when a new note has been selected. //var begin ClearTabPages(); DownloadImagesInBackground := true; SetupTimer; //This will start downloading images after few second delay (so that if //user is just browsing past note, this won't waste effort. //If user selects images tab, then load will occur without delay. //Note: OnTimer calls timLoadImagesTimer() FEditIsActive := EditIsActive; UploadImagesButton.Enabled := EditIsActive; UploadImagesMnuAction.Enabled := EditIsActive; WebBrowser.Navigate(NullImageName); end; procedure TfrmImages.EmptyCache(); //This will delete ALL files in the Cache directory //Note: This will include the html_note file created by // the notes tab. var //CacheDir : AnsiString; FoundFile : boolean; FSearch : TSearchRec; Files : TStringList; i : integer; FName : AnsiString; begin Files := TStringList.Create; // CacheDir := ExtractFilePath(ParamStr(0))+ 'Cache'; FoundFile := (FindFirst(CacheDir+'\*.*',faAnyFile,FSearch)=0); while FoundFile do Begin FName := FSearch.Name; if (FName <> '.') and (FName <> '..') then begin FName := CacheDir + '\' + FName; Files.Add(FName); end; FoundFile := (FindNext(FSearch)=0); end; for i := 0 to Files.Count-1 do begin FName := Files.Strings[i]; if DeleteFile(FName) = false then begin //kt raise Exception.Create('Unable to delete file: '+FSearch.Name+#13+'Will try again later...'); end; end; Files.Free; end; procedure TfrmImages.UploadImagesButtonClick(Sender: TObject); var Node: TORTreeNode; AddResult : TModalResult; begin inherited; AddResult := UploadForm.ShowModal; if not IsAbortResult(AddResult) then begin NewNoteSelected(true); //force a reload to show recently added image. timLoadImages.Interval := IMAGE_DOWNLOAD_DELAY_FOREGROUND; Node := TORTreeNode(frmNotes.tvNotes.Selected); case Node.StateIndex of IMG_NO_IMAGES : Node.StateIndex := IMG_1_IMAGE; IMG_1_IMAGE : Node.StateIndex := IMG_2_IMAGES; IMG_2_IMAGES : Node.StateIndex := IMG_MANY_IMAGES; IMG_MANY_IMAGES : Node.StateIndex := IMG_MANY_IMAGES; end; end; end; procedure TfrmImages.FormHide(Sender: TObject); begin inherited; DownloadImagesInBackground := true; // Application.MessageBox('Here I can hide images.','title'); end; procedure TfrmImages.TabControlChange(Sender: TObject); var FileName : AnsiString; Rec : TImageInfo; Selected : integer; begin inherited; //here tab has been changed. Selected := TabControl.TabIndex; if Selected > -1 then begin Rec := TImageInfo(ImageInfoList[Selected]); FileName := Rec.CacheFName; UpdateImageInfoMemo(Rec); end else begin FileName := NullImageName; UpdateImageInfoMemo(nil); end; WebBrowser.Navigate(FileName); end; procedure TfrmImages.TabControlGetImageIndex(Sender: TObject; TabIndex: Integer; var ImageIndex: Integer); //specify which image to display, from ThumbsImageList begin inherited; if (ImageInfoList <> nil) and (TabIndex < ImageInfoList.Count) then begin ImageIndex := TImageInfo(ImageInfoList[TabIndex]).TabImageIndex; end else ImageIndex := 0; end; procedure TfrmImages.TabControlResize(Sender: TObject); begin inherited; if TabControl.Width < 80 then begin TabControl.Width := 80; end; end; function TfrmImages.CreateBarcode(MsgStr: AnsiString; ImageType: AnsiString): AnsiString; //Create a local barcode file, in .png format, from MsgStr //ImageType is optional, default ='png'. It should NOT contain '.' //Returns file path on local client of new barcode image. //Note: this function is not related to uploading or downloading images // to the server for attaching to progress notes. It is included // in this unit because the functionality used is nearly identical to // the other code. function UniqueFName : AnsiString; var FName,tempFName : AnsiString; count : integer; begin FName := 'Barcode-Image'; count := 0; repeat tempFName := CacheDir + '\' + FName + '.' + ImageType; FName := FName + '1'; count := count+1; until (fileExists(tempFName)=false) or (count> 32); result := tempFName; end; var i,count : integer; j : word; OutFile : TFileStream; s : AnsiString; Buffer : array[0..1024] of byte; LocalSaveFNamePath : AnsiString; begin StatusText('Getting Barcode...'); LocalSaveFNamePath := UniqueFName; Result := LocalSaveFNamePath; //default to success; // CallV('TMG BARCODE ENCODE', [MsgStr]); RPCBrokerV.ClearParameters := true; RPCBrokerV.remoteprocedure := 'TMG BARCODE ENCODE'; RPCBrokerV.param[0].Value := MsgStr; RPCBrokerV.param[0].PType := literal; RPCBrokerV.Param[1].Value := '.X'; //<-- is this needed or used? RPCBrokerV.Param[1].PType := list; RPCBrokerV.Param[1].Mult['"IMAGE TYPE"'] := ImageType; //RPCBrokerV.Call; CallBroker; Application.ProcessMessages; //Note:RPCBrokerV.Results[0]=1 if successful load, =0 if failure if (RPCBrokerV.Results.Count>0) and (RPCBrokerV.Results[0]='1') then begin OutFile := TFileStream.Create(LocalSaveFNamePath,fmCreate); for i:=1 to (RPCBrokerV.Results.Count-1) do begin s :=Decode(RPCBrokerV.Results[i]); count := Length(s); if count>1024 then begin Result := ''; //failure of load. break; end; for j := 1 to count do Buffer[j-1] := ord(s[j]); OutFile.Write(Buffer,count); end; OutFile.Free; end else begin result := ''; end; StatusText(''); end; function TfrmImages.DecodeBarcode(LocalFNamePath,ImageType: AnsiString): AnsiString; //Decode data from barcode on image, or return '' if none //Note: if I could find a cost-effective way of decoding this on client side, // then that code be done here in the function, instead of uploading image // to the server for decoding. const RefreshInterval = 500; BlockSize = 512; var ReadCount : Word; ParamIndex : LongWord; j : word; InFile : TFileStream; Buffer : array[0..1024] of byte; RefreshCountdown : integer; OneLine : AnsiString; RPCResult : AnsiString; SavedCursor : TCursor; totalReadCount : integer; begin result := ''; //default of failure if not FileExists(LocalFNamePath) then exit; try InFile := TFileStream.Create(LocalFNamePath,fmOpenRead or fmShareCompat); //Note: I may well cut this out. Most of the delay occurs during // the RPC call, and I can't make a progress bar change during that... // (or I could, but I'm not going to change the RPC broker...) ImageTransferForm.setMax(InFile.Size); //ImageTransferForm.ResetStartTime; ImageTransferForm.ProgressMsg.Caption := 'Preparing to upload...'; ImageTransferForm.Show; totalReadCount := 0; except // catch failure here... on eError... exit; end; StatusText('Checking image for barcodes...'); Application.ProcessMessages; RPCBrokerV.ClearParameters := true; RPCBrokerV.Param.Clear; RPCBrokerV.Param[0].PType := list; ParamIndex := 0; RefreshCountdown := RefreshInterval; //Put image data into parameter 0 (ARRAY parameter of RPC on server side) repeat ReadCount := InFile.Read(Buffer,BlockSize); OneLine := ''; totalReadCount := totalReadCount + ReadCount; ImageTransferForm.updateProgress(totalReadCount); if ReadCount > 0 then begin SetLength(OneLine,ReadCount); for j := 1 to ReadCount do OneLine[j] := char(Buffer[j-1]); RPCBrokerV.Param[0].Mult[IntToStr(ParamIndex)] := Encode(OneLine); Inc(ParamIndex); Dec(RefreshCountdown); if RefreshCountdown < 1 then begin Application.ProcessMessages; RefreshCountdown := RefreshInterval; end; end; until (ReadCount < BlockSize); RPCBrokerV.Param[1].PType := literal; RPCBrokerV.Param[1].Value := ImageType; RPCBrokerV.remoteprocedure := 'TMG BARCODE DECODE'; SavedCursor := Screen.Cursor; Screen.Cursor := crHourGlass; ImageTransferForm.ProgressMsg.Caption := 'Uploading file to server...'; Application.ProcessMessages; CallBroker; //this is the slow step, pass to server and get response. Screen.Cursor := SavedCursor; ImageTransferForm.Hide; //Get result: 1^DecodedMessage, or 0^Error Message RPCResult := RPCBrokerV.Results[0]; if Piece(RPCResult,'^',1)='0' then begin MessageDlg(Piece(RPCResult,'^',2),mtError,[mbOK],0); end else begin result := Piece(RPCResult,'^',2); end; InFile.Free; StatusText(''); end; procedure TfrmImages.EnableAutoScanUploadClick(Sender: TObject); begin inherited; AutoScanUpload.Checked := not AutoScanUpload.Checked; uTMGOptions.WriteBool('Scan Enabled',AutoScanUpload.Checked); end; procedure TfrmImages.PickScanFolderClick(Sender: TObject); var CurScanDir : string; begin inherited; CurScanDir := UploadForm.ScanDir; OpenDialog.InitialDir := CurScanDir; MessageDlg('Please pick ANY file in the desired directory.',mtInformation,[mbOK],0); if OpenDialog.Execute then begin UploadForm.SetScanDir(ExtractFilePath(OpenDialog.FileName)); end; AutoScanUpload.Checked := true; end; function TfrmImages.FileSize(fileName : wideString) : Int64; var sr : TSearchRec; begin if FindFirst(fileName, faAnyFile, sr ) = 0 then result := Int64(sr.FindData.nFileSizeHigh) shl Int64(32) + Int64(sr.FindData.nFileSizeLow) else result := -1; FindClose(sr) ; end; function TfrmImages.GetImagesCount : integer; //Returns number of images possible, not just those already downloaded. begin EnsureImageListLoaded(); Result := NumImagesAvailableOnServer; end; function TfrmImages.GetImageInfo(Index : integer) : TImageInfo; begin if (Index > -1) and (Index < ImageInfoList.Count) then begin Result := TImageInfo(ImageInfoList[Index]); end else begin Result := nil; end; end; procedure TfrmImages.TabControlMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); //kt add 7/6/10 var TabIndex : integer; P : TPoint; begin inherited; if Button <> mbRight then exit; TabIndex := TabControl.IndexOfTabAt(X,Y); if TabIndex < 0 then exit; FDeleteImageIndex := TabIndex; P.X := X; P.Y := Y; P := TabControl.ClientToScreen(P); TabControl.PopupMenu := mnuPopup; mnuPopup.Popup(P.X, P.Y); TabControl.PopupMenu := nil; end; procedure TfrmImages.mnuPopupPopup(Sender: TObject); //Determine here if delete option should be enabled. begin inherited; mnuPopDeleteImage.Enabled := CanDeleteImages; end; function TfrmImages.CanDeleteImages : boolean; //Determine here if image can be deleted. var ActionSts: TActionRec; const ATTACHED_IMAGES_SERVER_REPLY = 'You must "delete" the Images using the Imaging package before proceeding.'; begin FImageDeleteMode := idmNone; Result := false; //default action if FEditIsActive then begin Result := true; FImageDeleteMode := idmDelete; exit; end; //Will use same user class managment rules for images as for notes. //So if user can delete a note, then they can also delete images. ActOnDocument(ActionSts, frmNotes.lstNotes.ItemIEN, 'DELETE RECORD'); if (ActionSts.Success = false) then begin if Pos(ATTACHED_IMAGES_SERVER_REPLY, ActionSts.Reason) > 0 then ActionSts.Success := true; end; Result := ActionSts.Success; if Result then begin if AuthorSignedDocument(frmNotes.lstNotes.ItemIEN) then FImageDeleteMode := idmRetract else FImageDeleteMode := idmDelete; end; end; procedure TfrmImages.mnuPopDeleteImageClick(Sender: TObject); begin inherited; DeleteImageIndex(FDeleteImageIndex, FImageDeleteMode, True); end; procedure TfrmImages.DeleteAll(DeleteMode: TImgDelMode); begin EnsureALLImagesDownloaded; while TabControl.Tabs.Count > 0 do begin DeleteImageIndex(0,DeleteMode,False); NewNoteSelected(False); EnsureALLImagesDownloaded; frmImages.Formshow(self); end; end; procedure TfrmImages.DeleteImageIndex(ImageIndex : integer; DeleteMode : TImgDelMode; boolPromptUser: boolean); //Note: permissions must be checked before running this function var ImageInfo : TImageInfo; ReasonForDelete : string; DeleteSts : TActionRec; CONST TMG_PRIVACY = 'FOR PRIVACY'; //Server message (don't translate) TMG_ADMIN = 'ADMINISTRATIVE'; //Server message (don't translate) begin if (ImageIndex<0) or (ImageIndex>=ImagesCount) then begin MessageDlg('Invalid image index to delete: '+IntToStr(ImageIndex), mtError,[mbOK],0); exit; end; ImageInfo := Self.ImageInfo[ImageIndex]; if boolPromptUser then begin ReasonForDelete := SelectDeleteReason(frmNotes.lstNotes.ItemIEN); if ReasonForDelete = DR_CANCEL then Exit; if ReasonForDelete = DR_PRIVACY then begin ReasonForDelete := TMG_PRIVACY; end else if ReasonForDelete = DR_ADMIN then begin ReasonForDelete := TMG_ADMIN; end; end else begin ReasonForDelete := 'DeleteAll'; end; DeleteImage(DeleteSts, ImageInfo.ServerFName, ImageInfo.IEN, frmNotes.lstNotes.ItemIEN, DeleteMode, ReasonForDelete); end; procedure TfrmImages.DeleteImage(var DeleteSts: TActionRec; ImageFileName: String; ImageIEN, DocIEN: Integer; DeleteMode : TImgDelMode; const Reason: string); //Reason should be 10-60 chars; function ServerImageDelete(ImageIEN:integer; DeleteMode:tImgDelMode; Reason:String) : boolean; //Returns success var RPCResult,IEN,Mode : string; begin IEN := IntToStr(ImageIEN); Mode := IntToStr(Ord(DeleteMode)); RPCResult := sCallV('TMG IMAGE DELETE', [IEN,Mode,Reason]); Result := Piece(RPCResult,'^',1)= '1'; if Result = false then begin MessageDlg(Piece(RPCResult,'^',2),mtError,[mbOK],0); end; end; procedure NoteImageDelete(DocIEN:integer; FileName: string; DeleteMode:tImgDelMode; Reason:String); var NoteText, tempString: string; Beginning, Ending: integer; boolFound: boolean; // // FEditIsActive begin if FEditIsActive then begin Ending := 1; Beginning := 1; boolFound := False; While (boolFound = False) AND (Beginning > 0) Do Begin NoteText := frmNotes.HtmlEditor.HTMLText; Beginning := PosEx('', NoteText, Beginning) + 1; tempString := MidStr(NoteText, Beginning, Ending-Beginning); if pos(FileName,tempString) > 0 then boolFound := True; end; if boolFound = false then begin Ending := 1; Beginning := 1; boolFound := False; While (boolFound = False) AND (Beginning > 0) Do Begin NoteText := frmNotes.HtmlEditor.HTMLText; Beginning := PosEx('', NoteText, Beginning) + 1; tempString := MidStr(NoteText, Beginning, Ending-Beginning); if pos(FileName,tempString) > 0 then boolFound := True; end; end; if boolFound = False then exit; if DeleteMode = idmDelete then begin frmnotes.HtmlEditor.HTMLText := AnsiReplaceStr(frmNotes.HtmlEditor.HTMLText, tempString, ''); end else if DeleteMode = idmRetract then begin frmnotes.HtmlEditor.HTMLText := AnsiReplaceStr(frmNotes.HtmlEditor.HTMLText, tempString, '