Category : Windows 3.X Files
Archive   : PRVW13.ZIP
Filename : PREVIEW.PAS

 
Output of file : PREVIEW.PAS contained in archive : PRVW13.ZIP

{Font Preview - 1.3 Program Copyright (C) Doug Overmyer 7/26/91}
program FList;

{$S-}
{$R PREVIEW.RES}
{$R-}
uses WinTypes, WinProcs, WinDos, Strings, WObjects,WOPlus,WFPlus,StdDlgs,
printer,pDevice;

const
id_OKPrt = 521; {OK button in Dlg3}
id_Ec1 = 506; {Edit control element in Dlg3}
id_But1 = 201; {User defined button 1}
id_But2 = 202; { " 2}
id_But3 = 203; { " 3}
id_But4 = 204; { " 3}
id_But5 = 205; { " 5}
id_Lb1 = 301; {List box control in Dlg1}
id_lb2 = 302; {id of FBox list box control}
id_Setup = 501; {Setup button in Dlg3}
id_St1 = 401; {Static text 1 }
id_St2 = 402; {Static text 2 }
id_St3 = 403; {Static text 3 }
id_St4 = 404; {Static text 4 }
idm_About = 801; {menu id for PV_About menu}
idm_RunCP = 802; {menu id for run control panel}
um_FilePrint = 802; {User defined message }

{******************************************************************}
{ Types }
{******************************************************************}
type
TPVApplication = object(TApplication)
procedure InitMainWindow;virtual;
end;

PPVDlg1 = ^TPVDlg1; {Font Sizes Dialog}
TPVDlg1 = 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;

PPVDlg2 = ^TPVDlg2; {String Dialog}
TPVDlg2 = object(TDialog)
DCType:Char;
procedure WMInitDialog(var Msg:TMessage);virtual wm_First+wm_InitDialog;
end;

PPVDlg3 = ^TPVDlg3;
TPVDlg3 = object(TDialog) {Print setup dialog}
PFontSize: Integer;
procedure WMInitDialog(var Msg:TMessage);virtual wm_First+wm_InitDialog;
procedure IDSetup(var Msg:TMessage);virtual id_First+id_Setup;
procedure IDOKPrt(var Msg:TMessage);virtual id_First+id_OKPrt;
procedure IDEc1(var Msg:TMessage);virtual id_First+id_Ec1;
end;


type {convert TLogFont records to objects}
PFontItem = ^TFontItem;
TFontItem = object(TObject)
LogFont:TLogFont;
FontType:Integer;
constructor Init(NewItem:TLogFont;NewType:Integer);
destructor Done;virtual;
end;

PFontCollection = ^TFontCollection; {Collection of printer TLOGFont recs}
TFontCollection = object(TSortedCollection)
function KeyOf(Item:Pointer):Pointer;virtual;
function Compare(Key1,Key2:Pointer):Integer;virtual;
function GetCount:Integer;virtual;
end;

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 {Printer object support for margins,fonts}
PPVPrinter = ^TPVPrinter;
TPVPrinter = object(tPrinter)
MarginL:Integer; {left horiz margin value in Pixels}
MarginT:Integer; {top vert margin value in Pixels}
MarginR:Integer; {right horiz margin value in Pixels}
MarginB:Integer; {bottom vert margin value in Pixels}
function Start(dName:pChar;hw:HWnd):Boolean;virtual;
procedure SetMarginL(NewMargin:Integer);virtual;
procedure SetMarginT(NewMargin:Integer);virtual;
procedure SetMarginR(NewMargin:Integer);virtual;
procedure SetMarginB(NewMargin:Integer);virtual;
function SetFont(NewFont:hFont):hFont;virtual;
function NewLine:Boolean; virtual;
function resetPos:Boolean;virtual;
function CheckNewPage:Boolean; virtual;
function Print(aStr:pChar):Boolean;virtual;
function prnDeviceMode(Wnd:HWnd):Integer;virtual;
end;

type {MainWindow of Application}
PPVWindow = ^TPVWindow;
TPVWindow = object(TWindow)
FWin:PFontWindow; {child window displaying typeface sample}
FBox:PListBox; {List box of available type faces}
TheIcon:HIcon;
Bn1,Bn2,Bn3,Bn4,Bn5 :PODButton;
Dlg1 : PPVDlg1; {Select font size dialog}
St1,St2,St3,St4:PStatic;
TextString:Array[0..80] of Char; {to display in FWin}
FontSelection:Integer; {Index into Faces collection}
FontSize:Integer; {Current font size desired for FWin}
PFontSize:Integer; {Current font size for printed text}
LogPixX,LogPixY:Integer; {LogPixelsX & Y for current Printer}
constructor Init(AParent:PWindowsObject;ATitle:PChar);
destructor Done;virtual;
procedure SetupWindow;virtual;
procedure Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);virtual;
procedure LoadFBox;
procedure WMDrawItem(var Msg:TMessage);virtual wm_First + wm_DrawItem;
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; {About}
procedure IDBut2(var Msg:TMessage);virtual id_First+id_But2; {Size}
procedure IDBut3(var Msg:TMessage);virtual id_First+id_But3; {String}
procedure IDBut4(var Msg:TMessage);virtual id_First+id_But4; {Text Metrics}
procedure IDBut5(var Msg:TMessage);virtual id_First+id_But5; {Exit}
procedure IDLB2(var Msg:TMessage);virtual id_First+id_lb2;
procedure EnumerateFaces;virtual;
procedure EnumerateSizes;virtual;
function GetFontSelection:Integer;virtual;
function GetFontSize:Integer;virtual;
function GetTextString:PChar;virtual;
function GetLogPixX:Integer;virtual;
function GetLogPixY:Integer;virtual;
procedure SetFontSize(NewfontSize:Integer);virtual;
procedure SetPFontSize(NewfontSize:Integer);virtual;
procedure UMFilePrint(var Msg:TMessage);virtual wm_User+um_FilePrint;
procedure WMSysCommand(var Msg:TMessage);virtual wm_First+wm_SysCommand;
end;


{********************************************************************}
{G L O B A L V A R I A B L E S }
{********************************************************************}
var
Faces:PFontCollection; {collection of PFontItem for call-back func}
Sizes:PCollection; {collection of stacks for call-back func}

{********************************************************************}
{M E T H O D S }
{********************************************************************}

procedure TPVApplication.InitMainWindow;
begin
MainWindow := New(PPVWindow,Init(nil,'Font Preview'));
end;

{********************************************************************}
{Init}
constructor TPVWindow.Init(AParent:PWindowsObject;ATitle:PChar);
begin
TWindow.Init(AParent,ATitle);
Attr.Menu := 0; {LoadMenu(HInstance,'PV_Menu');}
Attr.X := 20; Attr.Y := 25; Attr.W := 595; Attr.H := 260;
Bn1 := New(PODButton,Init(@Self,id_But1,'Font Size',0,0,50,50,False,'PV_Bn1'));
Bn2 := New(PODButton,Init(@Self,id_But2,'Font Size',50,0,50,50,False,'PV_Bn2'));
Bn3 := New(PODButton,Init(@Self,id_But3,'String',100,0,100,50,False,'PV_Bn3'));
Bn4 := New(PODButton,Init(@Self,id_But4,'String',200,0,50,50,False,'PV_Bn4'));
Bn5 := New(PODButton,Init(@Self,id_But5,'Exit',250,0,50,50,False,'PV_Bn5'));
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,140,18,75));
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;
LogPixY := 1;
FontSelection := 0;
FontSize := 48;
PFontsize := 14;
StrCopy(TextString,'');
Faces := New(PFontCollection,Init(100,100));
Faces^.Duplicates := False;
Sizes := New(PCollection,Init(10,10));
EnumerateFaces;
EnumerateSizes;
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;
end;

{SetupWindow}
procedure TPVWindow.SetupWindow;
var
SysMenu:hMenu;
begin
TWindow.SetupWindow;
SetClassWord(HWindow,GCW_HIcon,LoadIcon(HInstance,'PV_Icon'));
Sysmenu := GetSystemMenu(hWindow,false);
AppendMenu(SysMenu,MF_Separator,0,nil);
AppendMenu(SysMenu,0,idm_RunCP,'Run Control Panel');
AppendMenu(Sysmenu,0,idm_About,'About...');
LoadFBox;
end;

{Paint}
procedure TPVWindow.Paint(PaintDC:HDC;var PaintInfo:TPaintStruct);
var
ThePen:HPen;
TheBrush :HBrush;
OldBrush :HBrush;
OldPen:HPen;
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);
end;

{Route the Ownerdraw msgs to correct object}
procedure TPVWindow.WMDrawItem(var Msg:TMessage);
var
PDIS : ^TDrawItemStruct;
begin
PDIS := Pointer(Msg.lParam);
case PDIS^.CtlType of
odt_Button:
case PDIS^.CtlID of
id_But1 :Bn1^.DrawItem(Msg);
id_But2 :Bn2^.DrawItem(Msg);
id_But3 :Bn3^.DrawItem(Msg);
id_But4 :Bn4^.DrawItem(Msg);
id_But5 :Bn5^.DrawItem(Msg);
end;
end;
end;


{Done}
destructor TPVWindow.Done;
begin
Dispose(Sizes,Done);
TWindow.Done;
end;

{WMSize}
procedure TPVWindow.WMSize(var Msg:TMessage);
begin
SetWindowPos(FBox^.HWindow,0,-1,75,(Msg.LParamLo div 3)+1,
((Msg.LParamHi-70) ),swp_NoZOrder);
SetWindowPos(FWin^.HWindow,0,(Msg.LParamLo div 3)-1,49,

(Msg.LParamLo * 2 div 3)+1,(Msg.LParamHi-48),swp_NoZOrder);
end;

{WMSetFocus}
procedure TPVWindow.WMSetFocus(var Msg:TMessage);
begin
SetFocus(FBox^.HWindow);
end;

procedure TPVWindow.IDBut1(var Msg:TMessage);
var
Dlg : PDialog;
begin
Dlg :=New(PPVDlg3,Init(@Self,'PV_Dlg3'));
Application^.ExecDialog(Dlg);
end;

{IDBut2} {run font size dialog box}
procedure TPVWindow.IDBut2(var Msg:TMessage);
begin
Dlg1 := new(PPVDlg1,Init(@Self,'PV_Dlg1'));
Application^.ExecDialog(Dlg1);
if (Dlg1^.FontSize) <> 0 then
InvalidateRect(Fwin^.HWindow,nil,True);
end;

{IDBut3} {run sample string dialog box}
procedure TPVWindow.IDBut3(var Msg:TMessage);
var
TotChars:Integer;
begin
If Application^.ExecDialog(New(PInputdialog,Init(@Self,'Font String',
'Enter text:',TextString,SizeOf(TextString)))) = 1 then
else StrCopy(TextString,'');
InvalidateRect(FWin^.HWindow,nil,True);
end;

{IdBut4} {GetTextMetrics}
procedure TPVWindow.IDBut4(var Msg:TMessage);
var
Dlg : PPVDlg2;
begin
Dlg :=New(PPVDlg2,Init(@Self,'PV_Dlg2'));
Dlg^.DCType := 'S';
Application^.ExecDialog(Dlg);
Dlg :=New(PPVDlg2,Init(@Self,'PV_Dlg2'));
Dlg^.DCType := 'P';
Application^.ExecDialog(Dlg);
end;

{IdBut5} {exit}
procedure TPVWindow.IDBut5(var Msg:TMessage);
begin
SendMessage(HWindow,wm_Close,0,0);
end;


procedure TPVWindow.LoadFBox;
var
Indx : Integer;
Font : PFontItem;
Buf1 :Array[0..20] of Char;
Buf2 :Array[0..5] of Char;
begin
Str(Faces^.Getcount,Buf2);
StrECopy(StrECopy(StrECopy(Buf1,'*'),Buf2),' Type Faces*');
St4^.SetText(Buf1);
for indx := 0 to (Faces^.GetCount -1) do
begin
Font := Faces^.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 EnumerateFace(var LogFont: TLogFont; TextMetric: PTextMetric;
FontType: Integer; Data: PChar): Integer; export;
function DupF(Item:PFontItem):Boolean;far;
begin
DupF := (StrIComp(Item^.LogFont.lfFaceName, LogFont.lfFacename)= 0);
end;
var
OldFont: HFont;
Result:PFontItem;
begin
Result := Faces^.FirstThat(@DupF);
if Result = nil then Faces^.Insert(New(PFontItem,Init(LogFont,FontType)));
EnumerateFace := 1;
end;


function EnumerateSize(var LogFont: TLogFont; TextMetric: PTextMetric;
FontType: Integer; Data: PChar): Integer; export;
function DupS(Item:PStackInt):Boolean;far;
begin
DupS := (Item^.StackInt = LogFont.lfHeight);
end;
var
FHeight:Array[0..6] of Char;
PStk :PStack;
Result :PStackInt;
begin
PStk :=Sizes^.At(Sizes^.Count-1);
Result := PStk^.FirstThat(@DupS);
if Result = nil then PStk^.Push(New(PStackInt,Init(LogFont.lfHeight))) ;
EnumerateSize := 1;
end;


{ Collect all of faces of current system printer }
procedure TPVWindow.EnumerateFaces;
var
EnumProc: TFarProc;
ThePrinter:pPVPrinter;
begin
ThePrinter := New(pPVPrinter,Init(hInstance,@Self));
ThePrinter^.GetPrinterParms;
ThePrinter^.DCCreated;
EnumProc := MakeProcInstance(@EnumerateFace, HInstance);
EnumFonts(ThePrinter^.hPrintDC, nil, EnumProc,nil);
LogPixY := GetDeviceCaps(ThePrinter^.hPrintDC,LogPixelsY);
LogPixX := GetDeviceCaps(ThePrinter^.hPrintDC,LogPixelsX);
ThePrinter^.DeleteContext;
Dispose(ThePrinter,Done);
end;

{ Collect all of sizes for each face of current system printer }
procedure TPVWindow.EnumerateSizes;
var
EnumProc: TFarProc;
ThePrinter:pPVPrinter;
FontItem :PFontItem;
Indx : Integer;
begin
ThePrinter := New(pPVPrinter,Init(hInstance,@Self));
ThePrinter^.GetPrinterParms;
ThePrinter^.DCCreated;
EnumProc := MakeProcInstance(@EnumerateSize, HInstance);
for Indx := 0 to Faces^.Count -1 do
begin
FontItem := Faces^.At(Indx);
Sizes^.Insert(New(PStack,Init(10,10)));
EnumFonts(ThePrinter^.hPrintDC, FontItem^.LogFont.lfFaceName,
EnumProc,nil);
end;
ThePrinter^.DeleteContext;
Dispose(ThePrinter,Done);
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;

procedure TPVWindow.SetPFontSize(NewFontSize:Integer);
begin
PFontSize := NewFontSize;
end;

function TPVWindow.GetLogPixX:Integer;
begin
GetLogPixX := LogPixX;
end;


function TPVWindow.GetLogPixY:Integer;
begin
GetLogPixY := LogPixY;
end;


procedure TPVWindow.UMFilePrint(var Msg:TMessage);
var
aPtr : pPVPrinter;
indx : Integer;
FI : PFontItem;
OldFont,NewFont:hFont;
szSize:Array[0..7] of Char;
LogFont:TLogFont;
TM:TTextMetric;
Buf1:Array[0..60] of Char;
begin
aPtr := New(pPVPrinter,Init(hInstance,@Self));
indx := 0;
if aPtr^.Start('PreView',hWindow) then
begin
aPtr^.SetMarginB(LogPixY div 3);
aPtr^.SetMarginL(LogPixX+LogPixX); {Indent 2 inches}
aptr^.ResetPos;
StrECopy(StrECopy(Buf1,'Printer Font Samples: '),aPtr^.DeviceName);
aPtr^.printLine(Buf1);
aPtr^.SetMarginL(LogPixX); {Set margin = 1 inch}
aPtr^.NewLine;
for indx := 0 to (Faces^.GetCount-1) do
begin
FI := Faces^.At(Indx);
FI^.LogFont.lfHeight := PFontsize * LogPixY div 72;
FI^.LogFont.lfWidth := 0;
FI^.LogFont.lfWeight := fw_Normal;
FI^.LogFont.lfQuality := Proof_Quality;
NewFont := CreateFontIndirect(FI^.LogFont);
OldFont := aPtr^.SetFont(NewFont);
getTextMetrics(aPtr^.hPrintDC,TM);
Str(TM.tmHeight * 72 / LogPixY:3:0,szSize);
StrCat(StrCat(StrCopy(Buf1,FI^.LogFont.lfFaceName),szSize),
' ABCDEFG!@#$%^&* abcdefg()_+\<>? 123456789');
aPtr^.printLine(Buf1);
OldFont := aPtr^.SetFont(OldFont);
DeleteObject(NewFont);
end;
aPtr^.Finish;
Dispose(aPtr,Done);
end;
end;

procedure TPvWindow.WMSysCommand(var Msg:TMessage);
begin
case Msg.Wparam of
idm_About:Application^.ExecDialog(New(PDialog,Init(@Self,'PV_About')));
idm_RunCP:begin
WinExec('Control',1);
EnumerateFaces;
EnumerateSizes;
end;
else
DefWndProc(Msg);
end;
end;


{***********************************************************************}

{ Initialize object and collect font information }
constructor TFontWindow.Init(AParent: PWindowsObject; ATitle: PChar);

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 font name in Window & update static text}
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;
FH:Real;
szFH:Array[0..5] of Char;
LPY:Integer;
FontMetrics:TTextMetric;
begin {build text display}
LPY := GetDeviceCaps(PaintDC,LogPixelsY);
FontItem := Faces^.At(PPVWindow(Parent)^.GetFontSelection);
FontsHeight := PPVWindow(Parent)^.GetFontSize * LPY div 72;
FontItem^.LogFont.lfHeight := FontsHeight;
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);
GetTextMetrics(PaintDC,FontMetrics);
LongInt(Extent) := GetTextExtent(PaintDC,Text,
StrLen(Text));
Scroller^.SetRange(Extent.lo div 12, Extent.Hi div 12);
TextOut(PaintDC, 10,VPosition, Text,
StrLen(Text));
{Set static text}
StrCopy(Buf,'Face: ');
PPVWindow(Parent)^.St1^.SetText(StrCat(Buf,FontItem^.LogFont.lfFaceName));
FH :=(FontMetrics.tmHeight)*72 / LPY;
Str(FH:5:1,szFH);
StrECopy(StrECopy(Buf,'Actual :'),szFH);
if FontItem^.FontType and Raster_FontType = 0 then
StrCat(Buf,' Type:Vector,') else StrCat(Buf,' Type:Raster,');
if FontItem^.FontType and Device_FontType = 0 then
StrCat(Buf,'GDI') else StrCat(Buf,'Device');
PPVWindow(Parent)^.St2^.SetText(Buf);
SelectObject(PaintDC,OldFont);
DeleteObject(AFont);
end;

procedure TFontWindow.Destroy;
begin
TWindow.Destroy;
end;

procedure TFontWindow.WMSize(var Msg: TMessage);
begin
TWindow.WMSize(Msg);
end;

{***********************************************************************}
constructor TFontItem.Init(NewItem:TLogFont;NewType:Integer);
begin
LogFont := NewItem;
FontType := NewType;
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;

function TFontCollection.GetCount:Integer;
begin
GetCount := Count;
end;

{***********************************************************************}
procedure TPVDlg1.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 TPVDlg1.WMInitDialog(var Msg:TMessage);
var
pTextItem:PChar;
Buf:Array[0..5] of Char;
Indx:Integer;
DSN,ErrCode :Integer;
EnumProc:TFarProc;
TheDC:HDc;
FontItem:PFontItem;
Item:PStackInt;
Flag:PChar;
ThePrinter:pPVPrinter;
LPY : Integer;
PStk :PStack;
Height:Integer;
Indx2:Integer;
Res,Res2:Integer;
begin
TDialog.WMInitDialog(Msg);

FontItem := Faces^.At(PPVWindow(Parent)^.GetFontSelection);
PStk := Sizes^.At(PPVWindow(Parent)^.GetFontSelection);
Indx2 := 0;
Indx := 12;
pTextItem := Buf;

Res := FontItem^.FontType and Raster_FontType; {0 = vector font}
Res2 := FontItem^.FontType and Device_FontType; {0 = GDI font}
if Res = 0 then
begin
Str(Indx:3,Buf);
while Indx < 200 do
begin
SendDlgItemMsg(id_Lb1,lb_AddString,word(0),LongInt(pTextItem));
Indx := Indx + 12;
Str(Indx:3,Buf);
end;
end
else
for Indx2 := 0 to PStk^.Count-1 do
begin
Item := PStk^.At(Indx2);
Height := Item^.StackInt;
Str(Height * 72 div PPVWindow(Parent)^.GetLogPixY:3,Buf);
SendDlgItemMsg(id_Lb1,lb_AddString,word(0),LongInt(pTextItem));
end;
end;

{***********************************************************************}
procedure TPVDlg2.WMInitDialog(var Msg:TMessage);
const
FontFamily : Array[0..5,0..11] of Char = ('Don''t Care', ' Roman',
' Swiss',' Modern', ' Script', 'Decorative');
var
FontItem:PFontItem;
TextItem:PChar;
Buf:Array[0..3] of Char;
Buf60:Array[0..60] of Char;
FontMetrics:TTextMetric;
aPtr:pPVPrinter;
OldFont,NewFont:hFont;
LogFont:TLogFont;
DeviceName:Array[0..30] of Char;
ScreenDC:hDC;
begin
FontItem := Faces^.At(PPVWindow(Parent)^.GetFontSelection);
if DCType = 'P' then
begin
aPtr := New(pPVPrinter,Init(hInstance,@Self));
aPtr^.GetPrinterParms;
aPtr^.DCCreated;
StrCopy(DeviceName,aPtr^.DeviceName);
FontItem^.LogFont.lfHeight := PPVWindow(Parent)^.GetFontSize *
GetDeviceCaps(aPtr^.hPrintDC,LogPixelsY) div 72;
FontItem^.LogFont.lfQuality := Proof_Quality;
FontItem^.LogFont.lfWeight := fw_Normal;
NewFont := CreateFontIndirect(FontItem^.LogFont);
OldFont := aPtr^.SetFont(NewFont);
GetTextMetrics(aPtr^.hPrintDC,FontMetrics);
aPtr^.SetFont(OldFont);
DeleteObject(NewFont);
aPtr^.DeleteContext;
Dispose(aPtr,Done);
end
else
begin
StrCopy(DeviceName,'Screen Display');
ScreenDC :=GetDC(PPVWindow(Parent)^.HWindow);
FontItem^.LogFont.lfHeight := PPVWindow(Parent)^.GetFontSize *
GetDeviceCaps(ScreenDC,LogPixelsY) div 72;
FontItem^.LogFont.lfQuality := Proof_Quality;
FontItem^.LogFont.lfWeight := fw_Normal;
NewFont := CreateFontIndirect(FontItem^.LogFont);
OldFont := SelectObject(ScreenDC,Newfont);
GetTextMetrics(ScreenDC,FontMetrics);
SelectObject(ScreenDC,OldFont);
DeleteObject(NewFont);
ReleaseDC(PPVWindow(Parent)^.HWindow,ScreenDC);
end;

TDialog.WMInitDialog(Msg);
StrECopy(StrECopy(StrECopy(Buf60,FontItem^.LogFont.lfFaceName),' - '),DeviceName);
SetDlgItemText(HWindow,601,Buf60);

Str(FontMetrics.tmHeight:3,Buf); SetDlgItemText(HWindow,612,Buf);
Str(FontMetrics.tmAscent:3,Buf); SetDlgItemText(HWindow,613,Buf);
Str(FontMetrics.tmDescent:3,Buf); SetDlgItemText(HWindow,614,Buf);
Str(FontMetrics.tmInternalLeading:3,Buf); SetDlgItemText(HWindow,615,Buf);
Str(FontMetrics.tmExternalLeading:3,Buf); SetDlgItemText(HWindow,616,Buf);
Str(FontMetrics.tmAveCharWidth:3,Buf); SetDlgItemText(HWindow,617,Buf);
Str(FontMetrics.tmMaxCharWidth:3,Buf); SetDlgItemText(HWindow,618,Buf);

Str(FontMetrics.tmWeight:3,Buf); SetDlgItemText(HWindow,619,Buf);
Str(FontMetrics.tmItalic:3,Buf); SetDlgItemText(HWindow,620,Buf);
Str(FontMetrics.tmUnderlined:3,Buf); SetDlgItemText(HWindow,621,Buf);

Str(FontMetrics.tmStruckOut:3,Buf); SetDlgItemText(HWindow,632,Buf);
Str(FontMetrics.tmFirstChar:3,Buf); SetDlgItemText(HWindow,633,Buf);
Str(FontMetrics.tmLastChar:3,Buf); SetDlgItemText(HWindow,634,Buf);
Str(FontMetrics.tmDefaultChar:3,Buf); SetDlgItemText(HWindow,635,Buf);
if FontMetrics.tmPitchandFamily and 1 > 0 then SetDlgItemText(HWindow,636,'Variable')
else SetDlgItemText(HWindow,636,'Fixed');
SetDlgItemText(HWindow,637,FontFamily[FontMetrics.tmPitchAndFamily shr 4] );
if FontMetrics.tmCharSet = ANSI_CharSet then SetDlgItemText(HWindow,638,'Ansi')
else if FontMetrics.tmCharSet = OEM_CharSet then SetDlgItemText(HWindow,638,'OEM')
else if FontMetrics.tmCharSet = Symbol_CharSet then SetDlgItemText(HWindow,638,'Symbol')
else if FontMetrics.tmCharSet = ShiftJis_CharSet then SetDlgItemText(HWindow,638,'ShiftJis')
else SetDlgItemText(HWindow,638,' ');
Str(FontMetrics.tmOverHang:3,Buf); SetDlgItemText(HWindow,639,Buf);
Str(FontMetrics.tmDigitizedAspectX:3,Buf); SetDlgItemText(HWindow,640,Buf);
Str(FontMetrics.tmDigitizedAspectY:3,Buf); SetDlgItemText(HWindow,641,Buf);
end;

{*********************************************************************}
procedure TPVDlg3.WMInitDialog(var Msg:TMessage);
var
ThePrinter:pPVPrinter;
DeviceName:Array[0..40] of Char;
begin
TDialog.WMInitDialog(Msg);
ThePrinter := New(pPVPrinter,Init(hInstance,@Self));
ThePrinter^.GetPrinterParms;
ThePrinter^.DCCreated;
StrCopy(DeviceName,ThePrinter^.deviceName);
ThePrinter^.DeleteContext;
Dispose(ThePrinter,Done);
SetDlgItemText(HWindow,503,DeviceName);
end;

procedure TPVDlg3.IDSetup(var Msg:TMessage);
var
ThePrinter:pPVPrinter;
begin
ThePrinter := New(pPVPrinter,Init(hInstance,@Self));
ThePrinter^.prnDeviceMode(hWindow);
dispose(ThePrinter,Done);
pPVWindow(Parent)^.EnumerateFaces;
pPVWindow(Parent)^.EnumerateSizes;
end;

procedure TPVDlg3.IDOKPrt(var Msg:TMessage);
begin
EndDlg(1);
SendMessage(PPVWindow(Parent)^.HWindow,wm_User+um_FilePrint,Msg.wParam,Msg.LParam);
end;

procedure TPVDlg3.IDEC1(var Msg:TMessage);
var
Idx : Integer;
Buf:Array[0..5] of Char;
Ptr : PChar;
ErrCode:Integer;
FontSize:Integer;
return:Integer;
begin
case Msg.lParamHi of
en_Change:
begin
Ptr := Buf;
Idx := 5;
Return := SendDlgItemMsg(id_Ec1,wm_GetText,word(Idx),LongInt(Ptr));
val(Ptr,FontSize,ErrCode);
PPVWindow(Parent)^.SetPFontSize(FontSize);
Exit;
end;
end;
end;
{*********************************************************************}
function TPVPrinter.SetFont(NewFont:hFont):hFont;
var
MM:Integer;
LogFont:TLogFont;
begin
SetFont := SelectObject(hPrintDC,NewFont);
getTextMetrics(hPrintDC,Metrics);
MM := GetMapMode(hPrintDC);
GetObject(NewFont,sizeof(LogFont),@LogFont);
end;

function TPVPrinter.Start(dName:pChar;hw:HWnd):Boolean;
begin
MarginL := 0;
MarginT := 0;
MarginR := 0;
MarginB := 0;
Start := tPrinter.Start(dName,hw); {ancestor call}
end;

procedure TPVPrinter.SetMarginL(NewMargin:Integer);
begin
MarginL := NewMargin;
end;

procedure TPVPrinter.SetMarginT(NewMargin:Integer);
begin
MarginT := NewMargin;
end;

procedure TPVPrinter.SetMarginR(NewMargin:Integer);
begin
MarginR := NewMargin;
end;

procedure TPVPrinter.SetMarginB(NewMargin:Integer);
begin
MarginB := NewMargin;
end;


function TPVPrinter.NewLine:Boolean;
Begin
posX := MarginL;
posY := posY + height;
checkNewPage;
end;

function TPVPrinter.ResetPos:Boolean;
Begin
posX := MarginL;
posY := MarginT;
end;

function TPVPrinter.CheckNewPage:Boolean;
begin
if (posY + MarginB > maxY ) then newPage;
end;

function TPVPrinter.Print(aStr:pchar):Boolean;
var
Extent:Integer;
begin
Extent := lineWidth(aStr);
if ((PosX + Extent + MarginR) > maxX) then
newLine;
if printString(aStr) then
begin
PosX := PosX + Extent;
Print := True;
end
else
Print := False;
end;


function TPVPrinter.prnDeviceMode(Wnd:HWnd):Integer;
var
dHandle: tHandle; {handle of the load library for the current printer}
drvName: pChar; {name of the driver used to get dHandle}
pAddr: tFarProc; {address of the function in the DLL we want to EXEC}


Begin
if getPrinterParms then begin {retrieve printer info from windows}
drvName := driver;
strCat(drvName,'.drv'); {make a file name out of the driver}
dHandle := LoadLibrary(drvName); {load the DLL for the printer}
pAddr := getProcAddress(dHandle,'ExtDeviceMode');
if (pAddr <> nil) then begin
tGetExtDevMode(pAddr)(wnd,dHandle,dMode,drvName,prnPort,dMode,nil,
dm_prompt OR dm_Update);
end else begin
pAddr := GetProcAddress(dHandle,'DEVICEMODE');
if (pAddr <> nil) then begin
tGetDevMode(pAddr)(wnd,dHandle,drvName,prnPort);
End;
End;
FreeLibrary(dHandle); {the library is freed when we are done with it}
End;
end;


{*********************************************************************}
{*** M A I N L I N E }
{*********************************************************************}
var
PVApp : TPVApplication;
begin
PVApp.Init('Font Preview');
PVApp.Run;
PVApp.Done;

end.


  3 Responses to “Category : Windows 3.X Files
Archive   : PRVW13.ZIP
Filename : PREVIEW.PAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/