Checking Printer Messages using OPOS Drivers in Delphi - delphi

I'm trying to open a Point of Sale (POS) printer using the OPOS Drivers in Delphi (BDS2006), but don't have a clue on how to check the printer status.
How would I check for messages like Check Paper and Paper Jam from the printer?

I haven't used OPOS Drivers but I have done some work with POS Drivers for an Epson receipt printer connected to a cash drawer. What I discovered was that, if the printer is installed in Windows, you can then open a direct connection to it and make it do whatever you want.
The reason the printer is so slow is that it's using the graphical font functions of Windows. When you open the printer directly, you will set the mode to RAW and it will just send text out like an old-style dot-matrix. To kick the cash drawer open, you just send it the specific control codes as if you were going to print them. The printer intercepts the codes before it prints and kicks the drawer open.
BTW, I have no idea how this would work with Unicode. The printer I had only really worked with ASCII data. There might be variants designed for international markets that would work differently.
Here's the code I've used to make it work (VxMsgBox is just a cover to MessageBox):
{***************************************************************************}
{** PrintDirect2Printer **}
{***************************************************************************}
procedure PrintDirect2Printer(PrinterName, Data:pchar; dwByteCount:DWORD);
var PrinterHandle : THandle;
DocInfo : TDocInfo1;
dwJob : DWORD;
dwBytesWritten : DWORD;
begin
if not OpenPrinter(PrinterName, PrinterHandle, nil) then exit; //failed to open printer, abort
DocInfo.pDocName := 'Direct 2 Printer';
DocInfo.pOutputFile := nil;
DocInfo.pDataType := 'RAW';
dwJob:=StartDocPrinter(PrinterHandle, 1, #DocInfo);
if dwJob=0 then //failed to start a document
begin
ClosePrinter(PrinterHandle);
exit;
end;
if not StartPagePrinter(PrinterHandle) then
begin
EndDocPrinter(PrinterHandle);
ClosePrinter(PrinterHandle);
exit;
end;
if not WritePrinter(PrinterHandle, Data, dwByteCount, dwBytesWritten) then
begin
EndPagePrinter(PrinterHandle);
EndDocPrinter(PrinterHandle);
ClosePrinter(PrinterHandle);
exit;
end;
if not EndPagePrinter(PrinterHandle) then
begin
EndDocPrinter(PrinterHandle);
ClosePrinter(PrinterHandle);
exit;
end;
if not EndDocPrinter(PrinterHandle) then
begin
ClosePrinter(PrinterHandle);
exit;
end;
ClosePrinter(PrinterHandle);
if dwBytesWritten<>dwByteCount then
VxMsgBox('Print Direct To Printer failed.', 'Printer Error', mb_Ok);
end;
{***************************************************************************}
{** OpenPrintDirect2Printer **}
{***************************************************************************}
function OpenPrintDirect2Printer(PrinterName, DocName:pchar; var PrinterHandle:THandle):boolean;
var DocInfo : TDocInfo1;
dwJob : DWORD;
begin
result:=false;
if not OpenPrinter(PrinterName, PrinterHandle, nil) then exit; //failed to open printer, abort
DocInfo.pDocName := DocName;
DocInfo.pOutputFile := nil;
DocInfo.pDataType := 'RAW';
dwJob:=StartDocPrinter(PrinterHandle, 1, #DocInfo);
if dwJob=0 then //failed to start a document
begin
ClosePrinter(PrinterHandle);
exit;
end;
if not StartPagePrinter(PrinterHandle) then
begin
EndDocPrinter(PrinterHandle);
ClosePrinter(PrinterHandle);
exit;
end;
result:=true;
end;
{***************************************************************************}
{** WritePrintDirect2Printer **}
{***************************************************************************}
function WritePrintDirect2Printer(PrinterHandle:THandle; Data:pchar; dwByteCount:DWORD):boolean;
var dwBytesWritten : DWORD;
begin
result:=true;
if not WritePrinter(PrinterHandle, Data, dwByteCount, dwBytesWritten) then
result:=false;
if dwBytesWritten<>dwByteCount then
VxMsgBox('WritePrintDirect2Printer byte check failed.', 'Printer Error', mb_Ok);
end;
{***************************************************************************}
{** ClosePrintDirect2Printer **}
{***************************************************************************}
procedure ClosePrintDirect2Printer(var PrinterHandle:THandle);
begin
if not EndPagePrinter(PrinterHandle) then
begin
EndDocPrinter(PrinterHandle);
ClosePrinter(PrinterHandle);
PrinterHandle:=0;
exit;
end;
if not EndDocPrinter(PrinterHandle) then
begin
ClosePrinter(PrinterHandle);
PrinterHandle:=0;
exit;
end;
ClosePrinter(PrinterHandle);
PrinterHandle:=0;
end;

Are you using the ActiveX control from here: http://monroecs.com/oposccos.htm? It has an event for error status.

First of all you have to install the right support software for your device, which you probably have to download from the manufacturer's website. Keep in mind that sometimes, many devices (like receipt printers) contain standard hardware (ex EPSON TX-88III) although the brand name might differ.
The support software usually contains the driver, configuration tools, and possibly programming examples of how to use the driver. Make sure that the following steps are correctly completed:
Installation of driver, config tools is done
The device is correctly connected using the right cables (I had problems finding the correct serial cable, since there are many different types of them)
Your device is recognised by the configuration software (through the driver) and communicates well, at least it responds to some functions
Use the ActiveX control that was installed with the driver. It should have similar name with the driver.
After the above steps you will have a control in your application that provides you with all available functions, status properties and events (for paper, or anything other).

Related

Non overlapped Serial Port hangs at CloseHandle

I wrote a serial port class that I developed and for simplicity I used blocking/synchronous/non-overlapped. I went through all MSDN documentations and it was strait forward for me.
I don't have any problem with Opening, Transmitting or Receiving Bytes from the port. All operations are synchronous and there is no-threading complexity.
function TSerialPort.Open: Boolean;
var
h: THandle;
port_timeouts: TCommTimeouts;
dcb: TDCB;
begin
Result := False;
if Assigned(FHandleStream) then
begin
// already open
Exit(True);
end;
h := CreateFile(PChar('\\?\' + FComPort),
GENERIC_WRITE or GENERIC_READ, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
// RaiseLastOSError();
if h <> INVALID_HANDLE_VALUE then
begin
{
REMARKS at https://learn.microsoft.com/en-us/windows/desktop/api/winbase/ns-winbase-_commtimeouts
If an application sets ReadIntervalTimeout and ReadTotalTimeoutMultiplier to MAXDWORD and
sets ReadTotalTimeoutConstant to a value greater than zero and less than MAXDWORD, one
of the following occurs when the ReadFile function is called:
* If there are any bytes in the input buffer, ReadFile returns immediately with the bytes in the buffer.
* If there are no bytes in the input buffer, ReadFile waits until a byte arrives and then returns immediately.
* If no bytes arrive within the time specified by ReadTotalTimeoutConstant, ReadFile times out.
}
FillChar(port_timeouts, Sizeof(port_timeouts), 0);
port_timeouts.ReadIntervalTimeout := MAXDWORD;
port_timeouts.ReadTotalTimeoutMultiplier := MAXDWORD;
port_timeouts.ReadTotalTimeoutConstant := 50; // in ms
port_timeouts.WriteTotalTimeoutConstant := 2000; // in ms
if SetCommTimeOuts(h, port_timeouts) then
begin
FillChar(dcb, Sizeof(dcb), 0);
dcb.DCBlength := sizeof(dcb);
if GetCommState(h, dcb) then
begin
dcb.BaudRate := FBaudRate; // baud rate
dcb.ByteSize := StrToIntDef(FFrameType.Chars[0], 8); // data size
dcb.StopBits := ONESTOPBIT; // 1 stop bit
dcb.Parity := NOPARITY;
case FFrameType.ToUpper.Chars[1] of
'E': dcb.Parity := EVENPARITY;
'O': dcb.Parity := ODDPARITY;
end;
dcb.Flags := dcb_Binary or dcb_Parity or dcb_ErrorChar or
(DTR_CONTROL_ENABLE shl 4) or (RTS_CONTROL_ENABLE shl 12);
dcb.ErrorChar := '?'; // parity error will be replaced with this char
if SetCommState(h, dcb) then
begin
FHandleStream := THandleStream.Create(h);
Result := True;
end;
end;
end;
if not Result then
begin
CloseHandle(h);
end;
end;
end;
function TSerialPort.Transmit(const s: TBytes): Boolean;
var
len: NativeInt;
begin
Result := False;
len := Length(s);
if Assigned(FHandleStream) and (len > 0) then
begin
// total timeout to transmit is 2sec!!
Result := (FHandleStream.Write(s, Length(s)) = len);
end;
end;
function TSerialPort.Receive(var r: Byte): Boolean;
begin
Result := False;
if Assigned(FHandleStream) then
begin
// read timeout is 50ms
Result := (FHandleStream.Read(r, 1) = 1);
end;
end;
My problem starts at closing the port.
After all my communications, when I try to close the serial port, my Application totally hangs at CloseHandle() API. And that happens randomly. Which is meaningless to me since I use synchronous mode, there can not be any pending operations. When I request a close, It must simply close the handle.
I searched the problem on the google and stack-overflow. There are many people who faced the similar problems but most of them are related with .NET serial port driver and their asynchronous mode operations which I don't have.
And also some people forgot to set timeouts properly and they faced blocking issue at ReadFile and WriteFile API that is fully normal. But again this is not my problem, I've set CommTimeouts as it is indicated in MSDN remarks.
function TSerialPort.Close: Boolean;
var
h: THandle;
begin
Result := True;
if Assigned(FHandleStream) then
begin
h := FHandleStream.Handle;
FreeAndNil(FHandleStream);
if h <> INVALID_HANDLE_VALUE then
begin
//PurgeComm(h, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR); // didn't help
//ClearCommError(h, PDWORD(nil)^, nil); // didn't help
//CancelIO(h); // didn't help
Result := CloseHandle(h); <------------ hangs here
end;
end;
end;
Some people on Microsoft forum, suggest calling CloseHandle() in different thread. I have tried that as well. But that time it hangs while trying to free AnonymousThread that I created. Even I left FreeOnTerminate:=true as default, it hangs and I get memory leakage report by Delphi.
Another bothering problem when it hangs, I have to close Delphi IDE fully and reopen. Otherwise I can't compile the code again since exe is still used.
function TSerialPort.Close: Boolean;
var
h: THandle;
t: TThread;
Event: TEvent;
begin
Result := True;
if Assigned(FHandleStream) then
begin
h := FHandleStream.Handle;
FreeAndNil(FHandleStream);
if h <> INVALID_HANDLE_VALUE then
begin
PurgeComm(h, PURGE_TXABORT or PURGE_RXABORT or PURGE_TXCLEAR or PURGE_RXCLEAR);
Event := TEvent.Create(nil, False, False, 'COM PORT CLOSE');
t := TThread.CreateAnonymousThread(
procedure()
begin
CloseHandle(h);
If Assigned(Event) then Event.SetEvent();
end);
t.FreeOnTerminate := False;
t.Start;
Event.WaitFor(1000);
FreeAndNil(t); // <---------- that time it hangs here, why??!!
FreeAndNil(Event);
end;
end;
end;
In my notebook I'm using USB to Serial Port converters from FTDI. Some people said that it is because of FTDI driver. But I'm using all microsoft drivers that is signed by Microsoft Windows Hardware Compatibility Publisher. There is no third party driver in my system. But when I disconnect the USB adapter, CloseHandle API unfreeze itself. Some people reports that, even native Serial Ports that are build in their motherboards have same issue.
So far I couldn't solve the problem. Any help or workaround highly appreciated.
Thanks.
This issue is with the FTDI USB-Serial converter driver. It doesn't handle the hardware flow control properly and on occasion will hang in CloseHandle call.
To get around the issue, implement hardware flow control manually. In C++ (not sure how it would be done in Delphi) set up these DCB structure fields in order to allow manual control of the RTS line:
// Assuming these variables are defined in the header
HANDLE m_hComm; // Comm port handle.
DCB m_dcb; // DCB comm port settings.
// Put these settings in the DCB structure.
m_dcb.fRtsControl = RTS_CONTROL_ENABLE;
m_dcb.fOutxCtsFlow = TRUE;
Then use
EscapeCommFunction(m_hComm, CLRRTS); // Call this before calling WriteFile.
And
EscapeCommFunction(m_hComm, SETRTS); // Call this after Write is complete.
In your case, because its synchronous - you can just wrap every call to WriteFile with these 2 calls. If using asynchronous (like in my case), call the one with SETRTS after you get the completion event from the ovelapped structure in your WriteFile call.
Used to freeze all the time before we implemented this as we were using 12 serial ports, and only way to unlock the port would be restarting the computer.
Now works like a charm with manual control, hasn't frozen once since.
One thing to keep in mind, some USB-Serial devices (or even different versions of FTDI) may invert the RTS line! So if the above doesn't work, try using SETRTS to set the line low and CLRRTS to set it high.
Edit: If you have access to a Windows XP machine, use portmon tool to see what is happening with the RTS line, this way you will know if it is inverted or not or if it is getting the commands at all.

Delphi Check for Default Printer Failing

I use the code below to prevent an exception when someone tries to print but doesn't have a default printer set. I've gotten a report from a user using the software remotely with citrix who has a network printer as the default printer. It raises an exception at the call to GetPrinter with the message "There is no default printer currently selected". They have no problems printing from other applications. What would be going wrong here?
function CheckForDefaultPrinter: boolean;
var
FDevice: PChar;
FDriver: PChar;
FPort: PChar;
FHandle: THandle;
CurrentPrinterName: string;
begin
//ensure default printer selected - bypass printer.pas bug
Printer.PrinterIndex := Printer.PrinterIndex;
GetMem (FDevice, 255);
GetMem (FDriver, 255);
GetMem (FPort, 255);
try
try
Printers.Printer.GetPrinter(FDevice, FDriver, FPort, FHandle);
except
on E:Exception do
ShowMessage(E.Message);
end;
CurrentPrinterName := FDevice;
finally
if FDevice <> nil then FreeMem (FDevice, 255);
if FDriver <> nil then FreeMem (FDriver, 255);
if FPort <> nil then FreeMem (FPort, 255);
end;
if CurrentPrinterName = '' then
begin
MessageDlg('You do not have a default printer defined.' +
#13#13 + 'Please select a printer before running a report.'+
#13#13 + 'Or the default printer name is blank. Please assign the printer a name.',
mtError,[mbOK],0);
Result:= False;
end
else
Result:= True;
end;
The error occurs before the code you posted can check it, because it fails during the first access to Printer.
You should use the WinAPI GetDefaultPrinter function directly instead to see if a default printer exists, before attempting to use the global Printer. Here's a sample console application (which utilizes an easier declaration of the function than the one contained in recent versions of Delphi) to demonstrate how to do so. The sample was compiled in XE 10 Seattle and tested on Windows 7 64-bit.
program Project1;
{$APPTYPE CONSOLE}
uses
System.SysUtils, WinAPI.Windows;
function GetDefaultPrinter(Buffer: PChar; var BufferSize: DWord): BOOL; stdcall;
external 'winspool.drv' name 'GetDefaultPrinterW'; // GetDefaultPrinterA on pre-Unicode Delphi versions
var
Buff: string;
BuffSize, Err: DWord;
begin
// Get size of buffer needed.
GetDefaultPrinter(nil, BuffSize);
SetLength(Buff, BuffSize);
// If this call fails, and GetLastError returns
// ERROR_FILE_NOT_FOUND, there is no default printer assigned.
if GetDefaultPrinter(PChar(Buff), BuffSize) then
WriteLn('Default printer: ', Buff)
else
begin
Err := GetLastError();
if Err = ERROR_FILE_NOT_FOUND then
WriteLn('No default printer assigned')
else
WriteLn('Failed. Error: ', Err);
end;
ReadLn;
end.
Note that the return value includes the terminating NULL (#0) according to the documentation. To remove it, simply SetLength(Buff, Length(Buff) - 1) after the call to GetDefaultPrinter returns.
On Windows you can assume that if there is more than 0 (zero) printers then there is a default printer.
This assmption is safe except if your application is running as a service.
So all you need is this:
if (Printer.Printers.Count=0) then
ShowMessage('Please install a printer before attempting to print.');
You need to make this check before you access most other properties/methods on the Printer object.
If your application is running as a service there will be no default printer. Here PrinterIndex will be -1 until you assign a value in code.
I tested your code with Delphi XE6, Win7Pro. Just changed a line
GetMem (FPort, 255);
try
try
Printer.GetPrinter(FDevice, FDriver, FPort, FHandle); // HERE
except
on E:Exception do
ShowMessage(E.Message);
end;
It works with a networked printer as default, even with cable unplugged.

Serial (COM) ports name or identification

I've a program that access multiple serial ports using cport.
To configure, till now I simply listed all available comports in a combobox to make a selection, but the increasing number of drivers with (virtual) serial interfaces makes configuring for end-users troublesome.
The current detection works with createfile(), but that has the problem that you only get exists/nonexists and maybe "busy" as information.
However to improve, I need per COM port a identification string, like the hardware device/driver (device manager) it is connected too. This would make it easier for the user to narrow the comports down (since we deliver a finite number of serial cards)
Probably it is available from WMI, but that's quite a jungle, does sb have more concrete information, or better, code?
(Delphi XE3, Win7+, no solution that requires additional installing or deployment please)
If you want enumerate the COM ports getting a friendly name you can use the SetupAPI and the GUID_DEVINTERFACE_COMPORT device interface class.
Try this sample
{$APPTYPE CONSOLE}
{$R *.res}
uses
Windows,
SysUtils,
JvSetupApi;
const
GUID_DEVINTERFACE_COMPORT:TGUID='{86E0D1E0-8089-11D0-9CE4-08003E301F73}';
procedure EnumerateCOMPorts;
var
cbRequired : DWORD;
hdev : HDEVINFO;
idev : Integer;
did : TSPDeviceInterfaceData;
pdidd : PSPDeviceInterfaceDetailData;
PropertyBuffer : array[0..255] of Char;
DeviceInfoData: TSPDevInfoData;
PropertyRegDataType: DWORD;
RequiredSize: DWORD;
begin
// enumerate the com ports
hdev := SetupDiGetClassDevs(#GUID_DEVINTERFACE_COMPORT, nil, 0, DIGCF_PRESENT OR DIGCF_DEVICEINTERFACE);
if ( INVALID_HANDLE_VALUE <> THandle(hdev) ) then
begin
try
idev:=0;
ZeroMemory(#did, SizeOf(did));
did.cbSize := SizeOf(did);
repeat
if (SetupDiEnumDeviceInterfaces(hdev, nil, GUID_DEVINTERFACE_COMPORT, idev, did)) then
begin
cbRequired := 0;
SetupDiGetDeviceInterfaceDetail(hdev, #did, nil, 0, cbRequired, nil);
if (ERROR_INSUFFICIENT_BUFFER= GetLastError()) then
begin
pdidd:=AllocMem(cbRequired);
try
pdidd.cbSize := SizeOf(TSPDeviceInterfaceDetailData);
DeviceInfoData.cbSize:= SizeOf(DeviceInfoData);
RequiredSize:=0;
if (SetupDiGetDeviceInterfaceDetail(hdev, #did, pdidd, cbRequired, RequiredSize, #DeviceInfoData)) then
begin
PropertyRegDataType:=0;
RequiredSize:=0;
if SetupDiGetDeviceRegistryProperty(hdev, DeviceInfoData, SPDRP_FRIENDLYNAME, PropertyRegDataType, PBYTE(#PropertyBuffer[0]), SizeOf(PropertyBuffer), RequiredSize) then
Writeln(Format('Friendly Name - %s',[PropertyBuffer]));
if SetupDiGetDeviceRegistryProperty(hdev, DeviceInfoData, SPDRP_DEVICEDESC, PropertyRegDataType, PBYTE(#PropertyBuffer[0]), SizeOf(PropertyBuffer), RequiredSize) then
Writeln(Format('Description - %s',[PropertyBuffer]));
if SetupDiGetDeviceRegistryProperty(hdev, DeviceInfoData, SPDRP_LOCATION_INFORMATION, PropertyRegDataType, PBYTE(#PropertyBuffer[0]), SizeOf(PropertyBuffer), RequiredSize) then
Writeln(Format('Location - %s',[PropertyBuffer]));
end
else
RaiseLastOSError;
finally
FreeMem(pdidd);
end;
end;
end
else
Break;
inc(idev);
until false;
finally
SetupDiDestroyDeviceInfoList(hdev);
end;
end;
end;
begin
try
if not LoadsetupAPI then exit;
EnumerateCOMPorts;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
readln;
end.
This will return something like so
Note : The JvSetupApi unit is part of the JVCL library.
You can use HKEY_LOCAL_MACHINE \HARDWARE\DEVICEMAP\SERIALCOMM for COMxx style short names. Keep remember specify read only access to avoid Admin rights / UAC necessity. You can see both usb232 adapters and real comm ports.
You can also chek HKEY_LOCAL_MACHINE \SYSTEM\CurrentControlSet\Enum\Root\PORTS but it seems a bit tricky.

How to set the paper size using the WinSpool API?

I can't use the XPS API since the program has to be able to print on Windows XP.
I'm trying to set the paper size from Letter to A4 using WinSpool.
This is my test code:
var
H : THandle;
I : TBytes;
Info : PPrinterInfo2;
NeededSize : DWORD;
DevMode : PDeviceMode;
PD : TPrinterDefaults;
begin
PD.pDatatype := nil;
PD.pDevMode := nil;
PD.DesiredAccess := PRINTER_ACCESS_ADMINISTER;
if not OpenPrinter('Brother HL-5350DN series Printer', H, #PD) then begin
raise Exception.Create('OpenPrinter error: ' + SysErrorMessage(GetLastError));
end;
try
Assert(not GetPrinter(H, 2, nil, 0, #NeededSize));
SetLength(I, NeededSize);
Info := #I[0];
if not GetPrinter(H, 2, Info, NeededSize, #NeededSize) then begin
raise Exception.Create('GetPrinter error: ' + SysErrorMessage(GetLastError));
end;
DevMode := Info.pDevMode;
DevMode.dmFields := DevMode.dmFields or DM_PAPERSIZE;
DevMode.dmPaperSize := DMPAPER_A4;
Info.pSecurityDescriptor := nil; // According to MSDN it has to be niled if we're not going to change it.
if not SetPrinter(H, 2, Info, 0) then begin
raise Exception.Create('SetPrinter error: ' + SysErrorMessage(GetLastError));
end;
finally
ClosePrinter(H);
end;
TPrintDialog.Create(Self).Execute; // This is just so I can check the paper size
end;
I have two problems related to access rights.
If I set PD.DesiredAccess to PRINTER_ACCESS_ADMINISTER the GetPrinter call fails, I guess this is due to UAC.
If I set it to PRINTER_ACCESS_USE the GetPrinter call succeeds and the Info structure is fine, but the call to SetPrinter fails.
Interestingly enough when I ignore the Result of SetPrinter the print dialog reports A4 as the printer size even though SetPrinter fails.
Am I doing it completly wrong and it is enough to pass a correctly setup up PDeviceMode to OpenPrinter? (I actually came up with this after writing this question :-)
Another question regarding the VCL:
If I use the Printers unit how do I know how big the buffers have to be that get passed as parameters to the TPrinter.GetPrinter method?
Background:
The system is: Windows 7 Professional 64-Bit English with English locale.
I'm trying to print to A4 paper on a network printer (Brother HL-5350DN).
I have set all printer settings in the control panel to A4 paper, but the Delphi 2009 program I'm writing still gets the paper dimensions for US Letter.
In other words: The Delphi program doesn't respect the default settings of the printer spooler.
If I run a TPrinterDialog first and select the correct paper size from there manually (in the advanced printer settings) everything is fine.
The program has to run without any UI, so I have to solve this programmatically or preferably the program should just respect the default Windows printer spooler settings.
Maybe I have missed some imporant setting?
try this guys
it work for me
uses WinSpool,Windows,System;
procedure SetPrinterInfo(APrinterName: PChar);
var
HPrinter : THandle;
InfoSize,
BytesNeeded: Cardinal;
DevMode : PDeviceMode;
PI2: PPrinterInfo2;
PrinterDefaults: TPrinterDefaults;
begin
with PrinterDefaults do
begin
DesiredAccess := PRINTER_ACCESS_USE;
pDatatype := nil;
pDevMode := nil;
end;
if OpenPrinter(APrinterName, HPrinter, #PrinterDefaults) then
try
SetLastError(0);
//Determine the number of bytes to allocate for the PRINTER_INFO_2 construct...
if not GetPrinter(HPrinter, 2, nil, 0, #BytesNeeded) then
begin
//Allocate memory space for the PRINTER_INFO_2 pointer (PrinterInfo2)...
PI2 := AllocMem(BytesNeeded);
try
InfoSize := SizeOf(TPrinterInfo2);
if GetPrinter(HPrinter, 2, PI2, BytesNeeded, #BytesNeeded) then
begin
DevMode := PI2.pDevMode;
DevMode.dmFields := DevMode.dmFields or DM_PAPERSIZE;
DevMode.dmPaperSize := DMPAPER_A4;
PI2.pSecurityDescriptor := nil;
// Apply settings to the printer
if DocumentProperties(0, hPrinter, APrinterName, PI2.pDevMode^,
PI2.pDevMode^, DM_IN_BUFFER or DM_OUT_BUFFER) = IDOK then
begin
SetPrinter(HPrinter, 2, PI2, 0); // Ignore the result of this call...
end;
end;
finally
FreeMem(PI2, BytesNeeded);
end;
end;
finally
ClosePrinter(HPrinter);
end;
end;
Like David wrote, my specific problem is solved by setting the correct printer preferences in Windows.
I still haven't found a way to set the local printing properties for my application, but that is no longer necessary.
Like Sertac wrote you can read and write the global printer preferences using TPrinter.GetPrinter and TPrinter.SetPrinter. (See the comments to the question)
Since nobody provided an anwser and the problem is now solved, I'm marking this as community wiki. Feel free to improve this answer.

Named Pipes from Windows Service to Client Application

My story is that I am designing a new app which must communicate with a Windows service. After much research I have come to the conclusion that Named Pipes are the recommended method ( How do I send a string from one instance of my Delphi program to another? ) however, it appears that I can't use SendMessage or Named Pipes in Win7 due to security problems... the messages never reach outside the service to the application.
I am using the Russell Libby's named Pipe components, which work without a hitch between normal desktop apps, but the Windows service seems to be throwing a wrench in the solution. Further research tells me that it may be possible to open up security on both sides to let them communicate, however, my knowledge level on this is minimal at best, and I haven't been able to make heads or tails of the possible API calls.
Based on the Delphi component pipes.pas, what needs to be done to open up this baby so both sides can start talking? I'm sure the following two functions from the pipes.pas file identify the security attributes, is anyone able to help me out here?
Thanks!
procedure InitializeSecurity(var SA: TSecurityAttributes);
var
sd: PSecurityDescriptor;
begin
// Allocate memory for the security descriptor
sd := AllocMem(SECURITY_DESCRIPTOR_MIN_LENGTH);
// Initialize the new security descriptor
if InitializeSecurityDescriptor(sd, SECURITY_DESCRIPTOR_REVISION) then
begin
// Add a NULL descriptor ACL to the security descriptor
if SetSecurityDescriptorDacl(sd, True, nil, False) then
begin
// Set up the security attributes structure
SA.nLength := SizeOf(TSecurityAttributes);
SA.lpSecurityDescriptor := sd;
SA.bInheritHandle := True;
end
else
// Failed to init the sec descriptor
RaiseWindowsError;
end
else
// Failed to init the sec descriptor
RaiseWindowsError;
end;
procedure FinalizeSecurity(var SA: TSecurityAttributes);
begin
// Release memory that was assigned to security descriptor
if Assigned(SA.lpSecurityDescriptor) then
begin
// Reource protection
try
// Free memory
FreeMem(SA.lpSecurityDescriptor);
finally
// Clear pointer
SA.lpSecurityDescriptor := nil;
end;
end;
end;
Windows Vista, Seven and 2008 enforce a more secure use of named pipes, see for example http://blogs.technet.com/b/nettracer/archive/2010/07/23/why-does-anonymous-pipe-access-fail-on-windows-vista-2008-windows-7-or-windows-2008-r2.aspx
When we migrated our product from Win 2K to Win7, we ran our Named Pipes quit working. After 2 weeks talking with MS (and $275), we discovered it was being caused by the Use Shared Folders file settings. Unchecking this feature allowed us to continue with pipes.
I tried to implement this one:
function GetUserSid(var SID: PSID; var Token: THandle): boolean;
var TokenUserSize: DWORD;
TokenUserP: PSIDAndAttributes;
begin
result := false;
if not OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, Token) then
if (GetLastError <> ERROR_NO_TOKEN) or
not OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, Token) then
Exit;
TokenUserP := nil;
TokenUserSize := 0;
try
if not GetTokenInformation(Token, TokenUser, nil, 0, TokenUserSize) and
(GetLastError <> ERROR_INSUFFICIENT_BUFFER) then
Exit;
TokenUserP := AllocMem(TokenUserSize);
if not GetTokenInformation(Token, TokenUser, TokenUserP,
TokenUserSize, TokenUserSize) then
Exit;
SID := TokenUserP^.Sid;
result := true;
finally
FreeMem(TokenUserP);
end;
end;
function ConvertSidToStringSidA(aSID: PSID; var aStr: PAnsiChar): BOOL; stdcall; external advapi32;
function ConvertStringSecurityDescriptorToSecurityDescriptorA(
StringSecurityDescriptor: PAnsiChar; StringSDRevision: DWORD;
SecurityDescriptor: pointer; SecurityDescriptorSize: Pointer): BOOL; stdcall; external advapi32;
const
SDDL_REVISION_1 = 1;
procedure InitializeSecurity(var SA: TSecurityAttributes; var SD; Client: boolean);
var OK: boolean;
Token: THandle;
pSidOwner: PSID;
pSid: PAnsiChar;
SACL: AnsiString;
begin
fillchar(SD,SECURITY_DESCRIPTOR_MIN_LENGTH,0);
// Initialize the new security descriptor
OK := false;
if InitializeSecurityDescriptor(#SD, SECURITY_DESCRIPTOR_REVISION) then begin
if Client or (OSVersionInfo.dwMajorVersion<6) then
// before Vista: add a NULL descriptor ACL to the security descriptor
OK := SetSecurityDescriptorDacl(#SD, true, nil, false)
else begin
// since Vista: need to specify special ACL
if GetUserSid(pSidOwner,Token) then
try
if ConvertSidToStringSidA(pSidOwner,pSid) then
try
SACL := 'D:(A;;GA;;;'+pSID+')(A;;GWGR;;;AN)(A;;GWGR;;;WD)S:(ML;;NW;;;S-1-16-0)';
OK := ConvertStringSecurityDescriptorToSecurityDescriptorA(
pointer(SACL),SDDL_REVISION_1,#SD,nil);
finally
LocalFree(PtrUInt(pSid));
end;
finally
FreeSid(pSidOwner);
CloseHandle(Token);
end;
end;
end;
if OK then begin
// Set up the security attributes structure
SA.nLength := sizeof(TSecurityAttributes);
SA.bInheritHandle := true;
SA.lpSecurityDescriptor := #SD;
end else
fillchar(SA,sizeof(SA),0); // mark error: no security
end;
It seems to work on the server side (i.e. the security attributes are created as expected), and you will have to write the client side code, without forgetting to add the pipe name in SYSTEM\CurrentControlSet\Services\lanmanserver\parameters\NullSessionPipes registry key, as expected.
I seem to remember that RemObjects has a named pipe client/server control in their package. Unless you are on a budget I would strongly recommend that you have a look at finished components for things like this. It is both time consuming and tricky to get right.
Alternatively, Justin Smyth has an article on named pipes right now. Check out his blog on the subject here: http://smythconsulting.blogspot.com/2011/07/smartmediaplayer-pipes-part4.html
Good luck!
I had the same kind of problem and just solved it. For me the reason it didn't work was because Russels TPipe implementetion has a check on the threads ID's just before the Pipe gets created: if not(Sync.SyncBaseTID = FNotifyThread) then..
It turned out I was creating the TPipeServer at the wrong place in my service. (I overrided DoStart etc instead of using the event OnStart... don't do that!)
I am now creating the TPipeServer instance in the same thread I later on activate it in.

Resources