rm_prntr.pas

report machine 2.3 功能强大

var
  I: Integer;
  ByteCnt, StructCnt: DWORD;
  DefaultPrinter: array[0..79] of Char;
  Cur, lDevice: PChar;
  PrinterInfo: PPrinterInfo5;
begin
  FDefaultPrinterIndex := -1;
  ByteCnt := 0; StructCnt := 0;
  if not EnumPrinters(PRINTER_ENUM_DEFAULT, nil, 5, nil, 0, ByteCnt, StructCnt) and
    (GetLastError <> ERROR_INSUFFICIENT_BUFFER) then
    Exit;

  PrinterInfo := AllocMem(ByteCnt);
  try
    EnumPrinters(PRINTER_ENUM_DEFAULT, nil, 5, PrinterInfo, ByteCnt, ByteCnt, StructCnt);
    if StructCnt > 0 then
      lDevice := PrinterInfo.pPrinterName
    else
    begin
      GetProfileString('windows', 'device', '', DefaultPrinter, SizeOf(DefaultPrinter) - 1);
      Cur := DefaultPrinter;
      lDevice := FetchStr(Cur);
    end;
    with FPrinters do
    begin
      for i := 0 to Count - 1 do
      begin
        if string(TRMPrinterInfo(Objects[i]).Device) = lDevice then
        begin
          FDefaultPrinterIndex := i;
          Exit;
        end;
      end;
    end;
  finally
    FreeMem(PrinterInfo);
  end;
end;

procedure TRMPrinterList.BuildPrinterList;
var
  LineCur, Port: PChar;
  Buffer, PrinterInfo: PChar;
  Flags, Count, NumInfo: DWORD;
  I: Integer;
  Level: Byte;
  tmp: TRMPrinterInfo;
  str: string;
begin
  FreePrinterList; FPrinters.Clear;
  if Win32Platform = VER_PLATFORM_WIN32_NT then
  begin
    Flags := PRINTER_ENUM_CONNECTIONS or PRINTER_ENUM_LOCAL;
    Level := 4;
  end
  else
  begin
    Flags := PRINTER_ENUM_LOCAL;
    Level := 5;
  end;
  Count := 0;
  EnumPrinters(Flags, nil, Level, nil, 0, Count, NumInfo);
  if Count > 0 then
  begin
    GetMem(Buffer, Count);
    try
      if not EnumPrinters(Flags, nil, Level, PByte(Buffer), Count, Count, NumInfo) then
        Exit;
      PrinterInfo := Buffer;
      for I := 0 to NumInfo - 1 do
      begin
        if Level = 4 then
        begin
          with PPrinterInfo4(PrinterInfo)^ do
          begin
            tmp := TRMPrinterInfo.Create(nil, pPrinterName, nil);
            FPrinters.AddObject(pPrinterName, tmp);
            Inc(PrinterInfo, sizeof(TPrinterInfo4));
          end;
        end
        else
        begin
          with PPrinterInfo5(PrinterInfo)^ do
          begin
            LineCur := pPortName;
            Port := FetchStr(LineCur);
            while Port^ <> #0 do
            begin
              str := Format(SDeviceOnPort, [pPrinterName, Port]);
              tmp := TRMPrinterInfo.Create(nil, pPrinterName, Port);
              FPrinters.AddObject(str, tmp);
              Port := FetchStr(LineCur);
            end;
            Inc(PrinterInfo, sizeof(TPrinterInfo5));
          end;
        end;
      end;
    finally
      FreeMem(Buffer, Count);
    end;
  end;
  tmp := TRMPrinterInfo.Create(nil, PChar(RMLoadStr(SDefaultPrinter)), nil);
  FPrinters.InsertObject(0, RMLoadStr(SDefaultPrinter), tmp);
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;

  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;
  inherited Destroy;
end;

procedure TRMCustomPrinter.BeginDoc;
var
  lDocInfo: TDocInfo;
begin
  if FPrinting then Exit;
  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);
end;

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

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

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

procedure TRMCustomPrinter.ResetDC;
var
  lNewDC: HDC;
begin
  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;
end;

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

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

procedure TRMCustomPrinter.GetDevMode(var aDevMode: THandle);
begin
  aDevMode := RMCopyHandle(GetDocumentProperties);
end;

function TRMCustomPrinter.GetDocumentProperties: THandle;
var
  lStubDevMode: TDeviceMode;
  lPrinterInfo: TRMPrinterInfo;
begin
  Result := 0;
  if FDevMode = 0 then
  begin
    lPrinterInfo := RMPrinters.PrinterInfo[FPrinterIndex];
    if lPrinterInfo = nil then Exit;
    FDevMode := GlobalAlloc(GHND,
      DocumentProperties(0, PrinterHandle, lPrinterInfo.Device, lStubDevMode, lStubDevMode, 0));
    if FDevMode <> 0 then
    begin
      FPDevMode := GlobalLock(FDevMode);
      if DocumentProperties(0, PrinterHandle, lPrinterInfo.Device, FPDevMode^, FPDevMode^, DM_OUT_BUFFER) >= 0 then
      begin
        FDefaultBin := FPDevMode^.dmDefaultSource;
      end
      else
        FreeDevMode;
    end;
  end;
  Result := FDevMode;
end;

function TRMCustomPrinter.GetPDevMode: PDevMode;
begin
  GetDocumentProperties;
  Result := FPDevMode;
end;

function TRMCustomPrinter.GetDC: HDC;
var
  lPrinterInfo: TRMPrinterInfo;
begin
  if FDC = 0 then
  begin
    lPrinterInfo := RMPrinters.PrinterInfo[FPrinterIndex];
    if (lPrinterInfo <> nil) and lPrinterInfo.IsValid then
    begin
      if FPrinting then
        FDC := CreateDC(lPrinterInfo.Driver, lPrinterInfo.Device, lPrinterInfo.Port, GetPDevMode)
      else
        FDC := CreateIC(lPrinterInfo.Driver, lPrinterInfo.Device, lPrinterInfo.Port, GetPDevMode);

      if FDC = 0 then
        lPrinterInfo.IsValid := False;

      if FCanvas <> nil then
        FCanvas.Handle := FDC;

      DeviceContextChanged;
    end;
  end;
  Result := FDC;
end;

function TRMCustomPrinter.GetPrinterInfo: TRMPrinterInfo;
begin
  Result := RMPrinters.PrinterInfo[FPrinterIndex]
end;

procedure TRMCustomPrinter.FreeDC;
begin
  if FDC = 0 then Exit;
  if FCanvas <> nil then
    FCanvas.Handle := 0;
  DeleteDC(FDC);
  FDC := 0;
end;

procedure TRMCustomPrinter.FreeDevMode;
begin
  if FDevMode = 0 then Exit;
  GlobalUnlock(FDevMode);
  GlobalFree(FDevMode);
  FDevMode := 0;
  FPDevMode := nil;
end;

procedure TRMCustomPrinter.FreePrinterHandle;
begin
  if FPrinterHandle <> 0 then
  begin
    ClosePrinter(FPrinterHandle);
    FPrinterHandle := 0;
    FCurrentInfo := nil;
  end;
end;

procedure TRMCustomPrinter.FreePrinterResources;
begin
  if FPrinting then Exit;
  FreeDC;
  FreeDevMode;
  FreePrinterHandle;
end;

function TRMCustomPrinter.GetCanvas: TCanvas;
begin
  if FCanvas = nil then
    FCanvas := TRMPrinterCanvas.Create(Self);
  Result := FCanvas;
end;

procedure TRMCustomPrinter.SetDevMode(aDevMode: THandle);
begin
  if FPrinting then
    FResetDC := True
  else
    FreeDC;

  FreeDevMode;
  FDevMode := RMCopyHandle(aDevMode);
  FPDevMode := GlobalLock(FDevMode);
end;

procedure TRMCustomPrinter.SetPrinterIndex(Value: Integer);
var
  lPrinterInfo: TRMPrinterInfo;
  SaveWidth, SaveHeight: Integer;
  i, count: Integer;
begin
  if FPrinting or (Value < 0) or (FPrinterIndex = Value) then Exit;

  FreeDC;
  lPrinterInfo := RMPrinters.PrinterInfo[Value];
  if lPrinterInfo <> nil then
    FPrinterIndex := Value;
  if (lPrinterInfo = nil) or (FCurrentInfo = lPrinterInfo) then Exit;

  SaveWidth := -1; SaveHeight := -1;
  try
    if FCurrentInfo <> nil then
    begin
      with PrinterInfo do
      begin
        i := GetPaperSizeIndex(Self.PaperSize);
        SaveWidth := PaperWidths[i];
        SaveHeight := PaperHeights[i];
      end;
    end;
  except
  end;

  if FCurrentInfo <> nil then
    FreePrinterResources;
  FCurrentInfo := lPrinterInfo;

  if (SaveWidth > 0) and (SaveHeight > 0) then
  begin
    i := 0; count := FCurrentInfo.PaperSizesCount;
    with FCurrentInfo do
    begin
      while i < count do
      begin
        try
          if (abs(PaperWidths[i] - SaveWidth) <= 1) and (abs(PaperHeights[i] - SaveHeight) <= 1) then
            Break;
        except
        end;
        Inc(i);
      end;
      if i < count then
        Self.PaperSize := StrToInt(FPaperSizes[i])
      else
        Self.PaperSize := 256;
//	  SetPrinterInfo(PaperSize, SaveWidth, SaveHeight, Bin, Orientation, TRUE);
    end;
  end;
end;

function TRMCustomPrinter.HasColor: Boolean;
begin
  Result := (GetDeviceCaps(GetDC, NUMCOLORS) > 2) and (GetPDevMode^.dmColor = DMCOLOR_COLOR);