ImagerUnit

ImagerUnit

Here is the code for the main imager unit of the program. Below that is the code for the form itself (in text format)

unit ImagerUnit; interface uses\

 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,\
 Dialogs, StdCtrls, StrUtils, BrowserUnit, ExtCtrls, Menus, OleCtrls,\
 SHDocVw, ComCtrls, ToolWin;

type

 TImagerForm = class(TForm)
   PageControl: TPageControl;
   LogPage: TTabSheet;
   MsgMemo: TMemo;
   MainMenu: TMainMenu;
   File1: TMenuItem;
   Exit1: TMenuItem;
   ToolBar1: TToolBar;
   View1: TMenuItem;
   ShowLog1: TMenuItem;
   HideLog1: TMenuItem;
   procedure FormCreate(Sender: TObject);
   procedure HideButtonClick(Sender: TObject);
   procedure Button2Click(Sender: TObject);
   procedure Exit1Click(Sender: TObject);
   procedure FormDestroy(Sender: TObject);
   procedure FormResize(Sender: TObject);
   procedure FormClose(Sender: TObject; var Action: TCloseAction);
   procedure HideLog1Click(Sender: TObject);
   procedure ShowLog1Click(Sender: TObject);
 private
   { Private declarations }
   FVistaMsg: Word;
   BrowserList : TStringList;
   Running : boolean;
   procedure DefaultHandler(var Message); override;
   procedure ShowImage (var Data : string);
   function GetBetween (var Text : String; OpenTag,CloseTag : string;
                        KeepTags : Boolean) : string;
   procedure CutStringInThree(var Text : AnsiString; p1, p2 : Integer; var s1,s2,s3 : AnsiString);
   procedure AddImage (var URL, Title : string);
   procedure ClearAllImages();
 public
   { Public declarations }
 end;

var

 ImagerForm: TImagerForm;

const

 cLog : string[5] = 'Log';

implementation {$R *.dfm}

 procedure TImagerForm.DefaultHandler(var Message);
 { adds check to the message handling for this form to get a registered message }
 var
   buf: array[0..255] of Char;
   Data : string;
   p1 : integer;
 const
   ImageSignal : string = '^IMAGE^';
   NewDocSignal : string = '^TIU';
   NewPatientSignal : string = 'XPT^CPRS';
   EndCPRSSignal : string = 'END^CPRS^';
 begin
   // do the default message handling
   inherited DefaultHandler(Message);
   // if the message is 'VistA Event - Clinical' and not posted from self...
   // wParam=Handle of message sender, lParam=entry in global atom table
   with TMessage(Message) do if (Msg = FVistaMsg) and (wParam <> Handle) then
   begin
     // retrieve the text pointed to by lParam into a buffer
     GlobalGetAtomName(lParam, buf, 255);
     Data := StrPas(buf);
     MsgMemo.Lines.Add(Data);
     p1 := Pos (ImageSignal,Data);
     if p1 > 0 then begin
       Data := MidStr(Data, p1 + Length(ImageSignal), Length(Data));
       ShowImage (Data);
     end else if (Pos (NewDocSignal, Data) > 0)
              or (Pos (NewPatientSignal, Data) > 0)then begin
       ClearAllImages;
     end else if (Pos (ENDCPRSSignal, Data) > 0) then begin
       Application.Terminate;
     end;
   end;
 end;
 procedure TImagerForm.FormClose(Sender: TObject; var Action: TCloseAction);
 begin
   ClearAllImages();
 end;
 procedure TImagerForm.FormCreate(Sender: TObject);
 begin
   // register the message with windows to get a unique message number
   FVistaMsg := RegisterWindowMessage('VistA Event - Clinical');
   MsgMemo.Lines.clear;
   BrowserList := TStringList.Create;
   BrowserList.AddObject(cLog,nil);
   Running := true;
 end;
 procedure TImagerForm.FormDestroy(Sender: TObject);
 begin
   ClearAllImages();
   If BrowserList <> nil then BrowserList.Free;
   Running := false;
 end;
 procedure TImagerForm.HideButtonClick(Sender: TObject);
 begin
   Visible := false;
 end;
 procedure TImagerForm.Button2Click(Sender: TObject);
 begin
   Application.Terminate;
 end;
 procedure TImagerForm.Exit1Click(Sender: TObject);
 begin
   Application.Terminate;
 end;
 procedure TImagerForm.FormResize(Sender: TObject);
 var
   i : integer;
   Page : TTabSheet;
 begin
   //Note: I was getting a FormResize event after form destroyed->error.  Avoid via Running...
   if (PageControl <> nil) and (BrowserList <> nil) and (Running = true) then begin
     Page := PageControl.ActivePage;
     for i := 0 to BrowserList.Count-1 do begin
       if BrowserList.Objects[i] <> nil then begin
         (BrowserList.Objects[i] as TWebBrowser).Height := Page.Height;
         (BrowserList.Objects[i] as TWebBrowser).Width := Page.Width;
       end;
     end;
   end;
 end;
 procedure TImagerForm.HideLog1Click(Sender: TObject);
 begin
   LogPage.Visible := false;
 end;
 procedure TImagerForm.ShowLog1Click(Sender: TObject);
 begin
   LogPage.Visible := true;
 end;
 
 procedure TImagerForm.CutStringInThree(var Text : AnsiString; p1, p2 : Integer;
                                   var s1,s2,s3 : AnsiString);
 {Purpose: Cut input string Text into 3 parts, with cut points given by p1 & p2.
           p1 points to first character to be in s2
           p2 points to last character to be in s2        }
 begin
   s1 := ; s2 := ;  s3 := ;
   if p1 > 1 then s1 := MidStr(Text, 1, p1-1);
   s2 := MidStr(Text, p1, p2-p1+1);
   s3 := MidStr(Text, p2+1, Length(Text)-p2);
 end;
 function TImagerForm.GetBetween (var Text : String; OpenTag,CloseTag : string;
                                   KeepTags : Boolean) : string;
 {Purpose: Gets text between Open and Close tags.  Removes any CR's or LF's
  Input: Text - the text to work on.  It IS changed as code is removed
         KeepTags - true if want tag return in result
                    false if tag not in result (still is removed from Text)
  Output: Text IS changed.
          Result=the code between the opening and closing tags
  Note: Both OpenTag and CloseTag MUST be present for anything to happen.
 }
 var
   p1,p2 : integer;
   s1,s2,s3 : AnsiString;
 begin
   Result := ; //default of no result.
   p1 := Pos(UpperCase(OpenTag), UpperCase(Text));
   if (p1 > 0) then begin
     p2 := PosEx(UpperCase(CloseTag),UpperCase(Text),p1+Length(OpenTag)) + Length(CloseTag) -1;
     if ((p2 > 0) and (p2 > p1)) then begin
       CutStringInThree (Text, p1,p2, s1,Result,s3);
       Text := s1+s3;
       //Now, remove any CR's or LF's
       repeat
         p1 := Pos (Chr(13),Result);
         if p1= 0 then p1 := Pos (Chr(10),Result);
         if (p1 > 0) then begin
           CutStringInThree (Result, p1,p1, s1,s2,s3);
           Result := s1+s3;
         end;
       until (p1=0);
       //Now cut off boundry tags if requested.
       if not KeepTags then begin
         p1 := Length(OpenTag) + 1;
         p2 := Length (Result) - Length (CloseTag);
         CutStringInThree (Result, p1,p2, s1,s2,s3);
         Result := s2;
       end;
     end;
   end;
 end;
 procedure TImagerForm.ShowImage (var Data : string);
 {expected input: data is expected in the following format:
       <img src="http://www.geocities.com/kdtop3/pic1.jpg" alt="Title 1">
 }
 var
   URL, Title : string;
 begin
   Data := GetBetween(Data,'<img ', '>', false);
   URL := GetBetween (Data, 'src="', '"', false);
   Title := GetBetween (Data, 'alt="', '"', false);
   if URL <>  then begin
     AddImage(URL, Title);
   end;
 end;
 procedure TImagerForm.AddImage (var URL, Title : string);
 var
   NewTabSheet : TTabSheet;
   Browser     : TWebBrowser;
   CaptionName : string;
 begin
   NewTabSheet := TTabSheet.Create(PageControl);
   NewTabSheet.PageControl := PageControl;
   if Title =  then Title := 'Image';
   CaptionName := IntToStr(PageControl.PageCount-1) + '. ' + Title;
   NewTabSheet.Caption := CaptionName;
   NewTabSheet.Align := alClient;
   PageControl.ActivePage := NewTabSheet;
   Browser := TWebBrowser.Create(self);
   Browser.ParentWindow := NewTabSheet.Handle;
   Browser.Align := alClient;
   Browser.Width := NewTabSheet.Width;
   Browser.Height := NewTabSheet.Height;
   BrowserList.AddObject(CaptionName,Browser);
   Browser.Navigate(URL);
   BringWindowToTop(ImagerForm.Handle);
 end;
 procedure TImagerForm.ClearAllImages();
 var
   i,j : integer;
   PageName : string;
   p : ^TObject;
   Browser : ^TWebBrowser;  //a pointer
 begin
   if (PageControl <> nil) and (BrowserList <> nil) then begin
     for i := 0 to PageControl.PageCount-1 do begin
       PageName := PageControl.Pages[i].Caption;
       if PageName <> cLog then begin
         for j := 0 to BrowserList.Count-1 do begin
           if BrowserList.Strings[j]=PageName then begin
             if BrowserList.Objects[i] <> nil then begin
               (BrowserList.Objects[i] as TWebBrowser).Free;
               break;
             end;
           end;
         end;
       end;
     end;
     i := BrowserList.Count-1;
     while i >= 0 do begin
       if PageControl.Pages[i].Caption <> cLog then begin
         If PageControl.Pages[i] <> nil then PageControl.Pages[i].Free;
         BrowserList.Delete(i);
       end;
       i := i - 1;
     end;
   end;
 end;

end.

---

---

This is the form associated with ImagerUnit (viewed as text)

---

object ImagerForm: TImagerForm

 Left = 223
 Top = 116
 Width = 701
 Height = 567
 Caption = 'OpenVistA CPRS Imager'
 Color = clBtnFace
 Font.Charset = DEFAULT_CHARSET
 Font.Color = clWindowText
 Font.Height = -11
 Font.Name = 'MS Sans Serif'
 Font.Style = []
 Menu = MainMenu
 OldCreateOrder = False
 Visible = True
 OnClose = FormClose
 OnCreate = FormCreate
 OnDestroy = FormDestroy
 OnResize = FormResize
 PixelsPerInch = 96
 TextHeight = 13
 object PageControl: TPageControl
   Left = 0
   Top = 29
   Width = 693
   Height = 484
   ActivePage = LogPage
   Align = alClient
   TabOrder = 0
   TabPosition = tpBottom
   object LogPage: TTabSheet
     Caption = 'Log'
     ImageIndex = 1
     object MsgMemo: TMemo
       Left = 0
       Top = 0
       Width = 685
       Height = 458
       Align = alClient
       ScrollBars = ssBoth
       TabOrder = 0
     end
   end
 end
 object ToolBar1: TToolBar
   Left = 0
   Top = 0
   Width = 693
   Height = 29
   Caption = 'ToolBar1'
   TabOrder = 1
 end
 object MainMenu: TMainMenu
   Left = 256
   Top = 192
   object File1: TMenuItem
     Caption = '&File'
     object Exit1: TMenuItem
       Caption = 'E&xit'
       OnClick = Exit1Click
     end
   end
   object View1: TMenuItem
     Caption = '&View'
     object ShowLog1: TMenuItem
       Caption = '&Show Log'
       OnClick = ShowLog1Click
     end
     object HideLog1: TMenuItem
       Caption = '&Hide Log'
       OnClick = HideLog1Click
     end
   end
 end

end

Edit Page - Page History - Printable View - Recent Changes - WikiHelp - SearchWiki Page last modified on June 11, 2004, at 05:05 PM