rm_printer.pas

这是一个功能强大

end;

function TRMPrinterInfo.GetPaperSize(index: Integer): Integer;
begin
  FLock.Acquire;
  try
    Result := StrToInt(FPaperSizes[index]);
  finally
    FLock.Release;
  end;
end;

function TRMPrinterInfo.GetBin(index: Integer): Integer;
begin
  FLock.Acquire;
  try
    Result := 0;
    if index < FBins.Count then
      Result := StrToInt(FBins[index]);
  finally
    FLock.Release;
  end;
end;

function TRMPrinterInfo.GetPaperSizeIndex(pgSize: Integer): Integer;
begin
  FLock.Acquire;
  try
    Result := FPaperSizes.IndexOf(IntToStr(pgSize));
    if Result < 0 then
      Result := FPaperSizes.Count - 1; //Result := 0;
  finally
    FLock.Release;
  end;
end;

function TRMPrinterInfo.GetBinIndex(pgBin: Integer): Integer;
begin
  FLock.Acquire;
  try
    Result := FBins.IndexOf(IntToStr(pgBin));
    if Result < 0 then
      Result := 0;
  finally
    FLock.Release;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMPrinterList}

constructor TRMPrinterList.Create;
begin
  inherited Create;

  FLock := TCriticalSection.Create;

  FPrinters := TStringList.Create;
  BuildPrinterList;
  GetDefaultPrinter;
end;

destructor TRMPrinterList.Destroy;
begin
  FLock.Acquire;
  try
    FreePrinterList;
    FPrinters.Free;
  finally
    FLock.Release;
    FLock.Free;
  end;
  inherited Destroy;
end;

procedure TRMPrinterList.FreePrinterList;
var
  i: Integer;
begin
  for i := 0 to FPrinters.Count - 1 do
  begin
    FPrinters.Objects[i].Free;
    FPrinters.Objects[i] := nil;
  end;
end;

function TRMPrinterList.GetCount: Integer;
begin
  FLock.Acquire;
  try
    Result := FPrinters.Count;
  finally
    FLock.Release;
  end;
end;

function TRMPrinterList.GetPrinterInfo(Index: Integer): TRMPrinterInfo;
begin
  FLock.Acquire;
  try
    if Index = 0 then
      Index := FDefaultPrinterIndex;

    Result := TRMPrinterInfo(FPrinters.Objects[index]);
    if not Result.FAlreadlyGetInfo then
      Result.GetPrinterCaps(Index = 1);
  finally
    FLock.Release;
  end;
end;

procedure TRMPrinterList.Refresh;
begin
  FLock.Acquire;
  try
    BuildPrinterList;
  finally
    FLock.Release;
  end;
end;

procedure TRMPrinterList.GetDefaultPrinter;
var
  I: Integer;
  lByteCnt, lStructCnt: DWORD;
  lDefaultPrinter: array[0..79] of Char;
  lCur, lDevice: PChar;
  lPrinterInfo: PPrinterInfo5;
begin
  FLock.Acquire;
  try
    FDefaultPrinterIndex := 1;
    lByteCnt := 0; lStructCnt := 0;
    if not EnumPrinters(PRINTER_ENUM_DEFAULT, nil, 5, nil, 0, lByteCnt, lStructCnt) and
      (GetLastError <> ERROR_INSUFFICIENT_BUFFER) then
      Exit;

    lPrinterInfo := AllocMem(lByteCnt);
    try
      EnumPrinters(PRINTER_ENUM_DEFAULT, nil, 5, lPrinterInfo, lByteCnt, lByteCnt, lStructCnt);
      if lStructCnt > 0 then
        lDevice := lPrinterInfo.pPrinterName
      else
      begin
        GetProfileString('windows', 'device', '', lDefaultPrinter, SizeOf(lDefaultPrinter) - 1);
        lCur := lDefaultPrinter;
        lDevice := FetchStr(lCur);
      end;
      with FPrinters do
      begin
        for i := 0 to Count - 1 do
        begin
          if string(TRMPrinterInfo(Objects[i]).Device) = lDevice then
          begin
            FDefaultPrinterIndex := i;
            Break;
          end;
        end;
      end;
    finally
      FreeMem(lPrinterInfo);
    end;
  finally
    FLock.Release;
  end;
end;

procedure TRMPrinterList.BuildPrinterList;
var
  lLineCur, lPort: PChar;
  lBuffer, lPrinterInfo: PChar;
  lFlags, lCount, lNumInfo: DWORD;
  I: Integer;
  lLevel: Byte;
  tmp: TRMPrinterInfo;
  lStr: string;
begin
  FLock.Acquire;
  try
    FreePrinterList; FPrinters.Clear;
    if Win32Platform = VER_PLATFORM_WIN32_NT then
    begin
      lFlags := PRINTER_ENUM_CONNECTIONS or PRINTER_ENUM_LOCAL;
      lLevel := 4;
    end
    else
    begin
      lFlags := PRINTER_ENUM_LOCAL;
      lLevel := 5;
    end;
    
    lCount := 0;
    EnumPrinters(lFlags, nil, lLevel, nil, 0, lCount, lNumInfo);
    if lCount > 0 then
    begin
      GetMem(lBuffer, lCount);
      try
        if not EnumPrinters(lFlags, nil, lLevel, PByte(lBuffer), lCount, lCount, lNumInfo) then
          Exit;

        lPrinterInfo := lBuffer;
        for I := 0 to lNumInfo - 1 do
        begin
          if lLevel = 4 then
          begin
            with PPrinterInfo4(lPrinterInfo)^ do
            begin
              tmp := TRMPrinterInfo.Create(nil, pPrinterName, nil);
              FPrinters.AddObject(pPrinterName, tmp);
              Inc(lPrinterInfo, sizeof(TPrinterInfo4));
            end;
          end
          else
          begin
            with PPrinterInfo5(lPrinterInfo)^ do
            begin
              lLineCur := pPortName;
              lPort := FetchStr(lLineCur);
              while lPort^ <> #0 do
              begin
                lStr := Format(SDeviceOnPort, [pPrinterName, lPort]);
                tmp := TRMPrinterInfo.Create(nil, pPrinterName, lPort);
                FPrinters.AddObject(lStr, tmp);
                lPort := FetchStr(lLineCur);
              end;
              
              Inc(lPrinterInfo, sizeof(TPrinterInfo5));
            end;
          end;
        end;
      finally
        FreeMem(lBuffer, lCount);
      end;
    end;

    tmp := TRMPrinterInfo.Create(nil, PChar(RMLoadStr(SDefaultPrinter)), nil);
    FPrinters.InsertObject(0, RMLoadStr(SDefaultPrinter), tmp);
    
    tmp := TRMPrinterInfo.Create(nil, PChar(RMLoadStr(SVirtualPrinter)), nil); // 虚拟打印机
    FPrinters.InsertObject(1, RMLoadStr(SVirtualPrinter), tmp);
  finally
    FLock.Release;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TRMPrinterCanvas }
type
  TRMPrinterCanvas = class(TCanvas)
  private
    FPrinter: TRMCustomPrinter;
  public
    constructor Create(aPrinter: TRMCustomPrinter);
    procedure CreateHandle; override;
    procedure Changing; override;
    procedure UpdateDeviceContext;
  end;

constructor TRMPrinterCanvas.Create(aPrinter: TRMCustomPrinter);
begin
  inherited Create;
  FPrinter := aPrinter;
end;

procedure TRMPrinterCanvas.CreateHandle;
begin
  UpdateDeviceContext;
  Handle := FPrinter.DC;
end;

procedure TRMPrinterCanvas.Changing;
begin
  inherited Changing;
  UpdateDeviceContext;
end;

procedure TRMPrinterCanvas.UpdateDeviceContext;
var
  lFontSize: Integer;
begin
  if FPrinter = nil then
    Exit;
  if FPrinter.PixelsPerInch.Y <> Font.PixelsPerInch then
  begin
    lFontSize := Font.Size;
    Font.PixelsPerInch := FPrinter.PixelsPerInch.Y;
    Font.Size := lFontSize;
  end;

  if not FPrinter.CanGrayScale then
  begin
    if (Font.Color <> clBlack) and (Font.Color <> clWhite) then
      Font.Color := clBlack;
  end;
end;


{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TRMCustomPrinter }

constructor TRMCustomPrinter.Create;
begin
  inherited Create;

  FLock := TCriticalSection.Create;

  FAborted := False;
  FPageNumber := 0;
  FPrinting := False;
  FDocumentName := '';
  FFileName := '';
  FDC := 0;
  FDevMode := 0;
  FPrinterHandle := 0;
  FResetDC := False;
  FCanvas := nil;
  FCurrentInfo := nil;
  FPDevMode := nil;
end;

destructor TRMCustomPrinter.Destroy;
begin
  FreePrinterResources;
  FCanvas.Free;
  FLock.Free;

  inherited Destroy;
end;

procedure TRMCustomPrinter.BeginDoc;
var
  lDocInfo: TDocInfo;
begin
  if FPrinting then
    Exit;

  FLock.Acquire;
  try
    FPrinting := True;
    FAborted := False;
    FPageNumber := 0;
    FStartPage := False;

    FreeDC;
    ResetDC;

    FillChar(lDocInfo, SizeOf(lDocInfo), 0);
    lDocInfo.cbSize := SizeOf(lDocInfo);
    lDocInfo.lpszDocName := PChar(FDocumentName);
    if FFileName <> '' then
      lDocInfo.lpszOutput := PChar(FFileName);
    Windows.StartDoc(FDC, lDocInfo);
  finally
    FLock.Release;
  end;
end;

procedure TRMCustomPrinter.Abort;
begin
  if not FPrinting then
    Exit;
  FLock.Acquire;
  try
    Windows.AbortDoc(Canvas.Handle);
    FAborted := True;
    EndDoc;
  finally
    FLock.Release;
  end;
end;

procedure TRMCustomPrinter.EndDoc;
begin
  FLock.Acquire;
  try
    if not FPrinting then
      Exit;
    EndPage;
    if not FAborted then
      Windows.EndDoc(FDC);
    FreeDC;
    FPrinting := False;
    FStartPage := False;
    FAborted := False;
    FPageNumber := 0;
  finally
    FLock.Release;
  end;
end;

procedure TRMCustomPrinter.NewPage;
begin
  FLock.Acquire;
  try
    if not FPrinting or FStartPage then
      Exit;
    FStartPage := True;
    if FResetDC then
      ResetDC;
    Windows.StartPage(FDC);
    Inc(FPageNumber);
    Canvas.Refresh;
  finally
    Flock.Release;
  end;
end;

procedure TRMCustomPrinter.ResetDC;
var
  lNewDC: HDC;
begin
  FLock.Acquire;
  try
    if not FPrinting then Exit;

    FResetDC := False;
    Canvas.Refresh;
    if FDC <> 0 then
    begin
      lNewDC := Windows.ResetDC(FDC, FPDevMode^);
      if lNewDC <> 0 then
        FDC := lNewDC;
    end;
    DeviceContextChanged;
    TRMPrinterCanvas(Canvas).UpdateDeviceContext;
  finally
    FLock.Release;
  end;
end;

procedure TRMCustomPrinter.EndPage;
begin
  FLock.Acquire;
  try
    if (not FPrinting) or (not FStartPage) then
      Exit;
    FStartPage := False;
    Windows.EndPage(FDC);
  finally
    FLock.Release;
  end;
end;

function TRMCustomPrinter.GetPrinterHandle: THandle;
begin
  FLock.Acquire;
  try
    if FPrinterHandle = 0 then
    begin
      FCurrentInfo := RMPrinters.PrinterInfo[FPrinterIndex];
      if FCurrentInfo <> nil then
        OpenPrinter(FCurrentInfo.Device, FPrinterHandle, nil);
    end;
    Result := FPrinterHandle;
  finally
    Flock.Release;
  end;
end;

procedure TRMCustomPrinter.GetDevMode(var aDevMode: THandle);
begin
  FLock.Acquire;
  try
    aDevMode := RMCopyHandle(GetDocumentProperties);
  finally