Non overlapped Serial Port hangs at CloseHandle - delphi

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.

Related

Memory leaked or corrupted on Windows Service Config Get

After 2 days wracking my brain, I give up on fixing this problem on my own.
I'm currently working on a service that needs to check the config of certain other services to decide if it can proceed with the rest of the program.
So far so good, it is working, but the clean up of the memory seems to be faulty. GetMem() and FreeMem() seem not to really give back the memory, and New() and Dispose() seem to break the memory allocation internally.
function tServiceStoppStart.GetServiceConfigStartTtype(sService: String): DWORD;
var
schm, schs: SC_Handle;
config: LPQUERY_SERVICE_CONFIG;
pcbBytesNeeded: DWORD;
sucessful: boolean;
begin
try
try
begin
sucessful := false;
// open the service manager (defined in WinSvc)
schm := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
if (schm > 0) then
begin
// grab the service handle
schs := OpenService(schm, PChar(sService), SERVICE_ALL_ACCESS);
if (schs > 0) then
begin
// get the byte count for the serviceconfig query
//over the pcbBytesNeeded witchz is filled with the right amount after 1. call
QueryServiceConfig(schs, config, 0, pcbBytesNeeded);
// 1. GetMem(config, pcbBytesNeeded);
// 2. New(config); -> seems to corrupt the memory allocation
if QueryServiceConfig(schs, config, pcbBytesNeeded, pcbBytesNeeded) then
begin
Result := config.dwStartType;
sucessful := True;
end;
end;
end;
CloseServiceHandle(schs);
end;
except
on E: Exception do
begin
//
end;
end;
finally
begin;
if sucessful then
begin
// seems not to free the memory
// 1. freeMem(config,pcbBytesNeeded)
// 2. Dispose(config) -> seems to corrupt the memory allocation
end;
end;
end;
end;
{Set the new first free block}
mov TSmallBlockPoolHeader[edx].FirstFreeBlock, ecx
{Set the block header} // gets accesviolation with new and dispose
mov [eax - 4], edx
{Is the chunk now full?}
jz #RemoveSmallPool
by object create calls
I'm not that confident in my record handling in Delphi. Can someone point me in the right direction?
Looks like it got fixed thoug the closing of the manager proably got meomry leak from build up by manager opening spam thx J... for the cue for the close

Delphi RIO - Indy TCPServer high CPU usage

I have a simple TCP file server program developed in Delphi RIO + Indy TCP Server. When 2 or more clients asks for the files, the CPU runs very high in 90s. This spooks off the server team and during this time, they have hard time login into the server on which the program is running.
Based on other threads on the subject, when I put IndySleep(x), it does bring the CPU down and the avg stays in 50-60s. I understand that putting IndySleep() may throttle a bit, but it works!
The files it serves are already compressed and vary in size from 1KB to <10MB.
Is there anything else I can do to improve overall CPU usage, without or with little IndySleep()?
Here is the code snippet:
procedure TMainForm.IdTCPSyncServerExecute(AContext: TIdContext);
begin
if (not AContext.Connection.IOHandler.InputBufferIsEmpty)
and (AContext.Connection.Connected) then
begin
SendFile(AContext, AContext.Connection.IOHandler.ReadLn);
//IndySleep(1000 div IdTCPSyncServer.Contexts.Count); // For high CPU
IndySleep(500); // For high CPU
end;
end;
procedure TMainForm.SendFile(AContext: TIdContext; AFileName: string);
var
lStream: TFileStream;
begin
lStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
if Assigned(lStream) then
begin
try
WriteRespHeader(AContext, 1, lStream.Size); //Custom fn() writes back to client file size and other useful info
AContext.Connection.IOHandler.LargeStream := False; // 32-bit
lStream.Position := 0;
AContext.Connection.IOHandler.Write(lStream, lStream.Size);
finally
lStream.Free;
end;
AddLogMsg(AContext.Binding.PeerIP + ' : Sent File: ' + AFileName); // Thread.Queue() based logging
end;
end;
You have the call to IndySleep() in the wrong place. If there is nothing available from the client to read yet, you are exiting OnExecute immediately and coming right back in, creating a tight loop. That is where your high CPU usage is likely occurring. Sleep only when there is nothing available yet, eg:
procedure TMainForm.IdTCPSyncServerExecute(AContext: TIdContext);
begin
if (not AContext.Connection.IOHandler.InputBufferIsEmpty)
and (AContext.Connection.Connected) then
begin
SendFile(AContext, AContext.Connection.IOHandler.ReadLn);
end else begin
//IndySleep(1000 div IdTCPSyncServer.Contexts.Count); // For high CPU
IndySleep(500); // For high CPU
// or, use AContext.Connection.IOHandler.Readable() instead...
// or, use AContext.Connection.IOHandler.CheckForDataOnSoure() instead...
end;
end;
Alternatively, I usually suggest this kind of manual check instead:
procedure TMainForm.IdTCPSyncServerExecute(AContext: TIdContext);
begin
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
AContext.Connection.IOHandler.CheckForDataOnSource(500{1000 div IdTCPSyncServer.Contexts.Count}); // For high CPU
AContext.Connection.IOHandler.CheckForDisconnect;
if AContext.Connection.IOHandler.InputBufferIsEmpty then Exit;
end;
SendFile(AContext, AContext.Connection.IOHandler.ReadLn);
end;
But really, in this case, a better solution is to simply not manually check for the presence of client data at all. If there is nothing available to read yet, just let IOHandler.ReadLn() block until something actually arrives, eg:
procedure TMainForm.IdTCPSyncServerExecute(AContext: TIdContext);
begin
SendFile(AContext, AContext.Connection.IOHandler.ReadLn);
end;

GetAdaptersInfo not working on Delphi XE6

I finally bit the bullet and bought XE6 and as expected, the Unicode conversion is turning into a bit of a nightmare. So if anyone can enlighten me on why this simple Windows API call fails, it would be most appreciated. The function does not return an error, the first call gets the correct buffer length, the second call fills the record with garbage.
This works fine under Delphi 2007 but fails on XE6 with unicode garbage in the pAdapterinfo return record even though it is explicitly declared with AnsiString in IpTypes.pas
System is Win7(64) but compiling for 32 bits.
uses iphlpapi, IpTypes;
function GetFirstAdapterMacAddress:AnsiString;
var pAdapterInfo:PIP_ADAPTER_INFO;
BufLen,Status:cardinal; i:Integer;
begin
result:='';
BufLen:= sizeof(IP_ADAPTER_INFO);
GetAdaptersInfo(nil, BufLen);
pAdapterInfo:= AllocMem(BufLen);
try
Status:= GetAdaptersInfo(pAdapterInfo,BufLen);
if (Status <> ERROR_SUCCESS) then
begin
case Status of
ERROR_NOT_SUPPORTED: raise exception.create('GetAdaptersInfo is not supported by the operating ' +
'system running on the local computer.');
ERROR_NO_DATA: raise exception.create('No network adapter on the local computer.');
else
raiselastOSerror;
end;
Exit;
end;
while (pAdapterInfo^.AddressLength=0) and (pAdapterInfo^.next<>nil) do
pAdapterInfo:=pAdapterInfo.next;
if pAdapterInfo^.AddressLength>0 then
for i := 0 to pAdapterInfo^.AddressLength - 1 do
result := result + IntToHex(pAdapterInfo^.Address[I], 2);
finally
Freemem(pAdapterInfo);
end;
end;
UPDATE:
I did some more checking. I created a new simple application with one form and a button and called the routine when the button was pressed and it worked.
The differences are...in the working form the size of IP_ADAPTER_INFO is 640 bytes.
When this routine is used in a more complex application it fails and the size of IP_ADAPTER_INFO displays as 1192 bytes.
At this point, it seems the complier is unilaterally deciding to change the type of the ansi chars in the structures to unicode chars. The debugger is showing AdapterName and description fields in unicode form. I did a grep of the system source code, there are no other versions of this data type declared in the library code apart from in the Indy library and that is just a duplicate.
Here is the data structure definition in IPtypes
PIP_ADAPTER_INFO = ^IP_ADAPTER_INFO;
{$EXTERNALSYM PIP_ADAPTER_INFO}
_IP_ADAPTER_INFO = record
Next: PIP_ADAPTER_INFO;
ComboIndex: DWORD;
AdapterName: array [0..MAX_ADAPTER_NAME_LENGTH + 3] of AnsiChar;
Description: array [0..MAX_ADAPTER_DESCRIPTION_LENGTH + 3] of AnsiChar;
AddressLength: UINT;
Address: array [0..MAX_ADAPTER_ADDRESS_LENGTH - 1] of BYTE;
Index: DWORD;
Type_: UINT;
DhcpEnabled: UINT;
CurrentIpAddress: PIP_ADDR_STRING;
IpAddressList: IP_ADDR_STRING;
GatewayList: IP_ADDR_STRING;
DhcpServer: IP_ADDR_STRING;
HaveWins: BOOL;
PrimaryWinsServer: IP_ADDR_STRING;
SecondaryWinsServer: IP_ADDR_STRING;
LeaseObtained: time_t;
LeaseExpires: time_t;
end;
Looks like a compiler bug.
There are several problems with your code:
You are not doing any error handling at all on the first call that calculates the buffer length. You don't even need that call, so get rid of it.
You are not doing adequate error handling on subsequent calls, in particular you are not handling the ERROR_BUFFER_OVERFLOW condition when GetAdaptersInfo() needs you to allocate more memory than you already have. Your are allocating only enough memory for one adapter, but GetAdaptersInfo() returns info for all adapters and thus needs a sufficient buffer to hold all of them at one time.
GetAdaptersInfo() does not use GetLastError(), so you need to call SetLastError() before you call RaiseLastOSError().
You are looping through the adapter list using the original pointer that you used to allocate the list, so you are causing a memory leak if the first adapter does not have a MAC address. You need to use a separate variable as the loop iterator so the original pointer is preserved so it can be freed correctly.
You are not taking into account the possibility that none of the adapters has a MAC address, so you will end up accessing a nil pointer after your while loop exits.
You appear to have multiple versions of the IpTypes unit on your machine, and the compiler is finding one that happens to use Char instead of AnsiChar in the IP_ADAPTER_INFO record so its size and field offsets are wrong.
With that said, try this instead:
uses
Winapi.iphlpapi, Winapi.IpTypes;
function GetFirstAdapterMacAddress: String;
var
pAdapterList, pAdapter: PIP_ADAPTER_INFO;
BufLen, Status: DWORD;
I: Integer;
begin
Result := '';
BufLen := 1024*15;
GetMem(pAdapterList, BufLen);
try
repeat
Status := GetAdaptersInfo(pAdapterList, BufLen);
case Status of
ERROR_SUCCESS:
begin
// some versions of Windows return ERROR_SUCCESS with
// BufLen=0 instead of returning ERROR_NO_DATA as documented...
if BufLen = 0 then begin
raise Exception.Create('No network adapter on the local computer.');
end;
Break;
end;
ERROR_NOT_SUPPORTED:
begin
raise Exception.Create('GetAdaptersInfo is not supported by the operating system running on the local computer.');
end;
ERROR_NO_DATA:
begin
raise Exception.Create('No network adapter on the local computer.');
end;
ERROR_BUFFER_OVERFLOW:
begin
ReallocMem(pAdapterList, BufLen);
end;
else
SetLastError(Status);
RaiseLastOSError;
end;
until False;
pAdapter := pAdapterList;
while pAdapter <> nil do
begin
if pAdapter^.AddressLength > 0 then
begin
for I := 0 to pAdapter^.AddressLength - 1 do begin
Result := Result + IntToHex(pAdapter^.Address[I], 2);
end;
Exit;
end;
pAdapter := pAdapter^.next;
end;
finally
FreeMem(pAdapterList);
end;
end;
The explanation is that the types declared in your third party IpTypes unit use Char. This is an alias to AnsiChar in pre-Unicode Delphi, and an alias to WideChar in Unicode Delphi. That would explain the fact that you see non-ANSI text when you inspect the content of the record.
The solution is to fix IpTypes to use AnsiChar in place of Char where appropriate. The best way to do that is to use the IpTypes shipped with Delphi rather than your third party version.
On top of that, the first call to GetAdaptersInfo is wrong. Not only do you fail to check the return value, but you pass nil for the buffer and yet also pass a non-zero length. I think it should go like this:
BufLen := 0;
if GetAdaptersInfo(nil, BufLen) <> ERROR_BUFFER_OVERFLOW then
raise ....
Of course, you way will work, but I'm just being a little pedantic here. Always check for errors when you call an API function.
Just to conclude this topic.
Changing IPtypes to winapi.IPtypes fixed the problem for me.
I think a third party component is doing something to confuse the compiler and giving the full link fixes it.

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.

WM_COPYDATA string not appearing in target application

I'm trying to pass information between two of my applications in Delphi 2010.
I'm using a simplified version of code that I've used successfully in the past (simplified because I don't need the sender to know that the send has been successful) I've boiled down the send received to a pair of example applications, which in essence are as follows
Send
procedure TMF.SendString;
var
copyDataStruct: TCopyDataStruct;
s: AnsiString;
begin
s := ebFirm.Text;
copyDataStruct.cbData := 1 + length(s);
copyDataStruct.lpData := PAnsiChar(s);
SendData(copyDataStruct);
end;
procedure TMF.SendData(copyDataStruct: TCopyDataStruct);
var
rh: THandle;
res: integer;
begin
rh := FindWindow(PChar('TMF'), PChar('Get Phone'));
if rh = 0 then
begin
// Launch the target application
ShellExecute(Handle, 'open', GetPhone, nil, nil, SW_SHOWNORMAL);
// Give time for the application to launch
Sleep(3000);
SendData(copyDataStruct); // RECURSION!
end;
SendMessage(rh, WM_COPYDATA, Integer(Handle), Integer(#copyDataStruct));
end;
Receive Application
procedure TMF.WMCopyData(var Msg: TWMCopyData);
var
s : AnsiString;
begin
s := PAnsiChar(Msg.CopyDataStruct.lpData) ;
jobstatus.Panels[1].Text := s;
end;
The major difference between the working test applications and the application I am adding the code to is that there is a lot of extra activity going on in target application. Especially on startup.
Any suggestions on why the WMCopyData procedure seems not to be firing at all?
CHeers
Dan
There are a few problems with your code.
One, you are not assigning a unique ID to the message. The VCL, and various third-party components, also use WM_COPYDATA, so you have to make sure you are actually processing YOUR message and not SOMEONE ELSE'S message.
Two, you may not be waiting long enough for the second app to start. Instead of Sleep(), use ShellExecuteEx() with the SEE_MASK_WAITFORINPUTIDLE flag (or use CreateProcess() and WaitForInputIdle()).
Third, when starting the second app, your recursive logic is attempting to send the message a second time. If that happened to fail, you would launch a third app, and so on. You should take out the recursion altogether, you don't need it.
Try this:
var
GetPhoneMsg: DWORD = 0;
procedure TMF.SendString;
var
copyDataStruct: TCopyDataStruct;
s: AnsiString;
begin
if GetPhoneMsg = 0 then Exit;
s := ebFirm.Text;
copyDataStruct.dwData := GetPhoneMsg;
copyDataStruct.cbData := Length(s);
copyDataStruct.lpData := PAnsiChar(s);
SendData(copyDataStruct);
end;
procedure TMF.SendData(copyDataStruct: TCopyDataStruct);
var
rh: HWND;
si: TShellExecuteInfo;
res: Integer;
begin
rh := FindWindow(PChar('TMF'), PChar('Get Phone'));
if rh = 0 then
begin
// Launch the target application and give time to start
ZeroMemory(#si, SizeOf(si));
si.cbSize := SizeOf(si);
si.fMask := SEE_MASK_WAITFORINPUTIDLE;
si.hwnd := Handle;
si.lpVerb := 'open';
si.lpFile := GetPhone;
si.nShow := SW_SHOWNORMAL;
if not ShellExecuteEx(#si) then Exit;
rh := FindWindow(PChar('TMF'), PChar('Get Phone'));
if rh = 0 then Exit;
end;
SendMessage(rh, WM_COPYDATA, WParam(Handle), LParam(#copyDataStruct));
end;
initialization
GetPhoneMsg := RegisterWindowMessage('TMF_GetPhone');
Receive Application
var
GetPhoneMsg: DWORD = 0;
procedure TMF.WMCopyData(var Msg: TWMCopyData);
var
s : AnsiString;
begin
if (GetPhoneMsg <> 0) and (Msg.CopyDataStruct.dwData = GetPhoneMsg) then
begin
SetString(s, PAnsiChar(Msg.CopyDataStruct.lpData), Msg.CopyDataStruct.cbData);
jobstatus.Panels[1].Text := s;
end else
inherited;
end;
initialization
GetPhoneMsg := RegisterWindowMessage('TMF_GetPhone');
I think it is a good habit to add
copyDataStruct.dwData := Handle;
in procedure TMF.SendString; - if you don't have a custom identifier, putting the source HWND value will help debugging on the destination (you can check for this value in the other side, and therefore avoid misunderstand of broadcasted WMCOPY_DATA e.g. - yes, there should not be, but I've seen some!).
And
procedure WMCopyData(var Msg : TWMCopyData); message WM_COPYDATA;
in TMF client class definition, right?
There should be a missing exit or else after the nested SendData call:
procedure TMF.SendData(copyDataStruct: TCopyDataStruct);
(...)
Sleep(3000);
SendData(copyDataStruct);
end else
SendMessage(rh, WM_COPYDATA, NativeInt(Handle), NativeInt(#copyDataStruct));
end;
But this won't change much.
Check the rh := FindWindow() returned handle: is it the Handle of the TMF client form, or the Application.Handle?
It doesn't work anymore if you are using Windows 7.
If you are using it, check this page to see how to add an exception: http://msdn.microsoft.com/en-us/library/ms649011%28v=vs.85%29.aspx
I thought there was a problem with the (rh) handle being 0 when you call it, if the app needed to be started. But now I see that SendData calls itself recursively. I added a comment in the code for that, as it was non-obvious. But now there's another problem. The 2nd instance of SendData will have the right handle. But then you're going to pop out of that, back into the first instance where the handle is still 0, and then you WILL call SendMessage again, this time with a 0 handle. This probably is not the cause of your trouble, but it's unintended, unnecessary, and altogether bad. IMO, this is a case complicating things by trying to be too clever.

Resources