jclprint.pas

East make Tray Icon in delphi

        Result := GetPrinter(hPrinter, 2, nil, 0, @Needed);
        if not Result and ((GetLastError <> ERROR_INSUFFICIENT_BUFFER) or (Needed = 0)) then
          Exit;
        GetMem(PI2, Needed);
        try
          Result := GetPrinter(hPrinter, 2, PI2, Needed, @Needed);
          if Result then
          begin
            PI2^.Attributes := PI2^.Attributes or PRINTER_ATTRIBUTE_DEFAULT;
            Result := SetPrinter(hPrinter, 2, PI2, 0);
            if Result then
              SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0,
                LPARAM(cWindows), SMTO_NORMAL, 1000, Needed);
          end;
        finally
          FreeMem(PI2);
        end;
      finally
        ClosePrinter(hPrinter);
      end;
  end
  else
  // Win NT uses WIN.INI (registry)
  if WinVer in [wvWinNT31, wvWinNT35, wvWinNT351, wvWinNT4] then
  begin
    Result := OpenPrinter(PChar(PrinterName), hPrinter, nil);
    if Result and (hPrinter <> 0) then
      try
        SetLastError(0);
        Result := GetPrinter(hPrinter, 2, nil, 0, @Needed);
        if not Result and ((GetLastError <> ERROR_INSUFFICIENT_BUFFER) or (Needed = 0)) then
          Exit;
        GetMem(PI2, Needed);
        try
          Result := GetPrinter(hPrinter, 2, PI2, Needed, @Needed);
          if Result and (PI2^.pDriverName <> nil) and (PI2^.pPortName <> nil) then
          begin
            PrinterStr := PrinterName + ',' + PI2^.pDriverName + ',' + PI2^.pPortName;
            Result := WriteProfileString(cWindows, cDevice, PChar(PrinterStr));
            if Result then
              SendMessageTimeout(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0,
                SMTO_NORMAL, 1000, Needed);
          end;
        finally
          FreeMem(PI2);
        end;
      finally
        ClosePrinter(hPrinter);
      end;
  end
  else
  // >= Win 2000 uses SetDefaultPrinter
  begin
    hWinSpool := LoadLibrary(cPrintSpool);
    if hWinSpool <> 0 then
      try
        @SetDefPrint := GetProcAddress(hWinSpool, 'SetDefaultPrinterA');
        if Assigned(SetDefPrint) then
          Result := SetDefPrint(PChar(PrinterName));
      finally
        FreeLibrary(hWinSpool);
      end;
  end;
end;

// TJclPrintSet
constructor TJclPrintSet.Create;
begin
  inherited Create;
  FBinArray := nil;
  FPaperArray := nil;
  FPrinter := -99;         { TODO : why -99 }
  GetMem(FDevice, 255);
  GetMem(FDriver, 255);
  GetMem(FPort, 255);
end;

destructor TJclPrintSet.Destroy;
begin
  if FBinArray <> nil then
    FreeMem(FBinArray, FNumBins * SizeOf(Word));
  if FPaperArray <> nil then
    FreeMem(FPaperArray, FNumPapers * SizeOf(Word));
  if FDevice <> nil then
    FreeMem(FDevice, 255);
  if FDriver <> nil then
    FreeMem(FDriver, 255);
  if FPort <> nil then
    FreeMem(FPort, 255);
  inherited Destroy;
end;

procedure TJclPrintSet.CheckPrinter;
begin
  if FPrinter <> Printer.PrinterIndex then
  begin
    Printer.GetPrinter(FDevice, FDriver, FPort, FHandle);
    Printer.SetPrinter(FDevice, FDriver, FPort, FHandle);
    SetDeviceMode(False);
  end;
end;

procedure TJclPrintSet.SetBinArray;
var
  NumBinsRec: Integer;
begin
  if FBinArray <> nil then
    FreeMem(FBinArray, FNumBins * SizeOf(Word));
  FBinArray := nil;
  FNumBins := DeviceCapabilities(FDevice, FPort, DC_Bins, nil, FDeviceMode);
  if FNumBins > 0 then
  begin
    GetMem(FBinArray, FNumBins * SizeOf(Word));
    NumBinsRec := DeviceCapabilities(FDevice, FPort, DC_Bins,
      PChar(FBinArray), FDeviceMode);
    if NumBinsRec <> FNumBins then
      raise EJclPrinterError.CreateRes(@RsRetrievingSource);
  end;
end;

procedure TJclPrintSet.SetPaperArray;
var
  NumPapersRec: Integer;
begin
  if FPaperArray <> nil then
    FreeMem(FPaperArray, FNumPapers * SizeOf(Word));
  FNumPapers := DeviceCapabilities(FDevice, FPort, DC_Papers, nil, FDeviceMode);
  if FNumPapers > 0 then
  begin
    GetMem(FPaperArray, FNumPapers * SizeOf(Word));
    NumPapersRec := DeviceCapabilities(FDevice, FPort, DC_Papers,
      PChar(FPaperArray), FDeviceMode);
    if NumPapersRec <> FNumPapers then
      raise EJclPrinterError.CreateRes(@RsRetrievingPaperSource);
  end
  else
    FPaperArray := nil;
end;

{ TODO : complete this list }
// Since Win32 the strings are stored in the printer driver, no chance to get
// a list from Windows
function TJclPrintSet.DefaultPaperName(const PaperID: Word): string;
begin
  case PaperID of
    dmpaper_Letter:
      Result := RsPSLetter;
    dmpaper_LetterSmall:
      Result := RsPSLetter;
    dmpaper_Tabloid:
      Result := RsPSTabloid;
    dmpaper_Ledger:
      Result := RsPSLedger;
    dmpaper_Legal:
      Result := RsPSLegal;
    dmpaper_Statement:
      Result := RsPSStatement;
    dmpaper_Executive:
      Result := RsPSExecutive;
    dmpaper_A3:
      Result := RsPSA3;
    dmpaper_A4:
      Result := RsPSA4;
    dmpaper_A4Small:
      Result := RsPSA4;
    dmpaper_A5:
      Result := RsPSA5;
    dmpaper_B4:
      Result := RsPSB4;
    dmpaper_B5:
      Result := RsPSB5;
    dmpaper_Folio:
      Result := RsPSFolio;
    dmpaper_Quarto:
      Result := RsPSQuarto;
    dmpaper_10X14:
      Result := RsPS10x14;
    dmpaper_11X17:
      Result := RsPS11x17;
    dmpaper_Note:
      Result := RsPSNote;
    dmpaper_Env_9:
      Result := RsPSEnv9;
    dmpaper_Env_10:
      Result := RsPSEnv10;
    dmpaper_Env_11:
      Result := RsPSEnv11;
    dmpaper_Env_12:
      Result := RsPSEnv12;
    dmpaper_Env_14:
      Result := RsPSEnv14;
    dmpaper_CSheet:
      Result := RsPSCSheet;
    dmpaper_DSheet:
      Result := RsPSDSheet;
    dmpaper_ESheet:
      Result := RsPSESheet;
    dmpaper_User:
      Result := RsPSUser;
  else
    Result := RsPSUnknown;
  end;
end;

{$IFNDEF DROP_OBSOLETE_CODE}
function TJclPrintSet.GetBinSourceList: TStringList;
begin
  Result := TStringList.Create;
  try
    GetBinSourceList(Result);
  except
    FreeAndNil(Result);
    raise;
  end;
end;
{$ENDIF ~DROP_OBSOLETE_CODE}

procedure TJclPrintSet.GetBinSourceList(List: TStrings);
type
  TBinName = array [0..CCHBinName - 1] of Char;
  TBinArray = array [1..cBinMax] of TBinName;
  PBinArray = ^TBinArray;
var
  NumBinsRec: Integer;
  BinArray: PBinArray;
  BinStr: string;
  Idx: Integer;
begin
  CheckPrinter;
  BinArray := nil;
  if FNumBins = 0 then
    Exit;
  List.BeginUpdate;
  try
    GetMem(BinArray, FNumBins * SizeOf(TBinName));
    List.Clear;
    NumBinsRec := DeviceCapabilities(FDevice, FPort, DC_BinNames,
      PChar(BinArray), FDeviceMode);
    if NumBinsRec <> FNumBins then
      raise EJclPrinterError.CreateRes(@RsRetrievingSource);
    for Idx := 1 to NumBinsRec do
    begin
      BinStr := StrPas(BinArray^[Idx]);
      List.Add(BinStr);
    end;
  finally
    List.EndUpdate;
    if BinArray <> nil then
      FreeMem(BinArray, FNumBins * SizeOf(TBinName));
  end;
end;

{$IFNDEF DROP_OBSOLETE_CODE}
function TJclPrintSet.GetPaperList: TStringList;
begin
  Result := TStringList.Create;
  try
    GetPaperList(Result);
  except
    FreeAndNil(Result);
    raise;
  end;
end;
{$ENDIF ~DROP_OBSOLETE_CODE}

procedure TJclPrintSet.GetPaperList(List: TStrings);
type
  TPaperName = array [0..CCHPaperName - 1] of Char;
  TPaperArray = array [1..cPaperNames] of TPaperName;
  PPaperArray = ^TPaperArray;
var
  NumPaperRec: Integer;
  PaperArray: PPaperArray;
  PaperStr: string;
  Idx: Integer;
begin
  CheckPrinter;
  PaperArray := nil;
  if FNumPapers = 0 then
    Exit;
  List.BeginUpdate;
  List.Clear;
  try
    GetMem(PaperArray, FNumPapers * SizeOf(TPaperName));
    NumPaperRec := DeviceCapabilities(FDevice, FPort, DC_PaperNames,
      PChar(PaperArray), FDeviceMode);
    if NumPaperRec <> FNumPapers then
    begin
      for Idx := 1 to FNumPapers do
      begin
        PaperStr := DefaultPaperName(FPaperArray^[Idx - 1]);
        List.Add(PaperStr);
      end;
    end
    else
    begin
      for Idx := 1 to NumPaperRec do
      begin
        PaperStr := StrPas(PaperArray^[Idx]);
        List.Add(PaperStr);
      end;
    end;
  finally
    List.EndUpdate;
    if PaperArray <> nil then
      FreeMem(PaperArray, FNumPapers * SizeOf(TPaperName));
  end;
end;

procedure TJclPrintSet.SetDeviceMode(Creating: Boolean);
var
  Res: TPoint;
begin
  Printer.GetPrinter(FDevice, FDriver, FPort, FHandle);
  if FHandle = 0 then
  begin
    Printer.PrinterIndex := Printer.PrinterIndex;
    Printer.GetPrinter(FDevice, FDriver, FPort, FHandle);
  end;
  if FHandle <> 0 then
  begin
    FDeviceMode := GlobalLock(FHandle);
    FPrinter := Printer.PrinterIndex;
    FDeviceMode^.dmFields := dm_Orientation or dm_PaperSize or
      dm_PaperLength or dm_PaperWidth or
      dm_Scale or dm_Copies or
      dm_DefaultSource or dm_PrintQuality or
      dm_Color or dm_Duplex or
      dm_YResolution or dm_TTOption;
    UpdateDeviceMode;
    FDeviceMode^.dmFields := 0;
    SetBinArray;
    SetPaperArray;
  end
  else
  begin
    FDeviceMode := nil;
    if not Creating then
      raise EJclPrinterError.CreateRes(@RsDeviceMode);
    FPrinter := -99;
  end;
  Res := GetPrinterResolution;
  dpiX := Res.X;
  dpiY := Res.Y;
  if FHandle <> 0 then
    GlobalUnLock(FHandle);
end;

procedure TJclPrintSet.UpdateDeviceMode;
var
  DrvHandle: THandle;
  ExtDevCode: Integer;
begin
  CheckPrinter;      
  if OpenPrinter(FDevice, DrvHandle, nil) then
  try
    FDeviceMode^.dmFields := dm_Orientation or dm_PaperSize or
      dm_PaperLength or dm_PaperWidth or
      dm_Scale or dm_Copies or
      dm_DefaultSource or dm_PrintQuality or
      dm_Color or dm_Duplex or
      dm_YResolution or dm_TTOption;
    ExtDevCode := DocumentProperties(0, DrvHandle, FDevice,
      FDeviceMode^, FDeviceMode^,
      DM_IN_BUFFER or DM_OUT_BUFFER);
    if ExtDevCode <> IDOK then
      raise EJclPrinterError.CreateRes(@RsUpdatingPrinter);
  finally
    ClosePrinter(DrvHandle);
  end;
end;

procedure TJclPrintSet.SaveToDefaults;
var
  DrvHandle: THandle;
  ExtDevCode: Integer;
begin
  CheckPrinter;
  OpenPrinter(FDevice, DrvHandle, nil);
  ExtDevCode := DocumentProperties(0, DrvHandle, FDevice,
    FDeviceMode^, FDeviceMode^, DM_IN_BUFFER or DM_UPDATE);
  if ExtDevCode <> IDOK then
    raise EJclPrinterError.CreateRes(@RsUpdatingPrinter)
  else
    SendMessage(HWND_BROADCAST, WM_SETTINGCHANGE, 0, 0);
  ClosePrinter(DrvHandle);
end;

procedure TJclPrintSet.SavePrinterAsDefault;
begin
  CheckPrinter;
  DPSetDefaultPrinter(FDevice);
end;

procedure TJclPrintSet.ResetPrinterDialogs;
begin
  Printer.GetPrinter(FDevice, FDriver, FPort, FHandle);
  Printer.SetPrinter(FDevice, FDriver, FPort, FHandle);
  SetDeviceMode(False);
end;

function TJclPrintSet.XInchToDot(const Inches: Double): Integer;
begin
  Result := Trunc(DpiX * Inches);
end;

function TJclPrintSet.YInchToDot(const Inches: Double): Integer;
begin
  Result := Trunc(DpiY * Inches);
end;

function TJclPrintSet.XCmToDot(const Cm: Double): Integer;