rm_printer.pas

这是一个功能强大

    Inc(P);
  end;
  Str := P;
end;

function RMCopyHandle(aHandle: THandle): THandle;
var
  lpSource, lpDest: PChar;
  llSize: LongInt;
  lHandle: THandle;
begin
  Result := 0;
  if aHandle = 0 then Exit;

  llSize := GlobalSize(aHandle);
  lHandle := GlobalAlloc(GHND, llSize);
  if lHandle <> 0 then
  begin
    try
      lpSource := GlobalLock(aHandle);
      lpDest := GlobalLock(lHandle);
      if (lpSource <> nil) and (lpDest <> nil) then
        Move(lpSource^, lpDest^, llSize);
    finally
      GlobalUnlock(aHandle);
      GlobalUnlock(lHandle);
    end;
  end;
  Result := lHandle;
end;

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

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

  FLock := TCriticalSection.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
  FLock.Acquire;
  try
    FPaperNames.Free;
    FBinNames.Free;
    FBins.Free;
    FPaperWidths.Free;
    FPaperHeights.Free;
    FPaperSizes.Free;

    StrDispose(FDriver);
    StrDispose(FDevice);
    StrDispose(FPort);
  finally
    FLock.Release;
    FLock.Free;
  end;

  inherited Destroy;
end;

{function TRMPrinterInfo.GetCustomPaperSize: Integer;
begin
  FLock.Acquire;
  try
    Result := 256;
    if FPaperSizes.Count > 0 then
      Result := StrToInt(FPaperSizes[FPaperSizes.Count - 1]);
  finally
    FLock.Release;
  end;
end;}

function TRMPrinterInfo.PaperSizesCount: Integer;
begin
  FLock.Acquire;
  try
    Result := FPaperSizes.Count;
  finally
    FLock.Release;
  end;
end;

function DeviceCapabilities; external winspl name 'DeviceCapabilitiesA';
function DeviceCapabilitiesA; external winspl name 'DeviceCapabilitiesA';
function DeviceCapabilitiesW; external winspl name 'DeviceCapabilitiesW';

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

procedure TRMPrinterInfo.GetDeviceCapability(aPrinterCap: TRMPrinterCapType; sl: TStrings);
var
  lResultBuf: PChar;
  lpCurrentItem: Pointer;
  i: Integer;
  lCount: LongInt;
  lItemSize: Word;
  lItem: PChar;
  lpPoint: ^TPoint;
  lpWord: ^Word;
  lCapability: Word;
  lCapStructure: TCapStructure;

  function _GetCapabWinAPI: Boolean;
  begin
    Result := False;
    lResultBuf := nil;
    try
      lCount := DeviceCapabilities(FDevice, FPort, lCapability, nil, nil);
    except
    end;

    if lCount > 0 then
    begin
      GetMem(lResultBuf, (lCount * lItemSize) + 1);
      try
        DeviceCapabilities(FDevice, FPort, lCapability, lResultBuf, nil);
      except
        FreeMem(lResultBuf, (lCount * lItemSize) + 1);
        raise;
      end;
      Result := True;
    end;
  end;

begin
  FLock.Acquire;
  try
    FDeviceHandle := 0;
    sl.Clear;
    case aPrinterCap of
      pcPaperNames:
        begin
          lItemSize := 64;
          lCapability := DC_PAPERNAMES;
          lCapStructure := csString;
        end;
      pcPapers:
        begin
          lItemSize := SizeOf(Word);
          lCapability := dc_Papers;
          lCapStructure := csWord;
        end;
      pcPaperWidths, pcPaperHeights:
        begin
          lItemSize := SizeOf(TPoint);
          lCapability := dc_PaperSize;
          lCapStructure := csPoint;
        end;
      pcBinNames:
        begin
          lItemSize := 24;
          lCapability := DC_BINNAMES;
          lCapStructure := csString;
        end;
      pcBins:
        begin
          lItemSize := SizeOf(Word);
          lCapability := dc_Bins;
          lCapStructure := csWord;
        end;
    else
      Exit;
    end;

    if _GetCapabWinAPI then
    begin
      GetMem(lItem, lItemSize + 1);
      lpCurrentItem := lResultBuf;
      for i := 0 to lCount - 1 do
      begin
        case lCapStructure of
          csString: // papaer names
            begin
              StrLCopy(lItem, lpCurrentItem, lItemSize);
              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 i < lCount - 1 then
          lpCurrentItem := PChar(lpCurrentItem) + lItemSize;
      end;
      FreeMem(lItem, lItemSize + 1);
      FreeMem(lResultBuf, (lCount * lItemSize) + 1);
    end;
  finally
    FLock.Release;
  end;
end;

procedure TRMPrinterInfo.ValidatePaperSizes;
var
  i: integer;
  lstr: string;
  lCustomPos: 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 := RMDefaultPaperInfo[aPaperSize].X;
      Result.Y := RMDefaultPaperInfo[aPaperSize].Y;
    end
    else
    begin
      Result.X := 0; Result.Y := 0;
    end;
  end;

begin
  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
      lstr := PaperSizeToName(StrToInt(FPaperSizes[i]));
      if lstr = cUnknown then
      begin
        if (i < FPaperHeights.Count) and (i < FPaperWidths.Count) then
          lstr := PaperDimensionsToName(StrToInt(FPaperWidths[i]), StrToInt(FPaperHeights[i]))
        else
          lstr := cUnknown + ': ' + FPaperSizes[i];
      end;
      FPaperNames.Add(lstr);
    end;
  end;

  lCustomPos := FPaperSizes.IndexOf('256');
  if lCustomPos < 0 then
  begin
    for i := 0 to FPaperNames.Count - 1 do
    begin
      lstr := UpperCase(FPaperNames[i]);
      if (Pos('CUSTOM',lstr) > 0) or (Pos('USER', lstr) > 0) then
      begin
        lCustomPos := i;
        Break;
      end;
    end;
  end;

  if (lCustomPos >= 0) and (lCustomPos < FPaperNames.Count) then
  begin
    FPaperNames[lCustomPos] := RMLoadStr(SRMCustomPaperSize);
    if lCustomPos = FPaperSizes.Count then
    begin
      FPaperSizes.Add('256');
      FPaperWidths.Add('0'); FPaperHeights.Add('0');
    end;
  end
  else if lCustomPos < 0 then //add custom option
  begin
    lCustomPos := 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 (lCustomPos >= 0) and (lCustomPos < FPaperNames.Count - 1) then //make sure 'Custom' is last in the list
  begin
    FPaperNames.Move(lCustomPos, FPaperNames.Count - 1);
    FPaperSizes.Move(lCustomPos, FPaperSizes.Count - 1);
    FPaperWidths.Move(lCustomPos, FPaperWidths.Count - 1);
    FPaperHeights.Move(lCustomPos, FPaperHeights.Count - 1);
  end;

  FAddinPaperSizeIndex := FPaperNames.Count - 1;
  for i := 0 to FAddInPaperCount - 1 do //增加的纸张类型
  begin
    lstr := RMAddinPaperInfo[i].Name;
    if lstr = '' then
      lstr := RMLoadStr(SPaper800 + i);

    FPaperNames.Insert(FPaperNames.Count - 1, lstr);
    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
  FLock.Acquire;
  try
    if FAlreadlyGetInfo then
      Exit;
    if aVirtualPrinter then
    begin
      FBinNames.Clear; FBins.Clear;
      FPaperNames.Clear; FPaperSizes.Clear;
      FPaperWidths.Clear; FPaperHeights.Clear;
      for i := Low(RMDefaultPaperInfo) to High(RMDefaultPaperInfo) do
      begin
        FPaperNames.Add(RMDefaultPaperInfo[i].Name);
        FPaperSizes.Add(IntToStr(RMDefaultPaperInfo[i].Typ));
        FPaperWidths.Add(IntToStr(RMDefaultPaperInfo[i].X));
        FPaperHeights.Add(IntToStr(RMDefaultPaperInfo[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;
  finally
    FLock.Release;
  end;
end;

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

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

procedure TRMPrinterInfo.SetPaperWidth(index: Integer; Value: Integer);
begin
  FLock.Acquire;
  try
    FPaperWidths[index] := IntToStr(Value);
  finally
    FLock.Release;
  end;
end;

procedure TRMPrinterInfo.SetPaperHeight(index: Integer; Value: Integer);
begin
  FLock.Acquire;
  try
    FPaperHeights[index] := IntToStr(Value);
  finally
    FLock.Release;
  end;