home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / PLX13.ZIP / PRINTER1.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-10-09  |  9.5 KB  |  386 lines
  1. {$V-,F+}
  2. {tPrinter unit subclasses by D.Overmyer to directly support
  3.     margins, headers, footer, change printer dialog and changing fonts}
  4. UNIT Printer1;
  5. (***********************************************************)
  6. INTERFACE
  7. (***********************************************************)
  8. USES WObjects,WinTypes,WinProcs,Strings,WinDos,Printer;
  9. const
  10.     pm_NoPrint =   0;
  11.   pm_PrintText   =  1;
  12.   pm_PrintFooter =  2;
  13.  
  14. type
  15.   PPrinter1 = ^TPrinter1;
  16.   TPrinter1 = object(tPrinter)
  17.   Margin:TRect;      {Rect struct for left,top,right,bottom values in pixels}
  18.   CurFont:hFont;     {Current printing font}
  19.   PageNumber:Integer;{Current page number}
  20.   FooterY:Integer;   {Height of footer}
  21.   PrtMode:Integer;   {modal flag - set to pm_xxxxxxxxx constants}
  22.  
  23.     constructor Init(inst: tHandle;par: pWindowsObject);
  24.     Function Start(dName: pChar;hw: hWnd): Boolean; virtual;
  25.     Function Print(aStr: pChar): Boolean; virtual;
  26.     Function PrintString(aStr: pChar): Boolean; virtual;
  27.     Function NewLine: Boolean; virtual;
  28.     Function CheckNewPage: Boolean; virtual;
  29.     Function NewPage: Boolean; virtual;
  30.     Function ResetPos: Boolean; virtual;
  31.     Function DoNewFrame: Boolean; virtual;
  32.   Function LineWidth(aStr: pChar): Integer; virtual;
  33.   procedure SetMarginL(NewMargin:Integer);virtual;
  34.   procedure SetMarginT(NewMargin:Integer);virtual;
  35.   procedure SetMarginR(NewMargin:Integer);virtual;
  36.   procedure SetMarginB(NewMargin:Integer);virtual;
  37.   function SetMargin(NewMargin:TRect):Boolean;virtual;
  38.   function GetMargin(var CurMargin:TRect):Boolean;virtual;
  39.   function SetFont(NewFont:hFont):hFont;virtual;
  40.   function DoHeader:Boolean;virtual;
  41.   procedure ChgPrinter;virtual;
  42.   function CalcFooterY:Integer;virtual;
  43.   function DoFooter:Boolean;virtual;
  44.   function SetupPage:Boolean;virtual;
  45.   function GetQuickDC:hDC;virtual;
  46.   function DeleteQuickDC:Boolean;virtual;
  47.   function prnDeviceMode(wnd: hWnd):Integer; virtual;
  48. End;
  49.  
  50. tGetDevMode = function(hWindow: hWnd; dHan: tHandle; devName,output: pChar): Boolean;
  51. tGetExtDevMode = function(hWIndow: hWnd;
  52.     dHan: tHandle;
  53.     outMode: tDevMode;
  54.     devName: pChar;
  55.     outPut: pChar;
  56.     inMode: tDevMode;
  57.     profile: pChar;
  58.     pMode: word): Boolean;
  59.   tMode= tDeviceMode;
  60.  
  61. (***********************************************************)
  62. IMPLEMENTATION
  63. (***********************************************************)
  64. {$R Printer1.RES}
  65. var
  66.   userAbort: Boolean;
  67.   PrintDialog: pPrnDialog;
  68. const
  69.     id_PrtD1OK        = 1102;
  70.     id_PrtD1LB1   = 1101;
  71. type
  72. PPRTDlg1 = ^TPRTDlg1;
  73. TPRTDlg1 = object(TDialog)
  74.     szAllDevices:Array[0..4096] of Char;
  75.     procedure WMInitDialog(var Msg:TMessage);virtual wm_First+wm_InitDialog;
  76.     procedure IDPRTD1OK(var Msg:TMessage);virtual id_First+id_PrtD1OK;
  77. end;
  78.  
  79. (***********************************************************)
  80.  
  81. Constructor TPrinter1.Init(inst: tHandle; par: pWindowsObject);
  82. Begin
  83.     TPrinter.Init(Inst,Par);
  84.   PageNumber := 1;
  85.   PrtMode := pm_PrintText;
  86.   FooterY := 0;
  87.   hPrintDC := 0;            {init the device conText to 0}
  88. End;
  89.  
  90. Function TPrinter1.Start;
  91. var
  92.   ap: tPoint;
  93. Begin
  94.     Margin.Left := 0;
  95.   Margin.Top := 0;
  96.   Margin.Right := 0;
  97.   Margin.Bottom := 0;
  98.   hWindow := Hw;            {save the parent window. Seemed like a good idea}
  99.   hPrintDC := 0;            {init the device conText to 0}
  100.   GlobalCompact(0);            {compacts global memory}
  101.   if (getPrinterParms and DCcreated) then
  102.       begin
  103.         docName := dName;
  104.         getTextMetrics(hPrintDC,Metrics);
  105.         PageSize(ap);
  106.         MaxX := ap.x-1;
  107.         MaxY := ap.y-1;
  108.         start := CheckStart;
  109.       end
  110.   else
  111.         start := false;
  112.   CurFont := GetStockObject(Device_Default_Font);
  113. End;
  114.  
  115.  
  116. Function TPrinter1.lineWidth(aStr: pChar): Integer;
  117. var
  118.     Res:LongInt;
  119. Begin
  120.   if (aStr <> nil) then
  121.       begin
  122.     res := (GetTextExtent(hPrintDC,aStr,strLen(aStr)));
  123.     lineWidth := LongRec(res).lo;
  124.     end
  125.   else
  126.     LineWidth := 0;
  127. End;
  128.  
  129. function TPrinter1.Print(aStr:PChar):Boolean;
  130. var
  131.     Extent:Integer;
  132. begin
  133.     Extent := lineWidth(aStr);
  134.   if PrintString(aStr) then
  135.       begin
  136.       PosX := PosX + Extent;
  137.       Print := True;
  138.       end
  139.   else
  140.         Print := False;
  141. end;
  142.  
  143. function TPrinter1.PrintString(aStr:pChar):Boolean;
  144. begin
  145.     if OKPrint then
  146.       begin
  147.       if(PrtMode <> pm_NoPrint) then
  148.         PrintString := TextOut(hPrintDC,PosX,PosY,aStr,strLen(aStr))
  149.     end
  150.   else
  151.       PrintString := False;
  152. end;
  153.  
  154.  
  155. function TPrinter1.NewLine:Boolean;
  156. Begin
  157.     PosX := Margin.Left;
  158.   PosY := PosY + Height;
  159.   CheckNewPage;
  160. end;
  161.  
  162. function TPrinter1.CheckNewPage:Boolean;
  163. begin
  164.     if PrtMode = pm_PrintText then
  165.         if (PosY + Margin.Bottom + 2*Height + FooterY > MaxY ) then
  166.         begin
  167.       PrtMode := pm_PrintFooter;
  168.       DoFooter;
  169.       PrtMode := pm_PrintText;
  170.       NewPage;
  171.       end;
  172. end;
  173.  
  174.  
  175. function TPrinter1.NewPage:Boolean;
  176. begin
  177.     if OkToPrint then
  178.       begin
  179.     ResetPos;
  180.     DoNewFrame;
  181.     Inc(PageNumber);
  182.     SetupPage;
  183.     end;
  184. end;
  185.  
  186. function TPrinter1.SetupPage:Boolean;
  187. begin
  188.     ResetPos;
  189.     CalcFooterY;
  190.   DoHeader;
  191. end;
  192.  
  193. function TPrinter1.ResetPos:Boolean;
  194. Begin
  195.     PosX := Margin.Left;
  196.   PosY := Margin.Top;
  197. end;
  198.  
  199.  
  200. Function TPrinter1.DoNewFrame: Boolean;
  201. Begin
  202.   if OkPrint then
  203.       begin
  204.         DoNewFrame := TPrinter.DoNewFrame;
  205.       SelectObject(hPrintDC,CurFont);
  206.       end;
  207. End;
  208.  
  209. function TPrinter1.DoHeader:Boolean;
  210. begin
  211.     {formal method - override in instance variable}
  212. end;
  213.  
  214. function TPrinter1.DoFooter:Boolean;
  215. begin
  216.     {Formal Method - override in instance variable}
  217. end;
  218.  
  219. function TPrinter1.CalcFooterY:Integer; {Estimate footer height in pixels}
  220.                                        {Can be called between print lines with care!}
  221. var
  222.   OldX,OldY:Integer;
  223.   OldPM:Integer;
  224.     OldFont:hFont;
  225. begin
  226.     OldFont := SetFont(CurFont);
  227.   OldX := PosX;
  228.   OldY := PosY;
  229.   OldPM := PrtMode;
  230.   PrtMode := pm_NoPrint;
  231.   DoFooter;
  232.   FooterY := PosY - OldY;
  233.   PosX := OldX;
  234.   PosY := OldY;
  235.   SetFont(OldFont);
  236.   PrtMode := OldPM;
  237.   CalcFooterY := FooterY;
  238. end;
  239.  
  240. procedure TPrinter1.SetMarginL(NewMargin:Integer);
  241. begin
  242.     Margin.Left := NewMargin;
  243. end;
  244.  
  245. procedure TPrinter1.SetMarginT(NewMargin:Integer);
  246. begin
  247.     Margin.Top := NewMargin;
  248. end;
  249.  
  250. procedure TPrinter1.SetMarginR(NewMargin:Integer);
  251. begin
  252.     Margin.Right := NewMargin;
  253. end;
  254.  
  255. procedure TPrinter1.SetMarginB(NewMargin:Integer);
  256. begin
  257.     Margin.Bottom := NewMargin;
  258. end;
  259.  
  260. function TPrinter1.SetMargin(NewMargin:TRect):Boolean;
  261. begin
  262.     Margin := NewMargin;
  263.   SetMargin := True;
  264. end;
  265.  
  266. function TPrinter1.GetMargin(var CurMargin:TRect):Boolean;
  267. begin
  268.     CurMargin := Margin;
  269. end;
  270.  
  271. function TPrinter1.SetFont(NewFont:hFont):hFont;
  272. var
  273.     MM:Integer;
  274.   LogFont:TLogFont;
  275. begin
  276.     SetFont := SelectObject(hPrintDC,NewFont);
  277.   CurFont := NewFont;
  278.   getTextMetrics(hPrintDC,Metrics);
  279. end;
  280.  
  281. procedure TPrinter1.ChgPrinter;
  282. var
  283.   PRTDlg1 : pPRTDlg1;
  284. begin
  285.   PRTDlg1 := new(pPRTDlg1,Init(TheParent,'PRT_Dlg1'));
  286.   Application^.ExecDialog(PRTDlg1);
  287. end;
  288.  
  289. function TPrinter1.GetQuickDC:hDC; {This function does not fully initialized the printer object}
  290. begin
  291.     if hPrintDC = 0 then
  292.       begin
  293.       GetPrinterParms;
  294.     DCCreated;
  295.     GetQuickDC := hPrintDC;
  296.     end
  297.   else
  298.       GetQuickDC := 0;
  299. end;
  300.  
  301. function TPrinter1.DeleteQuickDC:Boolean;
  302. begin
  303.     DeleteContext;
  304. end;
  305.  
  306. function     TPrinter1.prnDeviceMode(Wnd:HWnd):Integer;
  307. var
  308.   dHandle: tHandle;     {handle of the load library for the current printer}
  309.   drvName: pChar;       {name of the driver used to get dHandle}
  310.   pAddr:   tFarProc;    {address of the function in the DLL we want to EXEC}
  311. Begin
  312.   if getPrinterParms then
  313.         begin            {retrieve printer info from windows}
  314.         drvName := driver;
  315.         strCat(drvName,'.drv');             {make a file name out of the driver}
  316.         dHandle := LoadLibrary(drvName);    {load the DLL for the printer}
  317.         pAddr := getProcAddress(dHandle,'ExtDeviceMode');
  318.         if (pAddr <> nil) then
  319.             begin
  320.           tGetExtDevMode(pAddr)(wnd,dHandle,dMode,Device,prnPort,dMode,nil,
  321.                   dm_prompt  OR dm_Update);
  322.             end
  323.         else
  324.             begin
  325.           pAddr := GetProcAddress(dHandle,'DEVICEMODE');
  326.           if (pAddr <> nil) then
  327.                 begin
  328.                 tGetDevMode(pAddr)(wnd,dHandle,drvName,prnPort);
  329.               End;
  330.             End;
  331.         FreeLibrary(dHandle);   {the library is freed when we are done with it}
  332.       End;
  333. end;
  334.  
  335. {***********************************************************************}
  336. procedure TPRTDlg1.WMInitDialog(var Msg:TMessage);
  337. var
  338.      pAllDevices:PChar;
  339.      Buf:Array[0..64] of Char;
  340.      pBuf:PChar;
  341.      szPrinter1:Array[0..64] of Char;
  342.      szPrinter:Array[0..64] of Char;
  343.     pPrinter:PChar;
  344. begin
  345.     GetProfileString('devices',nil,'',szAllDevices,sizeof(szAllDevices));
  346.     TDialog.WMInitDialog(Msg);
  347.   pAllDevices := szAllDevices;
  348.   pBuf := @Buf;
  349.   pPrinter := @szPrinter;
  350.   repeat
  351.     StrCopy(Buf,pAllDevices);
  352.     GetProfileString('devices',Buf,'',szPrinter1,sizeof(szPrinter1));
  353.     StrCat(StrCat(StrCopy(szPrinter,Buf),','),szPrinter1);
  354.       SendDlgItemMsg(id_PrtD1LB1,lb_AddString,word(0),LongInt(pPrinter));
  355.     pAllDevices := pAllDevices+StrLen(pBuf)+1;
  356.   until StrLen(pAllDevices) = 0;
  357. end;
  358.  
  359. procedure TPRTDlg1.IDPRTD1OK(var Msg:TMessage);
  360. var
  361.     Idx:Integer;
  362.   Buf:Array[0..64] of Char;
  363.   Ptr:PChar;
  364.   Ptr1:PChar;
  365.   cPos:PChar;
  366.   ErrCode:Integer;
  367.   szPrinter:Array[0..64] of Char;
  368.   szDriver:Array[0..64] of Char;
  369.   szPort:Array[0..64] of Char;
  370.   szNewDevice:Array[0..64] of Char;
  371. begin
  372.     StrCopy(Buf,'');
  373.     Ptr := @Buf;
  374.   Idx := SendDlgItemMsg(id_PrtD1LB1,lb_GetCurSel,0,0);
  375.   if Idx <> lb_Err then
  376.       SendDlgItemMsg(id_PrtD1LB1,lb_GetText,idx,Longint(Ptr));
  377.   if StrLen(Ptr) > 0 then
  378.       begin
  379.     StrCopy(szNewDevice,Buf);
  380.     WriteProfileString('Windows','device',szNewDevice);
  381.     end;
  382.     EndDlg(1);
  383. end;
  384.  
  385. end.
  386.