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; Panel1: TPanel; Splitter1: TSplitter; Splitter2: TSplitter; UploadImagesButton: TBitBtn; OpenPictureDialog: TOpenPictureDialog; ButtonPanel: TPanel; CurrentImageMemo: TMemo; MemosPanel: TPanel; UploadImagesMnuAction: TMenuItem; Panel2: TPanel; TabControl: TTabControl; WebBrowser: TWebBrowser; 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); private ImageInfoList : TList; LastDisplayedTIUIEN : AnsiString; CurImageToLoad : integer; InTimerFn : Boolean; procedure EnsureImageListLoaded(); procedure ClearImageList(); procedure DownloadToCache(ImageIndex : integer); procedure EmptyCache(); procedure ClearTabPages(); procedure SetupTab(i : integer); procedure UpdateNoteInfoMemo(); procedure UpdateImageInfoMemo(Rec: TImageInfo); public CacheDir : AnsiString; NullImageName : AnsiString; function Decode(input: AnsiString) : AnsiString; function Encode(input: AnsiString) : AnsiString; function DownloadFile(FPath,FName,LocalSaveFNamePath: AnsiString): boolean; function UploadFile(LocalFNamePath,FPath,FName: AnsiString): boolean; procedure SplitLinuxFilePath(FullPathName : AnsiString; var Path : AnsiString; var FName : AnsiString); procedure GetImageList(); procedure NewNoteSelected(EditIsActive : boolean); 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} UPloadProgress, {//kt 10-1-05} rHTMLTools, fNotes; {//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 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; 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); 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); 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; 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 Rec.Accessibility := piece(s,'^',12)[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; except //Error occurs after note is signed, and frmNotes.lstNotes.ItemID is "inaccessible" on E: Exception do exit; end; 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); end; ServerFName := Rec.ServerThumbFName; ServerPathName := Rec.ServerThumbPathName; if not FileExists(Rec.CacheThumbFName) then begin DownloadFile(ServerPathName,ServerFName,Rec.CacheThumbFName); 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.UploadFile(LocalFNamePath,FPath,FName: AnsiString): 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; 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...) UploadProgressForm.setMax(InFile.Size); //UploadProgressForm.ResetStartTime; UploadProgressForm.ProgressMsg.Caption := 'Prepairing to upload...'; UploadProgressForm.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; UploadProgressForm.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; UploadProgressForm.ProgressMsg.Caption := 'Uploading file to server...'; Application.ProcessMessages; CallBroker; Screen.Cursor := SavedCursor; RPCResult := RPCBrokerV.Results[0]; result := (Piece(RPCResult,'^',1)='1'); UploadProgressForm.Hide; if result=false then begin Application.MessageBox('Error uploading file','Error'); end; InFile.Free; LocalOutFile.Free; StatusText(''); end; function TfrmImages.DownloadFile(FPath,FName,LocalSaveFNamePath: AnsiString): 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; 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; initialization //put init code here finalization //put finalization code here end.