PrintToFile, Version 1.3b (alt)
Hinweis: dies ist nicht die neueste Version!
Datei: PrintToFile.pas
{ PrintToFile.pas Delphi unit giving the ability to directly specify the filename for printing when the "Print to file" option is checked, bypassing the query where to save the file. See the included README.txt for more information and how to use it. Version 1.3 - Always find the most current version at http://flocke.vssd.de/prog/code/pascal/prt2file/ Copyright (C) 2005, 2006 Volker Siebert <flocke@vssd.de> All rights reserved. Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. } unit PrintToFile; interface {$IFDEF VER130} const {$ELSE} var {$ENDIF} // Set this variable to the output filename before you start printing. // It will be reset to empty each time it has been used. PrintToThisFile: string = ''; function Patch_TPrinter_BeginDoc: boolean; function Patch_StartDoc_ImportTable: boolean; function Patch_StartDoc_DLL_Entry: boolean; function SendFileToPrinter(const Filename: string; const Docname: string = ''): boolean; implementation uses Windows, WinSpool, SysUtils, Printers, CodeLen, GenCodeHook; type TfnStartDoc = function(DC: HDC; const p2: TDocInfo): Integer; stdcall; var PrintToFilePossible: boolean = false; fnStartDoc: TfnStartDoc = nil; { Our replacement for the Windows StartDoc function. - If "PrintToThisFile" is not empty, redirect the output to this file by setting the "lpszOutput" member of the TDocInfo structure. - Otherwise, the call is just passed on to "Windows.StartDoc". } function MyStartDoc(DC: HDC; const p2: TDocInfo): Integer; stdcall; var p2new: TDocInfo; begin if PrintToThisFile <> '' then begin p2new := p2; p2new.lpszOutput := PChar(PrintToThisFile); PrintToThisFile := ''; Result := fnStartDoc(DC, p2new); end else Result := fnStartDoc(DC, p2); end; { Read the relative address at "Where" } function GetDisplacement(Where: pointer): pointer; begin Result := pointer(integer(Where) + 4 + PInteger(Where)^); end; { Calculate the relative displacement between "Source" and "Target" } function CalcDisplacement(Source, Target: pointer): integer; begin Result := integer(Target) - (integer(Source) + 4); end; { This function steps through the code of Printer.BeginDoc and tries to find the call to Windows.StartDoc. The found location is then patched to point to our replacement function above. An exception is raised when the hook can not be established. } function Patch_TPrinter_BeginDoc: boolean; var Code: pointer; Size, Len: integer; begin Result := PrintToFilePossible; if PrintToFilePossible then exit; fnStartDoc := GetProcAddress(GetModuleHandle('user32.dll'), 'StartDocA'); if not Assigned(fnStartDoc) then exit; Code := @TPrinter.BeginDoc; Size := 1024; while true do begin if IsReturnInstruction(Code, Size) then break; Len := GetCpuInstructionLength(Code, Size); if Len < 1 then break; if Len = 5 then // $E8 is the opcode of a direct call instruction if PByte(Code)^ = $E8 then begin inc(integer(Code)); dec(Size); dec(Len); if GetDisplacement(Code) = @Windows.StartDoc then begin Len := CalcDisplacement(Code, @MyStartDoc); if PatchMemory(Code, Len, 4) then PrintToFilePossible := true; break; end; end; inc(integer(Code), Len); dec(Size, Len); end;; Result := PrintToFilePossible; end; { This function patches the entry of Windows.StartDoc in the import table and thus goes a step farther than the function above. It can be used with *ANY* printing component you link to your project, not just those using TPrinter. } function Patch_StartDoc_ImportTable: boolean; var Code: pointer; Target: integer; begin Result := PrintToFilePossible; if PrintToFilePossible then exit; Code := @Windows.StartDoc; // FF 25 mm mm mm mm = JMP [mem32] if (PByte(Code)^ = $FF) and (PByte(integer(Code) + 1)^ = $25) then begin inc(integer(Code), 2); Code := Pointer(PInteger(Code)^); fnStartDoc := TfnStartDoc(PInteger(Code)^); Target := integer(@MyStartDoc); PrintToFilePossible := PatchMemory(Code, Target, 4); end // E9 dd dd dd dd = JMP disp32 else if PByte(Code)^ = $E9 then begin inc(integer(Code)); fnStartDoc := GetDisplacement(Code); Target := CalcDisplacement(Code, @MyStartDoc); PrintToFilePossible := PatchMemory(Code, Target, 4); end; Result := PrintToFilePossible; end; { This function patches the API entry point of Windows.StartDoc directly in the DLL code, thus going one more step farther than the two functions above. This can be used with *ANY* print component or DLL you use, even if it uses GetProcAddress to obtain the entry point. } function Patch_StartDoc_DLL_Entry: boolean; var Code: pointer; begin Result := PrintToFilePossible; if PrintToFilePossible then exit; try Code := GetProcAddress(GetModuleHandle('gdi32.dll'), 'StartDocA'); if Code = nil then exit; CreateGenericCodeHook(Code, @MyStartDoc, @fnStartDoc); PrintToFilePossible := true; except end; Result := PrintToFilePossible; end; { This function returns the device name of the currently selected printer (Delphi's "Printer" object). } function GetPrinterDeviceName: string; var szDevice, szDriver, szPort: array [0 .. 1023] of char; hDevMode: THandle; begin Printer.GetPrinter(szDevice, szDriver, szPort, hDevMode); Result := StrPas(szDevice); end; { This function sends the given file to the currently selected printer (Delphi's "Printer" object). } function SendFileToPrinter(const Filename: string; const Docname: string = ''): boolean; var hPrinter, hFile: THandle; Info: TDocInfo1; Buffer: array [0 .. 4095] of char; NumBytes: cardinal; begin Result := false; if not OpenPrinter(PChar(GetPrinterDeviceName), hPrinter, nil) then exit; try if Docname <> '' then Info.pDocName := PChar(Docname) else Info.pDocName := PChar(Filename); Info.pOutputFile := nil; Info.pDatatype := nil; if StartDocPrinter(hPrinter, 1, @Info) = 0 then begin RaiseLastOsError; exit; end; try if not StartPagePrinter(hPrinter) then exit; try hFile := CreateFile(PChar(Filename), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_FLAG_SEQUENTIAL_SCAN, 0); if hFile = INVALID_HANDLE_VALUE then exit; try repeat if not ReadFile(hFile, Buffer, SizeOf(Buffer), NumBytes, nil) then exit; if NumBytes > 0 then if not WritePrinter(hPrinter, @Buffer[0], NumBytes, NumBytes) then exit; until NumBytes = 0; Result := true; finally CloseHandle(hFile); end; finally EndPagePrinter(hPrinter); end; finally EndDocPrinter(hPrinter); end; finally ClosePrinter(hPrinter); end; end; end. |