home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
p
/
previe.zip
/
PREVIEW.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-07-01
|
14KB
|
495 lines
{Preview - 1.0 Program Copyright (C) Doug Overmyer 7/1/91}
program FList;
{$S-}
{$R PREVIEW.RES}
uses WinTypes, WinProcs, WinDos, Strings, WObjects,StdDlgs;
const
id_But1 = 201;
id_But2 = 202;
id_But3 = 203;
id_But4 = 204;
id_Lb1 = 301;
id_lb2 = 302;
id_St1 = 401;
id_St2 = 402;
id_St3 = 403;
id_St4 = 404;
{******************************************************************}
{ Types }
{******************************************************************}
type
TPVApplication = object(TApplication)
procedure InitMainWindow;virtual;
end;
PPVDialog = ^TPVDialog;
TPVDialog = object(TDialog)
FontSize: Integer;
procedure WMInitDialog(var Msg:TMessage);virtual wm_First+wm_InitDialog;
procedure IDLb1(var Msg:TMessage);virtual id_First+id_Lb1;
end;
type {convert TLogFont records to objects}
PFontItem = ^TFontItem;
TFontItem = object(TObject)
LogFont:TLogFont;
constructor Init(NewItem:TLogFont);
destructor Done;virtual;
end;
PFontCollection = ^TFontCollection;
TFontCollection = object(TSortedCollection)
function KeyOf(Item:Pointer):Pointer;virtual;
function Compare(Key1,Key2:Pointer):Integer;virtual;
end;
var
Fonts:PFontCollection; {Global collection of PFontItem to for call-back func}
type {Child win to display sample text}
PFontWindow = ^TFontWindow;
TFontWindow = object(TWindow)
FontsHeight: LongInt;
constructor Init(AParent: PWindowsObject; ATitle: PChar);
procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
procedure Destroy; virtual;
procedure WMSize(var Msg: TMessage);
virtual wm_First + wm_Size;
end;
type {MainWindow of Application}
PPVWindow = ^TPVWindow;
TPVWindow = object(TWindow)
FWin:PFontWindow;
FBox:PListBox;
TheIcon:HIcon;
TheButton,TheLogo:HBitmap;{button = About button}
Bn1,Bn2,Bn3,Bn4 : PButton;
Dlg1 : PPVDialog; {Select font size dialog}
St1,St2,St3,St4:PStatic;
TextString:Array[0..50] of Char; {to display in FWin}
FontSelection:Integer; {Index into Fonts collection}
FontSize:Integer; {Current font size desired}
constructor Init(AParent:PWindowsObject;ATitle:PChar);
destructor Done;virtual;
procedure SetupWindow;virtual;
procedure Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);virtual;
procedure LoadFBox;
procedure WMSize(var Msg:TMessage);virtual wm_First+wm_Size;
procedure WMSetFocus(var Msg:TMessage);virtual wm_First+wm_SetFocus;
procedure IDBut1(var Msg:TMessage);virtual id_First+id_But1; {Drive}
procedure IDBut2(var Msg:TMessage);virtual id_First+id_But2; {Clipboard}
procedure IDBut3(var Msg:TMessage);virtual id_First+id_But3; {not used}
procedure IDBut4(var Msg:TMessage);virtual id_First+id_But4; {Exit}
procedure IDLB2(var Msg:TMessage);virtual id_First+id_lb2;
procedure WMLButtonUp(var Msg:TMessage);virtual wm_First+wm_LButtonUp;
procedure EnumerateFonts;virtual;
function GetFontSelection:Integer;virtual;
function GetFontSize:Integer;virtual;
function GetTextString:PChar;virtual;
procedure SetFontSize(NewfontSize:Integer);virtual;
end;
{********************************************************************}
{M E T H O D S }
{********************************************************************}
procedure TPVApplication.InitMainWindow;
begin
MainWindow := New(PPVWindow,Init(nil,'Preview'));
end;
{********************************************************************}
{Init}
constructor TPVWindow.Init(AParent:PWindowsObject;ATitle:PChar);
begin
TWindow.Init(AParent,ATitle);
Attr.Menu := 0;
Attr.X := 20; Attr.Y := 25; Attr.W := 595; Attr.H := 325;
Fonts := New(PFontCollection,Init(100,100));
Fonts^.Duplicates := True;
EnumerateFonts;
FWin := New(PFontWindow,Init(@Self,ATitle));
with FWin^.Attr do
Style := Style or ws_Child or ws_HScroll or ws_VScroll or ws_Border ;
FBox := New(PListBox,Init(@Self,id_lb2,0,0,0,0));
with FBox^.Attr do
begin
Style := Style and not lbs_Sort ;
end;
Bn1 := New(PButton,Init(@Self,id_But1,'Font Size',0,0,0,0,False));
Bn2 := New(PButton,Init(@Self,id_But2,'String',0,0,0,0,False));
Bn3 := New(PButton,Init(@Self,id_But3,'File',0,0,0,0,False));
Bn4 := New(PButton,Init(@Self,id_But4,'Exit',0,0,0,0,False));
St1 := New(PStatic,Init(@Self,id_St1,'',315,5,240,18,75));
St2 := New(PStatic,Init(@Self,id_St2,'',315,26,240,18,75));
St3 := New(PStatic,Init(@Self,id_ST3,'',310,3,250,44,75));
St4 := New(PStatic,Init(@Self,id_St4,'',5,55,100,18,75));
TheButton := LoadBitmap(HInstance,'PV_BUTTON');
TheLogo := LoadBitmap(HInstance,'PV_BMP');
St2^.Attr.Style := St2^.Attr.Style or ss_LeftNoWordWrap;
St3^.Attr.Style := St3^.Attr.Style or ss_BlackFrame;
St4^.Attr.Style := St4^.Attr.Style or ss_Left;
FontSelection := 0;
FontSize := 48;
StrCopy(TextString,'');
end;
{SetupWindow}
procedure TPVWindow.SetupWindow;
begin
TWindow.SetupWindow;
SetClassWord(HWindow,GCW_HIcon,LoadIcon(HInstance,'PV_Icon'));
LoadFBox;
end;
{Paint}
procedure TPVWindow.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
var
ThePen:HPen;
TheBrush :HBrush;
OldBrush :HBrush;
OldPen:HPen;
OldBitMap:HBitMap;
MemDC :HDC;
CR:TRect;
W,H:Integer;
BMRec:TBitMap;
begin
TheBrush := GetStockObject(LtGray_Brush);
ThePen := CreatePen(ps_Solid,1,$00000000);
OldPen := SelectObject(PaintDC,ThePen);
OldBrush := SelectObject(PaintDC,TheBrush);
Rectangle(PaintDC,0,0,1024,50);
SelectObject(PaintDC,OldBrush);
SelectObject(PaintDC,OldPen);
DeleteObject(ThePen);
MemDC := CreateCompatibleDC(PaintDC);
OldBitMap := SelectObject(MemDC,TheButton);
BitBlt(PaintDC,0,0,50,50,MemDC,0,0,SrcCopy);
SelectObject(MemDC,OldBitMap);
DeleteDC(MemDC);
GetObject(TheLogo,sizeOf(BMRec),@BMRec);;
GetClientRect(HWindow,CR);
W := CR.Right-CR.Left;H := CR.Bottom-CR.Top;
MemDC := CreateCompatibleDC(PaintDC);
OldBitMap := SelectObject(MemDC,TheLogo);
BitBlt(PaintDC,((W div 3) - BMRec.bmWidth) div 2,
50+ ((H -50) div 2)+ abs((((H -50) div 2)-BMRec.bmHeight)div 2) ,
W div 3,H div 2,
MemDC,0,0,SrcCopy);
SelectObject(MemDC,OldBitMap);
DeleteDC(MemDC);
end;
{Done}
destructor TPVWindow.Done;
begin
DeleteObject(TheButton);
DeleteObject(TheLogo);
TWindow.Done;
end;
{WMSize}
procedure TPVWindow.WMSize(var Msg:TMessage);
begin
SetWindowPos(FBox^.HWindow,0,-1,75,(Msg.LParamLo div 3)+1,
((Msg.LParamHi-75) div 2 - 0),swp_NoZOrder);
SetWindowPos(FWin^.HWindow,0,(Msg.LParamLo div 3)-1,49,
(Msg.LParamLo * 2 div 3)+1,(Msg.LParamHi-48),swp_NoZOrder);
SetWindowPos(Bn1^.HWindow,0,50,0,100,50,swp_NoZOrder);
SetWindowPos(Bn2^.HWindow,0,150,0,100,50,swp_NoZOrder);
{SetWindowPos(Bn3^.HWindow,0,200,0,50,50,swp_NoZOrder);}
SetWindowPos(Bn4^.HWindow,0,250,0,50,50,swp_NoZOrder);
end;
{WMSetFocus}
procedure TPVWindow.WMSetFocus(var Msg:TMessage);
begin
SetFocus(FBox^.HWindow);
end;
{IDBut1} {run font size dialog box}
procedure TPVWindow.IDBut1(var Msg:TMessage);
begin
Dlg1 := new(PPVDialog,Init(@Self,'PV_Dlg1'));
Application^.ExecDialog(Dlg1);
if (Dlg1^.FontSize) <> 0 then
InvalidateRect(Fwin^.HWindow,nil,True);
end;
{IDBut2} {run sample string dialog box}
procedure TPVWindow.IDBut2(var Msg:TMessage);
var
TotChars:Integer;
begin
If Application^.ExecDialog(New(PInputdialog,Init(@Self,'Font String',
'Enter text:',TextString,SizeOf(TextString)))) = id_OK then
else StrCopy(TextString,'');
end;
{IdBut3}{not used}
procedure TPVWindow.IDBut3(var Msg:TMessage);
begin
end;
{IdBut4} {exit}
procedure TPVWindow.IDBut4(var Msg:TMessage);
begin
SendMessage(HWindow,wm_Close,0,0);
end;
{WMLButtonDown} {hit test for bitmapped button}
procedure TPVWindow.WMLButtonUp(var Msg:TMessage);
var
Dlg : PDialog;
begin
if (Msg.lParamLo < 50) and (Msg.lParamHi < 50) then
begin
Dlg :=New(PDialog,Init(@Self,'PV_About'));
Application^.ExecDialog(Dlg);
end;
end;
procedure TPVWindow.LoadFBox;
var
Indx : Integer;
Font : PFontItem;
Buf1 :Array[0..20] of Char;
Buf2 :Array[0..5] of Char;
begin
Str(Fonts^.Count,Buf2);
StrECopy(StrECopy(StrECopy(Buf1,'*'),Buf2),' Fonts*');
St4^.SetText(Buf1);
for indx := 0 to (Fonts^.Count -1) do
begin
Font := Fonts^.At(indx);
FBox^.InsertString(Font^.LogFont.lfFaceName,-1);
end;
end;
procedure TPVWindow.IDLB2(var Msg:TMessage);
var
szBuffer:Array[0..80] of Char;
indx:Integer;
begin
case Msg.lParamHi of
lbn_DblClk, lbn_SelChange:
begin
indx := FBox^.GetSelIndex;
FontSelection := Indx;
InvalidateRect(FWin^.HWindow,nil,True);
Exit;
end;
end;
end;
function EnumerateFont(var LogFont: TLogFont; TextMetric: PTextMetric;
FontType: Integer; Data: PChar): Integer; export;
var
OldFont: HFont;
begin
Fonts^.Insert(New(PFontItem,Init(LogFont)));
EnumerateFont := 1;
end;
{ Collect all of the system fonts }
procedure TPVWindow.EnumerateFonts;
var
EnumProc: TFarProc;
TheDC :HDC;
begin
TheDC := GetDC(HWindow);
EnumProc := MakeProcInstance(@EnumerateFont, HInstance);
EnumFonts(TheDC, nil, EnumProc, nil);
ReleaseDC(HWindow, TheDC);
end;
function TPVWindow.GetFontSelection:Integer;
begin
GetFontSelection := FontSelection;
end;
function TPVWindow.GetFontSize:Integer;
begin
GetFontSize := FontSize;
end;
function TPVWindow.GetTextString:PChar;
begin
GetTextString := @TextString;
end;
procedure TPVWindow.SetFontSize(NewFontSize:Integer);
begin
FontSize := NewFontSize;
end;
{***********************************************************************}
{ Initialize object and collect font information }
constructor TFontWindow.Init(AParent: PWindowsObject; ATitle: PChar);
var
I: Integer;
function Max(I, J: LongInt): LongInt;
begin
if I > J then Max := I else Max := J;
end;
begin
TWindow.Init(AParent, ATitle);
Attr.Style := Attr.Style or ws_VScroll or ws_HScroll or ws_Border;
FontsHeight := 0;
Scroller := New(PScroller, Init(@Self, 12, 12,0,0));
end;
{ Draw each font name in it's font in the Display context. Each
line is incremented by the height of the font }
procedure TFontWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
var
I: Integer;
VPosition: Integer;
FontItem :PFontItem;
FontSel:Integer;
AFont:HFont;
OldFont:HFont;
Extent:LongRec;
Text:Array[0..80] of Char;
Buf:Array[0..80] of Char;
szFH:Array[0..4] of Char;
begin
FontItem := Fonts^.At(PPVWindow(Parent)^.GetFontSelection);
FontItem^.LogFont.lfHeight := PPVWindow(Parent)^.GetFontSize;
FontsHeight := PPVWindow(Parent)^.GetFontSize;
FontItem^.LogFont.lfWidth := 0;
FontItem^.LogFont.lfWeight := 0;
FontItem^.LogFont.lfQuality := Proof_Quality;
VPosition := 5;
if StrComp(PPVWindow(Parent)^.GetTextString,'') = 0
then StrCopy(Text,FontItem^.LogFont.lfFaceName)
else StrCopy(Text,PPVWindow(Parent)^.GetTextString);
AFont := CreateFontIndirect(FontItem^.LogFont);
OldFont := SelectObject(PaintDC, AFont);
LongInt(Extent) := GetTextExtent(PaintDC,Text,
StrLen(Text));
Scroller^.SetRange(Extent.lo div 12, Extent.Hi div 12);
TextOut(PaintDC, 10,VPosition, Text,
StrLen(Text));
StrCopy(Buf,'Face: ');
PPVWindow(Parent)^.St1^.SetText(StrCat(Buf,FontItem^.LogFont.lfFaceName));
Str(FontsHeight:3,szFH);
StrCat(StrCopy(Buf,'Size: '),szFH);
PPVWindow(Parent)^.St2^.SetText(Buf);
SelectObject(PaintDC,OldFont);
DeleteObject(AFont);
end;
procedure TFontWindow.Destroy;
var
I: Integer;
begin
TWindow.Destroy;
end;
procedure TFontWindow.WMSize(var Msg: TMessage);
begin
TWindow.WMSize(Msg);
{ if Scroller <> nil then
Scroller^.SetRange(FontsWidth div 12,
FontsHeight div 12); }
end;
{***********************************************************************}
constructor TFontItem.Init(NewItem:TLogFont);
begin
LogFont := NewItem;
end;
destructor TFontItem.Done;
begin
end;
{***********************************************************************}
function TFontCollection.KeyOf(Item:Pointer):Pointer;
var
Ptr :PChar;
begin
Ptr := PFontItem(Item)^.LogFont.lfFaceName;
KeyOf := Ptr;
end;
function TFontCollection.Compare(Key1,Key2:Pointer):Integer;
begin
Compare := StrIComp(PChar(Key1),PChar(Key2));
end;
{***********************************************************************}
procedure TPVDialog.IDLb1(var Msg:TMessage);
var
Idx : Integer;
Buf:Array[0..5] of Char;
Ptr : PChar;
ErrCode:Integer;
begin
case Msg.lParamHi of
lbn_SelChange,lbn_DblClk:
begin
Ptr := Buf;
Idx := SendDlgItemMsg(id_Lb1,lb_GetCurSel,0,0);
SendDlgItemMsg(id_Lb1,lb_GetText,word(Idx),LongInt(Ptr));
val(Ptr,FontSize,ErrCode);
PPVWindow(Parent)^.SetFontSize(FontSize);
EndDlg(Idx);
Exit;
end;
end;
end;
procedure TPVDialog.WMInitDialog(var Msg:TMessage);
var
TextItem:PChar;
Buf:Array[0..3] of Char;
Indx:Integer;
DSN,ErrCode :Integer;
begin
TDialog.WMInitDialog(Msg);
DosError := 0;
{$I-}
Indx := 12;
TextItem := Buf;
Str(Indx:2,Buf);
while Indx < 200 do
begin
SendDlgItemMsg(id_Lb1,lb_InsertString,word(-1),LongInt(TextItem));
Indx := Indx + 12;
Str(Indx:2,Buf);
end;
end;
{*********************************************************************}
{*** M A I N L I N E }
{*********************************************************************}
var
PVApp : TPVApplication;
begin
PVApp.Init('Preview');
PVApp.Run;
PVApp.Done;
end.