ImagerUnit
From VistApedia
ImagerUnit
This page uses the Historical meaning of the term "OpenVistA" VistA Trademark Issues
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
