kolmck/Addons/KOLPrinters.pas

unit KOLPrinters;
{* Replaces VCL TPrinter functionality.
|<br>
Author : Bogus³aw Brandys, <brandysb@poczta.onet.pl>
|<br>
|<H3>Version 1.4 </H3>
|<br>
|<i>History :</i>
|<br>
|<b> 17-09-2002 </b> [+] Added property Assigned which should always be checked before first access
to TKOLPrinter. If is FALSE then there is no printer in system. (Warning: if You
assign incorrect info to Assign procedure this could lead Your application to
crash rather then return Assigned = FALSE)
|<br>
[+] Changed Write to WriteLn and improved.Now always print a line of text with
carrage return #10#13 even there is no one at the end of text.Also should not break
word on bottom-right corner of page and working good when text does not fit on page
(NextPage invoked)
|<br>
|<br>
|<b> 15-09-2002 </b> [-]  Fix access violation when there is no printer in system (caused
by DefPrinter function and Assign procedure).
|<br>
|<b><i>Example:</i></b>
! with Printer^ do
!  begin
!        Assign(nil); //default printer (actually not needed as default printer is assigned on start)
!        if not Assigned then begin
!        MsgBox('There is no default printer in system!',mb_iconexclamation);
!        Exit;
!        end;
!        Title := 'Printing test...';
!        Canvas.Font.Assign(Memo1.Font);
!        BeginDoc;
!         for i:=0 to Memo1.Count-1 do WriteLn(Memo1.Items[i]); //or just WriteLn(Memo1.Text);
!        EndDoc;
!  end;
|<br>
|</i>One more note:</i>
|<br> use psdWarning and pdWarning in PageSetup/Print dialogs to let
user know that there is no printer in system (or no default).
When these options are  not used PrintDialog appear empty but PageSetup dialog never
appears.
|<br>
Notes:
|<br>
When output is redirected to a file and You want to know his name , check Output property
but always after sucessful Execute and before EndDoc (becouse EndDoc clears Output property)
Margins are supported but experimental (if You have time and paper please examine
if it working and let me know ;-) - especially if units for margins are properly computed.
Beside let me know what is still missing...
|<br>
Still missing (I suppose):
|<br>
- printing text as continuation of current printed line (in the middle of the line)
(this was a nightmare for me , if You know how to do it contact me)
|<br>
- printing of selected pages only  (must compute pages count)
|<br>
- collate and printing more than one page when printer do not support multiple pages and collation
(well, should not be very difficult, maybe just check if this is supported and if no just print many times
 the same)
|<br>
- Printers property (list of printers in system),PrinterIndex and  Fonts property
|<br>
- print preview
|<br>
- more tests}

interface

uses Windows, Messages, KOL, KOLPrintCommon;

type
  TPrinterState = (psNeedHandle, psHandle, psOtherHandle);
  TPrinterOrientation = (poPortrait, poLandscape);
  {* Paper orientation}
  TMarginOption = (mgInches, mgMillimeters);
  {* Margin option}

  PPrinter = ^TPrinter;
  TKOLPrinter = PPrinter;
  TPrinter = object(TObj)
    {*}
  private
    { Private declarations }
    fDevice, fDriver, fPort: string;
    fDevMode: THandle;
    fDeviceMode: PDeviceMode;
    fCanvas: PCanvas;     // KOL canvas
    fTitle: string;
    fState: TPrinterState; // DC is allocated or need new DC becouse params were changed
    fAborted: Boolean;
    fPrinting: Boolean;
    fPageNumber: Integer;
    fOutput: string;
    PrinterInfo: TPrinterInfo;
    fRec: TRect;
    fMargins: TRect;      //Margins (in pixels)
    fAssigned: Boolean;   //if TRUE ,there is a printer with correctly assigned information
  protected
    function GetHandle: HDC;
    procedure SetHandle(Value: HDC);
    function GetCanvas: PCanvas;
    function GetCopies: Integer;
    procedure SetCopies(const Value: Integer);
    function GetOrientation: TPrinterOrientation;
    procedure SetOrientation(const Value: TPrinterOrientation);
    function GetPageHeight: Integer;
    function GetPageWidth: Integer;
    function Scale: Integer;
    procedure Prepare;
    procedure DefPrinter;
  public
    { Public declarations }
    destructor Destroy; virtual;
    procedure Abort;
    {* Abort print process}
    procedure BeginDoc;
    {* Begin print process}
    procedure EndDoc;
    {* End print process end send it to print spooler}
    procedure NewPage;
    {* Request new page}
    procedure Assign(Source: PPrinterInfo);
    {* Assign information about selected printer for example from Print/Page dialogs}
    procedure AssignMargins(cMargins: TRect; Option: TMarginOption);
    {* Assign information about paper margins for example from TKOLPageSetupDialog
    (in thousands of inches scale)}
    procedure WriteLn(const Text: string);
    {* Print tekst with TKOLPrinter selected font.Note: can be invoked more than once, but currently
    only for text ended with #10#13 (other is not properly wraped around right page corner ;-(  )}
    procedure RE_Print(RichEdit: PControl);
    {* Print content of TKOLRichEdit (if Rich is not TKOLRichEdit nothing happens)
       with full formating of course :-)}
    property Assigned: Boolean read fAssigned;
    {* If TRUE, there is a default or assigned previoulsy printer (by Assign).Always check
    this property to avoid access violation when there is no printer in system}
    property Title: string read fTitle write fTitle;
    {* Title of print process in print manager window}
    function Info: PPrinterInfo;
    {* Returns info of selected print}
    property Output: string read fOutput write fOutput;
    {* Let print to the file.Assign file path to this property.}
    property Handle: HDC read GetHandle write SetHandle;
    {*}
    property Canvas: PCanvas read GetCanvas;
    {*}
    property Copies: Integer read GetCopies write SetCopies;
    {* Number of copies}
    property Orientation: TPrinterOrientation read GetOrientation write SetOrientation;
    {* Page orientation}
    property Margins: TRect read fMargins write fMargins;
    {* Page margins (in pixels)}
    property PageHeight: Integer read GetPageHeight;
    {* Page height in logical pixels}
    property PageWidth: Integer read GetPageWidth;
    {* Page width in logical pixels}
    property PageNumber: Integer read fPageNumber;
    {* Currently printed page number}
    property Printing: Boolean read fPrinting;
    {* Indicate printing process}
    property Aborted: Boolean read fAborted;
    {* Indicate abort of printing process}

  end;

function Printer: PPrinter;
{* Returns pointer to global TKOLPrinter object}
procedure RecreatePrinter;
{* Recreates global Printer pbject }

function NewPrinter(PrinterInfo: PPrinterInfo): PPrinter;
{* Global function for creating TKOLPrinter instance.Usually not needed, becouse
inluding KOLPrinters causes creating of global TKOLPrinter instance.}

implementation

uses
  RichEdit;

type
  PtagPD = ^tagPD;
  tagPD = packed record
    lStructSize: DWORD;
    hWndOwner: HWND;
    hDevMode: HGLOBAL;
    hDevNames: HGLOBAL;
    hDC: HDC;
    Flags: DWORD;
    nFromPage: Word;
    nToPage: Word;
    nMinPage: Word;
    nMaxPage: Word;
    nCopies: Word;
    hInstance: HINST;
    lCustData: LPARAM;
    lpfnPrintHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall;
    lpfnSetupHook: function(Wnd: HWND; Message: UINT; wParam: WPARAM; lParam: LPARAM): UINT stdcall;
    lpPrintTemplateName: PAnsiChar;
    lpSetupTemplateName: PAnsiChar;
    hPrintTemplate: HGLOBAL;
    hSetupTemplate: HGLOBAL;
  end;

const
  PD_RETURNDC       = $00000100;
  PD_RETURNDEFAULT  = $00000400;

var
  FPrinter          : PPrinter = nil;

function PrintDlg(var PrintDlg: tagPD): BOOL; stdcall; external 'comdlg32.dll' name 'PrintDlgA';

function AbortProc(Handle: HDC; Error: Integer): Bool; stdcall;
begin
  Result := not fPrinter.Aborted;
end;

function NewPrinter(PrinterInfo: PPrinterInfo): PPrinter;
begin
  New(Result, Create);
  Result.fTitle := '';
  Result.fOutput := '';
  Result.fAborted := False;
  Result.fPrinting := False;
  Result.fPageNumber := 0;
  Result.fCanvas := nil;
  Result.fMargins.Top := 10;
  Result.fMargins.Left := 10;
  Result.fMargins.Bottom := 10;
  Result.fMargins.Right := 10;
  FillChar(Result.fRec, sizeof(Result.fRec), 0);
  if PrinterInfo = nil then
    Result.DefPrinter
  else
    Result.Assign(PrinterInfo);
end;

function Printer: PPrinter;
begin
  if FPrinter = nil then
    FPrinter := NewPrinter(nil);
  Result := FPrinter;
end;

procedure RecreatePrinter;
begin
  Free_And_Nil(FPrinter);
  FPrinter := NewPrinter(nil);
end;

destructor TPrinter.Destroy;
begin
  Prepare;
  fTitle := '';
  fDevice := '';
  fDriver := '';
  fPort := '';
  fOutput := '';
  inherited;              {+++}
  FPrinter := nil;
end;

procedure TPrinter.Prepare;
begin
  { Free previously used resources }
  if (fState <> psOtherHandle) and (fCanvas <> nil) then begin
    fCanvas.Free;
    fCanvas := nil;       {+++}
  end;
  if fDevMode <> 0 then begin
    GlobalUnlock(fDevMode);
    GlobalFree(fDevMode);
  end;
end;

function TPrinter.Scale: Integer;
var
  DC                : HDC;
  ScreenH, PrinterH : Integer;
begin
  DC := GetDC(0);
  ScreenH := GetDeviceCaps(DC, LOGPIXELSY);
  PrinterH := GetDeviceCaps(fCanvas.Handle, LOGPIXELSY);
  ReleaseDC(0, DC);
  Result := PrinterH div ScreenH;
end;

procedure TPrinter.WriteLn(const Text: string);
var
  OldFontSize, PageH, Size, Len: Integer;
  pC                : PChar;
  Rect              : TRect;
  Metrics           : TTextMetric;
  NewText           : string;

  procedure ComputeRect;
    { Start from new line.Rect is the rest of page from current new line to the bottom. First probe
     how many characters do not fit on this rect.}
  begin
    Len := 1;
    while Windows.DrawText(fCanvas.Handle, pC, Len, Rect, DT_CALCRECT + DT_WORDBREAK + DT_NOCLIP + DT_NOPREFIX + DT_EXPANDTABS) < PageH do begin
      Rect.Right := fRec.Right; //must be, becouse DrawText shorten right corner
      Len := Len + 100;
      if Len > Size then begin
        Len := Size;
        Break;
      end;
    end;

    { Next : Count backwards to find exact characters which fit on required page rect.}
    while Windows.DrawText(fCanvas.Handle, pC, Len, Rect, DT_CALCRECT + DT_WORDBREAK + DT_NOCLIP + DT_NOPREFIX + DT_EXPANDTABS) > PageH do
      Len := Len - 1;

    { Find position of last space or line end (#13#10) to not break word
     (if possible) on bottom-right corner of the page.Do it only for multipage text (Len<>Size)  }
   {
    if (Len <> Size) and (Len > 0) then begin
    Test := Len;
    while ((NewText[Test] <> #32) and (NewText[Test]<> #10)) and (Test > 0)  do Test := Test -1 ;
    if Test > 0 then Len := Test;
    end;
    }

    { Finally draw it!}
    Windows.DrawText(fCanvas.Handle, pC, Len, Rect, DT_WORDBREAK + DT_NOCLIP + DT_NOPREFIX + DT_EXPANDTABS);

  end;

begin
  if Length(Text) <= 0 then Exit;
  if Text[Length(Text)] <> #10 then NewText := Text + #13#10
  else
    NewText := Text;
  pC := PChar(NewText);
  Size := Length(NewText);
  SetMapMode(fCanvas.Handle, MM_TEXT);
  OldFontSize := fCanvas.Font.FontHeight;
  fCanvas.Font.FontHeight := fCanvas.Font.FontHeight * Scale;
  SelectObject(fCanvas.Handle, fCanvas.Font.Handle);
  PageH := GetPageHeight - fMargins.Bottom;
  GetTextMetrics(fCanvas.Handle, Metrics);
  while Size > 0 do begin
    Rect := fRec;
    ComputeRect;
    Inc(pC, Len + 1);
    Dec(Size, Len + 1);
    if (Size > 0) and (fRec.Left <= fMargins.Left) then NewPage;
  end;
  if (Rect.Bottom > PageH) then begin
    NewPage;
    Rect.Bottom := 0;
  end;
  fRec.Top := Rect.Bottom - Metrics.tmHeight;
  fRec.Left := fMargins.Left;
  fRec.Bottom := PageH;
  fCanvas.Font.FontHeight := OldFontSize;
  NewText := '';
end;

procedure TPrinter.DefPrinter;
var
  ftagPD            : tagPD;
  DevNames          : PDevNames;
begin
  fAssigned := false;
  fState := psHandle;
  Prepare;
  { Get DC of default printer }
  FillChar(ftagPD, sizeof(tagPD), 0);
  ftagPD.Flags := PD_RETURNDC + PD_RETURNDEFAULT;
  ftagPD.lStructSize := sizeof(ftagPD);
  if not PrintDlg(ftagPD) then Exit;
  fAssigned := true;
  DevNames := PDevNames(GlobalLock(ftagPD.hDevNames));
  fDevMode := ftagPD.hDevMode;
  fDeviceMode := PDevMode(GlobalLock(fDevMode));
  try
    fDriver := string(PChar(DevNames) + DevNames^.wDriverOffset);
    fDevice := string(PChar(DevNames) + DevNames^.wDeviceOffset);
    fPort := string(PChar(DevNames) + DevNames^.wOutputOffset);
  finally
    GlobalUnlock(ftagPD.hDevNames);
    GlobalFree(ftagPD.hDevNames);
  end;
  fCanvas := NewCanvas(ftagPD.hDC);
end;

procedure TPrinter.Assign(Source: PPrinterInfo);
var
  Size              : Integer;
  DevMode           : PDevMode;
  fhDC              : HDC;
begin
  fAssigned := false;
  if (Source = nil) or
    (Source^.ADriver = nil) and
    (Source^.ADevice = nil) and
    (Source^.APort = nil) and
    (Source^.ADevMode = 0) then DefPrinter
  else begin
    Prepare;
    fDriver := string(Source^.ADriver);
    fDevice := string(Source^.ADevice);
    fPort := string(Source^.APort);
    DevMode := PDevMode(GlobalLock(Source^.ADevMode));
    try
      Size := sizeof(DevMode^);
      fDevMode := GlobalAlloc(GHND, Size);
      fDeviceMode := PDevMode(GlobalLock(fDevMode));
      CopyMemory(fDeviceMode, DevMode, Size);
      fhDC := CreateDC(PChar(fDriver), PChar(fDevice), PChar(fPort), fDeviceMode);
    finally
      GlobalUnlock(Source^.ADevMode);
    end;
    fCanvas := NewCanvas(fhDC);
    fAssigned := true;
  end;
end;

procedure TPrinter.AssignMargins(cMargins: TRect; Option: TMarginOption);
var
  PH, PW            : Integer;
begin
  PH := GetDeviceCaps(fCanvas.Handle, LOGPIXELSY);
  PW := GetDeviceCaps(fCanvas.Handle, LOGPIXELSX);
  case Option of
    mgInches: begin
        fMargins.Top := round((cMargins.Top * PH) / 1000);
        fMargins.Left := round((cMargins.Left * PW) / 1000);
        fMargins.Bottom := round((cMargins.Bottom * PH) / 1000);
        fMargins.Right := round((cMargins.Right * PW) / 1000);
      end;
    mgMillimeters: begin
        fMargins.Top := round((cMargins.Top * PH) / 2540);
        fMargins.Left := round((cMargins.Left * PW) / 2540);
        fMargins.Bottom := round((cMargins.Bottom * PH) / 2540);
        fMargins.Right := round((cMargins.Right * PW) / 2540);
      end;
  end;
end;

procedure TPrinter.Abort;
begin
  AbortDoc(fCanvas.Handle);
  fAborted := True;
  EndDoc;
end;

procedure TPrinter.BeginDoc;
var
  doc               : DOCINFOA;
begin
  fRec.Top := fMargins.Top;
  fRec.Left := fMargins.Left;
  fRec.Right := GetPageWidth - fMargins.Right;
  fRec.Bottom := GetPageHeight - fMargins.Bottom;
  fAborted := False;
  fPageNumber := 1;
  fPrinting := True;
  FillChar(doc, sizeof(DOCINFOA), 0);
  doc.lpszDocName := PChar(fTitle);
  if (fOutput <> '') then doc.lpszOutput := PChar(fOutput);
  doc.cbSize := sizeof(doc);
  SetAbortProc(fCanvas.Handle, AbortProc);
  StartDoc(fCanvas.Handle, doc);
  StartPage(fCanvas.Handle);
end;

procedure TPrinter.EndDoc;
begin
  EndPage(fCanvas.Handle);
  if not fAborted then Windows.EndDoc(fCanvas.Handle);
  fAborted := False;
  fPageNumber := 0;
  fOutPut := '';
  fPrinting := False;
end;

function TPrinter.GetHandle: HDC;
var
  fhDC              : HDC;
begin
  if (fState = psNeedHandle) and (fCanvas <> nil) then begin
    fCanvas.Free;
    fhDC := CreateDC(PChar(fDriver), PChar(fDevice), PChar(fPort), fDeviceMode);
    fCanvas := NewCanvas(fhDC);
    fState := psHandle;
  end;
  Result := fCanvas.Handle;
end;

procedure TPrinter.SetHandle(Value: HDC);
begin
  if Value <> fCanvas.Handle then begin
    if fCanvas <> nil then fCanvas.Free;
    fCanvas := NewCanvas(Value);
    fState := psOtherHandle;
  end;
end;

function TPrinter.GetCanvas: PCanvas;
begin
  GetHandle;
  Result := fCanvas;
end;

function TPrinter.Info: PPrinterInfo;
begin
  with PrinterInfo do begin
    ADevice := PChar(fDevice);
    ADriver := PChar(fDriver);
    APort := PChar(fPort);
    ADevMode := fDevMode;
  end;
  Result := @PrinterInfo;
end;

function TPrinter.GetCopies: Integer;
begin
  Result := fDeviceMode^.dmCopies;
end;

procedure TPrinter.SetCopies(const Value: Integer);
begin
  fDeviceMode^.dmCopies := Value;
end;

function TPrinter.GetOrientation: TPrinterOrientation;
begin
  if System.Assigned(fDeviceMode) and (fDeviceMode^.dmOrientation = DMORIENT_PORTRAIT) then
    Result := poPortrait
  else
    Result := poLandscape;
end;

procedure TPrinter.SetOrientation(const Value: TPrinterOrientation);
const
  Orientations      : array[TPrinterOrientation] of Integer = (DMORIENT_PORTRAIT, DMORIENT_LANDSCAPE);
begin
  fDeviceMode^.dmOrientation := Orientations[Value];
end;

function TPrinter.GetPageHeight: Integer;
begin
  if fCanvas <> nil then
    Result := GetDeviceCaps(fCanvas.Handle, VERTRES)
  else Result := 0;
end;

function TPrinter.GetPageWidth: Integer;
begin
  if fCanvas <> nil then
    Result := GetDeviceCaps(fCanvas.Handle, HORZRES)
  else Result := 0;
end;

procedure TPrinter.NewPage;
begin
  fRec.Top := fMargins.Top;
  fRec.Left := fMargins.Left;
  fRec.Right := GetPageWidth - fMargins.Right;
  fRec.Bottom := GetPageHeight - fMargins.Bottom;
  EndPage(fCanvas.Handle);
  StartPage(fCanvas.Handle);
  SelectObject(fCanvas.Handle, fCanvas.Font.Handle);
  Inc(fPageNumber);
end;

procedure TPrinter.RE_Print(RichEdit: PControl);
var
  Range             : TFormatRange;
  LastChar, MaxLen, LogX, LogY, OldMap: Integer;
  SaveRect          : TRect;
  TextLenEx         : TGetTextLengthEx;
begin
  if IndexOfStr(RichEdit.SubClassName, 'obj_RichEdit') = -1 then Exit;
  FillChar(Range, SizeOf(TFormatRange), 0);
  with Range do begin
    BeginDoc;
    hdc := GetHandle;
    hdcTarget := hdc;
    LogX := GetDeviceCaps(Handle, LOGPIXELSX);
    LogY := GetDeviceCaps(Handle, LOGPIXELSY);
    rc.Top := fMargins.Top * 1440 div LogY;
    rc.Left := fMargins.Left * 1440 div LogX;
    rc.Right := (GetPageWidth - fMargins.Right) * 1440 div LogX;
    rc.Bottom := (GetPageHeight - fMargins.Bottom) * 1440 div LogY;
    rcPage := rc;
    SaveRect := rc;
    LastChar := 0;
    //    if RichEdit.Version >= 2 then begin
    with TextLenEx do begin
      flags := GTL_DEFAULT;
      codepage := CP_ACP;
    end;
    MaxLen := RichEdit.Perform(EM_GETTEXTLENGTHEX, WParam(@TextLenEx), 0);
    //    end
    //    else
    //    MaxLen := Length(RichEdit.RE_Text[ reRTF, True ]);
    chrg.cpMax := -1;
    OldMap := SetMapMode(hdc, MM_TEXT);
    SendMessage(RichEdit.Handle, EM_FORMATRANGE, 0, 0); { flush buffer }
    try
      repeat
        rc := SaveRect;
        chrg.cpMin := LastChar;
        LastChar := SendMessage(RichEdit.Handle, EM_FORMATRANGE, 1, Longint(@Range));
        if (LastChar < MaxLen) and (LastChar <> -1) then NewPage;
      until (LastChar >= MaxLen) or (LastChar = -1);
      EndDoc;
    finally
      SendMessage(RichEdit.Handle, EM_FORMATRANGE, 0, 0); { flush buffer }
      SetMapMode(hdc, OldMap); { restore previous map mode }
    end;
  end;
end;

initialization
  //FPrinter := NewPrinter(nil);

finalization
  Free_And_Nil(FPrinter);
end.