rm_prntr.pas

report machine 2.3 功能强大

{------------------------------------------------------------------------------}
{TRMPrinterInfo}

constructor TRMPrinterInfo.Create(aDriver, aDevice, aPort: PChar);
begin
  inherited Create;

  FIsValid := True;
  FAlreadlyGetInfo := FALSE;

  FPaperNames := TStringList.Create;
  FBinNames := TStringList.Create;
  FBins := TStringList.Create;
  FPaperWidths := TStringList.Create;
  FPaperHeights := TStringList.Create;
  FPaperSizes := TStringList.Create;

  FDriver := StrNew(ADriver);
  FDevice := StrNew(ADevice);
  FPort := StrNew(APort);
  if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion < 4) then
  begin
    if FDriver = nil then FDriver := StrAlloc(1);
    if FDevice = nil then FDevice := StrAlloc(1);
    if FPort = nil then FPort := StrAlloc(1);
  end;
end;

destructor TRMPrinterInfo.Destroy;
begin
  FPaperNames.Free;
  FBinNames.Free;
  FBins.Free;
  FPaperWidths.Free;
  FPaperHeights.Free;
  FPaperSizes.Free;

  StrDispose(FDriver);
  StrDispose(FDevice);
  StrDispose(FPort);

  inherited Destroy;
end;

function TRMPrinterInfo.GetCustomPaperSize: Integer;
begin
  Result := 256;
  if FPaperSizes.Count > 0 then
    Result := StrToInt(FPaperSizes[FPaperSizes.Count - 1]);
end;

function TRMPrinterInfo.PaperSizesCount: Integer;
begin
  Result := FPaperSizes.Count;
end;

type
  TCapStructure = (csString, csWord, csPoint, csInteger);

procedure TRMPrinterInfo.GetDeviceCapability(aPrinterCap: TRMPrinterCapType; sl: TStrings);
var
  lResultBuf: PChar;
  lpCurrentItem: Pointer;
  liItem: Integer;
  llItems: LongInt;
  lwItemSize: Word;
  lItem: PChar;
  lpPoint: ^TPoint;
  lpWord: ^Word;
  lwCapability: Word;
  lCapStructure: TCapStructure;

  function GetCapabWinAPI: Boolean;
  begin
    Result := False; lResultBuf := nil;
    try
      llItems := DeviceCapabilities(FDevice, FPort, lwCapability, lResultBuf, nil);
    except
    end;
    if llItems > 0 then
    begin
      GetMem(lResultBuf, ((llItems * lwItemSize) + 1));
      try
        DeviceCapabilities(FDevice, FPort, lwCapability, lResultBuf, nil);
      except
        FreeMem(lResultBuf, ((llItems * lwItemSize) + 1));
        raise;
      end;
      Result := True;
    end;
  end;

begin
  FDeviceHandle := 0;
  sl.Clear;
  case aPrinterCap of
    pcPaperNames:
      begin
        lwItemSize := 64;
        lwCapability := 16;
        lCapStructure := csString;
      end;
    pcPapers:
      begin
        lwItemSize := SizeOf(Word);
        lwCapability := dc_Papers;
        lCapStructure := csWord;
      end;
    pcPaperWidths, pcPaperHeights:
      begin
        lwItemSize := SizeOf(TPoint);
        lwCapability := dc_PaperSize;
        lCapStructure := csPoint;
      end;
    pcBinNames:
      begin
        lwItemSize := 24;
        lwCapability := 12;
        lCapStructure := csString;
      end;
    pcBins:
      begin
        lwItemSize := SizeOf(Word);
        lwCapability := dc_Bins;
        lCapStructure := csWord;
      end;
  else
    Exit;
  end;

  if GetCapabWinAPI then
  begin
    GetMem(lItem, lwItemSize + 1);
    lpCurrentItem := lResultBuf;
    for liItem := 0 to llItems - 1 do
    begin
      case lCapStructure of
        csString: // papaer names
          begin
            StrLCopy(lItem, lpCurrentItem, lwItemSize);
            sl.Add(StrPas(lItem));
          end;
        csWord:
          begin
            lpWord := lpCurrentItem;
            sl.Add(IntToStr(lpWord^));
          end;
        csPoint:
          begin
            lpPoint := lpCurrentItem;
            if aPrinterCap = pcPaperWidths then
              sl.Add(IntToStr(lpPoint^.X))
            else
              sl.Add(IntToStr(lpPoint^.Y));
          end;
      end;
      if liItem < (llItems - 1) then
        lpCurrentItem := PChar(lpCurrentItem) + lwItemSize;
    end;
    FreeMem(lItem, lwItemSize + 1);
    FreeMem(lResultBuf, ((llItems * lwItemSize) + 1));
  end;
end;

procedure TRMPrinterInfo.ValidatePaperSizes;
var
  i: integer;
  str: string;
  CustomPos: Integer;
  lPointPaperSize: TPoint;

  function PaperSizeToName(aIndex: Word): string;
  begin
    Result := cUnknown;
    if aIndex < PAPERCOUNT then
      Result := RMLoadStr(SPaper1 + aIndex)
    else if aIndex = DMPAPER_USER then
      Result := RMLoadStr(SRMCustomPaperSize);
  end;

  function PaperDimensionsToName(aWidth, aHeight: Integer): string;
  begin
    Result := IntToStr(aWidth div 10) + ' x ' + IntToStr(aHeight div 10) + ' mm';
  end;

  function PaperSizeToDimensions(aPaperSize: Word): TPoint;
  begin
    if aPaperSize < PAPERCOUNT then
    begin
      Result.X := PaperInfo[aPaperSize].X;
      Result.Y := PaperInfo[aPaperSize].Y;
    end
    else
    begin
      Result.X := 0; Result.Y := 0;
    end;
  end;

begin
  FCustomPageSize := 256;
  if FPaperNames.Count > FPaperSizes.Count then
  begin
    for i := FPaperNames.Count - 1 downto FPaperSizes.Count do
      FPaperNames.Delete(i);
  end
  else if FPaperNames.Count < FPaperSizes.Count then
  begin
    FPaperNames.Clear;
    for i := 0 to FPaperSizes.Count - 1 do
    begin
      str := PaperSizeToName(StrToInt(FPaperSizes[i]));
      if str = cUnknown then
      begin
        if (i < FPaperHeights.Count) and (i < FPaperWidths.Count) then
          str := PaperDimensionsToName(StrToInt(FPaperWidths[i]), StrToInt(FPaperHeights[i]))
        else
          str := cUnknown + ': ' + FPaperSizes[i];
      end;
      FPaperNames.Add(str);
    end;
  end;

  CustomPos := FPaperSizes.IndexOf('256');
  if CustomPos < 0 then
  begin
    i := 0;
    while (CustomPos < 0) and (i < FPaperNames.Count) do
    begin
      str := UpperCase(FPaperNames[i]);
      if (Pos('CUSTOM', str) > 0) or (Pos('USER', str) > 0) then
        CustomPos := i
      else
        Inc(i);
    end;
  end;

  if (CustomPos >= 0) and (CustomPos < FPaperNames.Count) then
  begin
    FPaperNames[CustomPos] := RMLoadStr(SRMCustomPaperSize);
    FCustomPageSize := StrToInt(FPaperSizes[CustomPos]);
    if CustomPos = FPaperSizes.Count then
    begin
      FCustomPageSize := 256;
      FPaperSizes.Add('256');
      FPaperWidths.Add('0'); FPaperHeights.Add('0');
    end;
  end
  else if CustomPos < 0 then //add custom option
  begin
    CustomPos := FPaperNames.Add(RMLoadStr(SRMCustomPaperSize));
    FPaperSizes.Add('256');
    FPaperWidths.Add('0'); FPaperHeights.Add('0');
  end;

  //note: some print drivers do not return Width & Height of PaperSizes (just the "PaperSize: Word" value
 //check the paper widths & heights
  for i := 0 to FPaperSizes.Count - 1 do
  begin
    if (i > FPaperWidths.Count - 1) or (i > FPaperHeights.Count - 1) then
    begin
      lPointPaperSize := PaperSizeToDimensions(StrToInt(FPaperSizes[i]));
      if i > FPaperWidths.Count - 1 then
        FPaperWidths.Add(IntToStr(lPointPaperSize.X))
      else
        FPaperWidths[i] := IntToStr(lPointPaperSize.X);
      if i > FPaperHeights.Count - 1 then
        FPaperHeights.Add(IntToStr(lPointPaperSize.Y))
      else
        FPaperHeights[i] := IntToStr(lPointPaperSize.Y);
    end;
  end;

  for i := FPaperSizes.Count - 1 downto 0 do //remove any unsupported paper sizes
  begin
    if FPaperNames[i] = RMLoadStr(SRMCustomPaperSize) then Continue;
    if (FPaperWidths[i] = '0') or (FPaperHeights[i] = '0') then
    begin
      FPaperSizes.Delete(i);
      FPaperWidths.Delete(i);
      FPaperHeights.Delete(i);
      if i < FPaperNames.Count then
        FPaperNames.Delete(i);
    end;
  end;

  if (CustomPos >= 0) and (CustomPos < FPaperNames.Count - 1) then //make sure 'Custom' is last in the list
  begin
    FPaperNames.Move(CustomPos, FPaperNames.Count - 1);
    FPaperSizes.Move(CustomPos, FPaperSizes.Count - 1);
    FPaperWidths.Move(CustomPos, FPaperWidths.Count - 1);
    FPaperHeights.Move(CustomPos, FPaperHeights.Count - 1);
  end;

  FAddinPaperSizeIndex := FPaperNames.Count - 1;
  for i := Low(RMAddinPaperInfo) to High(RMAddinPaperInfo) do //增加的纸张类型
  begin
    FPaperNames.Insert(FPaperNames.Count - 1, RMLoadStr(SPaper800 + i));
    FPaperSizes.Insert(FPaperSizes.Count - 1, IntToStr(RMAddinPaperInfo[i].Typ));
    FPaperWidths.Insert(FPaperWidths.Count - 1, IntToStr(RMAddinPaperInfo[i].X));
    FPaperHeights.Insert(FPaperHeights.Count - 1, IntToStr(RMAddinPaperInfo[i].Y));
  end;
end;

procedure TRMPrinterInfo.ValidatePaperBins;
var
  i: Integer;
begin
  if FBinNames.Count > FBins.Count then
  begin
    for i := FBinNames.Count - 1 downto FBins.Count do
      FBinNames.Delete(i)
  end
  else if FBinNames.Count < FBins.Count then
  begin
    for i := FBins.Count - 1 downto FBinNames.Count do
      FBins.Delete(i);
  end;

  i := FBinNames.IndexOf(RMLoadStr(SDefaultBin));
  if i < 0 then
  begin
    FBinNames.Insert(0, RMLoadStr(SDefaultBin));
    FBins.Insert(0, IntToStr($FFFF));
  end;
end;

procedure TRMPrinterInfo.GetPrinterCaps(aVirtualPrinter: Boolean);
var
  i: Integer;
begin
  if FAlreadlyGetInfo then Exit;
  if aVirtualPrinter then
  begin
    FBinNames.Clear; FBins.Clear;
    FPaperNames.Clear; FPaperSizes.Clear;
    FPaperWidths.Clear; FPaperHeights.Clear;
    for i := Low(PaperInfo) to High(PaperInfo) do
    begin
      FPaperNames.Add(PaperInfo[i].Name);
      FPaperSizes.Add(IntToStr(PaperInfo[i].Typ));
      FPaperWidths.Add(IntToStr(PaperInfo[i].X));
      FPaperHeights.Add(IntToStr(PaperInfo[i].Y));
    end;
  end
  else
  begin
    GetDeviceCapability(pcPaperNames, FPaperNames);
    GetDeviceCapability(pcPapers, FPaperSizes);
    GetDeviceCapability(pcPaperWidths, FPaperWidths);
    GetDeviceCapability(pcPaperHeights, FPaperHeights);
    GetDeviceCapability(pcBinNames, FBinNames);
    GetDeviceCapability(pcBins, FBins);
  end;
  ValidatePaperSizes;
  ValidatePaperBins;
  FAlreadlyGetInfo := TRUE;
end;

function TRMPrinterInfo.GetPaperWidth(index: Integer): Integer;
begin
  Result := StrToInt(FPaperWidths[index]);
end;

function TRMPrinterInfo.GetPaperHeight(index: Integer): Integer;
begin
  Result := StrToInt(FPaperHeights[index]);
end;

procedure TRMPrinterInfo.SetPaperWidth(index: Integer; Value: Integer);
begin
  FPaperWidths[index] := IntToStr(Value);
end;

procedure TRMPrinterInfo.SetPaperHeight(index: Integer; Value: Integer);
begin
  FPaperHeights[index] := IntToStr(Value);
end;

function TRMPrinterInfo.GetPaperSize(index: Integer): Integer;
begin
  Result := StrToInt(FPaperSizes[index]);
end;

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

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

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

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

constructor TRMPrinterList.Create;
begin
  inherited Create;

  FDefaultPrinterIndex := -1;
  FPrinters := TStringList.Create;
  BuildPrinterList;
  GetDefaultPrinter;
end;

destructor TRMPrinterList.Destroy;
begin
  FreePrinterList;
  FPrinters.Free;
  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
  Result := FPrinters.Count;
end;

function TRMPrinterList.GetPrinterInfo(index: Integer): TRMPrinterInfo;
begin
  if (index = 0) and (FDefaultPrinterIndex >= 0) then index := FDefaultPrinterIndex;
  Result := TRMPrinterInfo(FPrinters.Objects[index]);
  if not Result.FAlreadlyGetInfo then
    Result.GetPrinterCaps(FDefaultPrinterIndex < 0);
end;

procedure TRMPrinterList.Refresh;
begin
  BuildPrinterList;
end;

procedure TRMPrinterList.GetDefaultPrinter;