ImagerUnit
From VistApedia
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
