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 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; 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; 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); private ImageInfoList : TList; LastDisplayedTIUIEN : AnsiString; CurImageToLoad : integer; InTimerFn : Boolean; DropBoxDir : string; UseDropBox : boolean; 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; public CacheDir : AnsiString; NullImageName : AnsiString; 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; published end; 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 {//KT added 1-1-05}, mshtml, {//kt added 5-2-05} UploadImages, {//kt added 9/25/05} //ImageTransferForm, {//kt 10-1-05} uTMGOptions, //kt 3/10/10 rHTMLTools, fNotes, frmImageTransferProgress; {//kt added 5-27-05 for IsHTMLDocument} procedure TfrmImages.timLoadImagesTimer(Sender: TObject); begin inherited; if InTimerFn=false then begin InTimerFn := true; EnsureImageListLoaded(); //only does RPC call if CurImageToLoad = 0 if CurImageToLoad <> -1 then begin //-1 means RPC-> no avail images. if CurImageToLoad < ImageInfoList.Count then begin ImageTransferForm.ProgressMsg.Caption := 'Downloading Images'; //if ImageTransferForm.Visible = false then begin // ImageTransferForm.Show; //end; DownloadToCache(CurImageToLoad); //Only load 1 image per timer firing. SetupTab(CurImageToLoad); Inc(CurImageToLoad); if TabControl.TabIndex < 0 then TabControl.TabIndex := 0; TabControlChange(self); end else begin timLoadImages.Enabled := false; //ImageTransferForm.ProgressBar.Position := 100; //Sleep(1000); //ImageTransferForm.Hide; end; end; InTimerFn := false; if self.Visible = true then begin timLoadImages.Interval :=100; end else begin timLoadImages.Interval :=30000; //30 sec delay end; 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.FormCreate(Sender: TObject); //var i : integer; begin inherited; InTimerFn:=false; LastDisplayedTIUIEN := '0'; ImageInfoList := TList.Create; CurImageToLoad := 0; CacheDir := ExtractFilePath(ParamStr(0))+ 'Cache'; NullImageName := ExtractFilePath(ParamStr(0)) + 'images\blank.htm'; if not DirectoryExists(CacheDir) then ForceDirectories(CacheDir); UseDropBox := uTMGOptions.ReadBool('Use dropbox directory for transfers',false); 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; TIUIEN := IntToStr(frmNotes.lstNotes.ItemID); timLoadImages.Enabled := true; timLoadImages.Interval := 100; if LastDisplayedTIUIEN <> TIUIEN then begin UpdateNoteInfoMemo(); LastDisplayedTIUIEN := TIUIEN; end; 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; Bitmap.Free; end else begin Ext := LowerCase(ExtractFileExt(Rec.CacheFName)); 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 TImageInfo(ImageInfoList[i]).TabImageIndex := 0; //camera image end else if (Ext='pdf') then begin TImageInfo(ImageInfoList[i]).TabImageIndex := 1; //adobe icon end else if (Ext='avi') or (Ext='qt') or (Ext='mpg') or (Ext='mpeg') then begin TImageInfo(ImageInfoList[i]).TabImageIndex := 2; //video icon end else if (Ext='mp3') or (Ext='wma') or (Ext='au') or (Ext='wav') then begin TImageInfo(ImageInfoList[i]).TabImageIndex := 3; //sound icon end else begin TImageInfo(ImageInfoList[i]).TabImageIndex := 4; // misc icon end; end; end; TabControl.Tabs.Add(' '); //add the tab. Thumbnail should exist before this end; end; procedure TfrmImages.ClearTabPages(); begin TabControl.Tabs.Clear; ClearImageList(); end; procedure TfrmImages.ClearImageList(); //Note: !! This should also clear any visible images/thumbnails etc. 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; end; procedure TfrmImages.EnsureImageListLoaded(); begin if CurImageToLoad = 0 then begin GetImageList(); if ImageInfoList.Count=0 then CurImageToLoad := -1; end; end; procedure TfrmImages.GetImageList(); 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; //----MOVED 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; //----END MOVED StatusText(''); 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', ...); 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 RPCBrokerV.Call; //Move file into dropbox. Result := (Piece(RPCBrokerV.Results[0],'^',1)='1'); //1=success, 0=failure 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 Result := UploadFileViaDropBox(LocalFNamePath,FPath,FName,CurrentImage,TotalImages); exit; end; 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.ResetStartTime; 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.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 := '1'; //Note: the '1' in the line above is hard-coding in to use //IEN=1 in file 2005.2 (NETWORK LOCATION). This file will //instruct the server which relative path to store the file into //If I want to have more than one NETWORK LOCATION, then I would //need to create another RPC call that would determine which IEN //to use. //(This would be the same as the IEN stored in fields# 2, 2.1, 2.2 // of file 2005 (IMAGE). This in turn is originally obtained from //file IMAGING SITE PARAMETERS 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); RPCBrokerV.remoteprocedure := 'TMG UPLOAD FILE'; SavedCursor := Screen.Cursor; Screen.Cursor := crHourGlass; ImageTransferForm.ProgressMsg.Caption := 'Uploading file to server...'; Application.ProcessMessages; CallBroker; Screen.Cursor := SavedCursor; RPCResult := RPCBrokerV.Results[0]; 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; begin // CallV('TMG DOWNLOAD FILE 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 RPCBrokerV.Call; //Move file into dropbox. Result := (Piece(RPCBrokerV.Results[0],'^',1)='1'); //1=success, 0=failure CurrentFileSize := strtoint(Piece(RPCBrokerV.Results[0],'^',3)); //Piece 3 = file size if Result=true then begin 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; 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 UseDropBox then begin Result := DownloadFileViaDropBox(FPath,FName,LocalSaveFNamePath,CurrentImage,TotalImages); exit; end; Result := true; //default to success; StatusText('Retrieving full image...'); //Note: the '1' in the line below is hard-coding in to use //IEN=1 in file 2005.2 (NETWORK LOCATION). This file will //instruct the server which relative path to store the file into //If I want to have more than one NETWORK LOCATION, then I would //need to create another RPC call that would determine which IEN //to use. //(This would be the same as the IEN stored in fields# 2, 2.1, 2.2 // of file 2005 (IMAGE). This in turn is originally obtained from //file IMAGING SITE PARAMETERS CallV('TMG DOWNLOAD FILE', [FPath,FName,'1']); 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(); CurImageToLoad := 0; //a -1 would signal that no images avail to load. //this will start downloading images after 5 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. timLoadImages.Enabled := true; timLoadImages.Interval := 60000; //60 sec delay -- also set in timLoadImagesTimer //Note: OnTimer calls timLoadImagesTimer() 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 := 100; 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; // 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; 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; initialization //put init code here finalization //put finalization code here end.