GetAdaptersInfo not working on Delphi XE6 - delphi

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.

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, edit Auto-Complete access violation in tenumstring at TPointerlist()

In this autocomplete example by #KenWhite, the Next function has an access violation when TPointerList()[] is called ( by the windows autocomplete interface.)
D10.1u2, Win10.64
function TEnumString.Next(celt: Integer; out elt;
pceltFetched: PLongint): HResult;
var
I: Integer;
wStr: WideString;
begin
I := 0;
while (I < celt) and (FCurrIndex < FStrings.Count) do
begin
wStr := FStrings[FCurrIndex];
TPointerList(elt)[1] := PWideChar('abcd'); //access violation
TPointerList(elt)[1] := CoTaskMemAlloc(8); //access violation
TPointerList(elt)[I] := CoTaskMemAlloc(2 * (Length(wStr) + 1)); //access violation
StringToWideChar(wStr, TPointerList(elt)[I], 2 * (Length(wStr) + 1));
Inc(I);
Inc(FCurrIndex);
end;
if pceltFetched <> nil then
pceltFetched^ := I;
if I = celt then
Result := S_OK
else
Result := S_FALSE;
end;
In newer versions (IIRC XE2 and above), you can do what Remy says, but IMO you should not.
In versions before XE2 (or whatever version it was), the definition of TPointerList was:
type
...
TPointerList = array[0..MaxListSize] of Pointer;
In the newer versions, it is:
type
TPointerList = array of Pointer;
In other words, instead of a static array type (a value type), it has become a dynamic array type (a reference type) now. Casting the address of an untyped out parameter to such an array can turn out to be tricky.
The difference in definition explains why in newer versions, the code does not work properly: there is one extra level of indirection.
Now if you add the following declaration to the uAutoComplete.pas file:
type
TPointerList = array[0..65535] of Pointer; // assuming 65536 (2^16) entries are enough
then the rest of the file can remain what it used to be. Then:
TPointerList(elt)[I] := ...
works and does not require you to use a slightly tricky, indirect, cast to a Delphi dynamic array on something that is actually not. Note that this will also work in older versions.
(elt) needs to be (#elt), and [1] needs to be [I]:
TPointerList(#elt)[I]
Then the code will not AV anymore.
Also, the output strings must be allocated with either SysAllocString...() or CoTaskMemAlloc(), as the caller is going to use the COM memory manager to free them. You can use the RTL's ComObj.StringToLPOLESTR() function to handle that for you, which makes a COM-allocated wide string copy of a Delphi String:
TPointerList(#elt)[I] := StringToLPOLESTR(FStrings[FCurrIndex]);
Alternatively, you can simply take ownership of the WideString's data pointer instead of making yet another copy in memory after WideString has already made one:
wStr := FStrings[FCurrIndex];
TPointerList(#elt)[I] := Pointer(wStr);
Pointer(wStr) := nil;

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.

Changes to TRegistry key dont 'hold'

From my Win32 app I'm reading and writing HKEY_CURRENT_USER\Software\Embarcadero\BDS\9.0\History Lists\hlRunParameters, that is where the Delphi XE2 IDE writes run-time parameters.
This is the write code:
procedure TFrmCleanIDEParams.BtnWriteClick(Sender: TObject);
var
lReg : TRegistry;
lValue,
lKey : String;
i,
lNrToWrite,
lNrRegVals: Integer;
begin
.....
lKey := Trim(EdtRegKey.Text); // '\Software\Embarcadero\BDS\9.0\History Lists\hlRunParameters'
if lKey = '' then Exit;
if lKey[1] = '\' then lKey := Copy(lKey,2);
lReg := TRegistry.Create(KEY_READ or KEY_WRITE);
lReg.RootKey := HKEY_CURRENT_USER;
if not lReg.OpenKey(lKey,false) then
begin
MessageDlg('Key not found', mtError, mbOKCancel, 0);
Exit;
end;
if not lReg.ValueExists('Count') then
begin
MessageDlg('Value ''Count'' not found', mtError, mbOKCancel, 0);
Exit;
end;
lNrRegVals := lReg.ReadInteger('Count');
lNrToWrite := CLBParams.Items.Count; // TCheckListBox
lReg.WriteInteger('Count',lNrToWrite);
for i := 0 to lNrToWrite-1 do
begin
lValue := 'Item' + IntToStr(i);
lReg.WriteString(lValue,CLBParams.Items[i]);
end;
// Remove the rest:
for i := lNrToWrite to lNrRegVals-1 do
lReg.DeleteValue('Item' + IntToStr(i));
end;
Issues:
In RegEdit I see the key contents changing as expected, but the Delphi IDE does not pick up these changes
Some time (reboot?) later the HKEY_CURRENT_USER key has its old values
I think several things could be the reason, but I'm not sure which ones to attack:
I should not use HKEY_CURRENT_USER, but HKEY_USERS. If this is the case, how do I then get the proper S-1-5-etc that I need to use?
It's a Windows 7 64-bit issue, although both my program and the Delphi IDE are 32 bit. (How) do I then need to change the TRegistry.Create?
I read this Delphi: Read 64-bits registry key from 32-bits process post but that still does not tell me if/when to use different 'access keys'.
Do I always need to use this KEY_WOW64_64KEY value regardless of my app being 32/64 bit? I see that HKEY_CURRENT_USER\Software is shared, not redirected. (How) do I need to treat these differently?
BTW UAC is off, it would be nice if my code worked with UAC on too.
The Delphi IDE will only read these values at start up. But you must make sure that you write the registry values after the IDE has finished writing to them.
You should be using HKEY_CURRENT_USER.
You should not be using an alternate registry view flag because that part of the registry is shared.
UAC won't have any impact here because HKEY_CURRENT_USER is writeable for the standard user token.
The only explanation that makes sense is that another process is modifying the values. My guess is that the Delphi IDE is that process.

Copy a file to clipboard in Delphi

I am trying to copy a file to the clipboard. All examples in Internet are the same. I am using one from, http://embarcadero.newsgroups.archived.at/public.delphi.nativeapi/200909/0909212186.html but it does not work.
I use Rad Studio XE and I pass the complete path. In mode debug, I get some warnings like:
Debug Output:
Invalid address specified to RtlSizeHeap( 006E0000, 007196D8 )
Invalid address specified to RtlSizeHeap( 006E0000, 007196D8 )
I am not sure is my environment is related: Windows 8.1 64 bits, Rad Studio XE.
When I try to paste the clipboard, nothing happens. Also, seeing the clipboard with a monitor tool, this tool shows me error.
The code is:
procedure TfrmDoc2.CopyFilesToClipboard(FileList: string);
var
DropFiles: PDropFiles;
hGlobal: THandle;
iLen: Integer;
begin
iLen := Length(FileList) + 2;
FileList := FileList + #0#0;
hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE or GMEM_ZEROINIT,
SizeOf(TDropFiles) + iLen);
if (hGlobal = 0) then raise Exception.Create('Could not allocate memory.');
begin
DropFiles := GlobalLock(hGlobal);
DropFiles^.pFiles := SizeOf(TDropFiles);
Move(FileList[1], (PChar(DropFiles) + SizeOf(TDropFiles))^, iLen);
GlobalUnlock(hGlobal);
Clipboard.SetAsHandle(CF_HDROP, hGlobal);
end;
end;
UPDATE:
I am sorry, I feel stupid. I used the code that did not work, the original question that somebody asked, in my project, while I used the Remy's code, the correct solution, here in Stackoverflow. I thought that I used the Remy's code in my project. So, now, using the Remy's code, everything works great. Sorry for the mistake.
The forum post you link to contains the code in your question and asks why it doesn't work. Not surprisingly the code doesn't work for you any more than it did for the asker.
The answer that Remy gives is that there is a mismatch between ANSI and Unicode. The code is for ANSI but the compiler is Unicode.
So click on Remy's reply and do what it says: http://embarcadero.newsgroups.archived.at/public.delphi.nativeapi/200909/0909212187.html
Essentially you need to adapt the code to account for characters being 2 bytes wide in Unicode Delphi, but I see no real purpose repeating Remy's code here.
However, I'd say that you can do better than this code. The problem with this code is that it mixes every aspect all into one big function that does it all. What's more, the function is a method of a form in your GUI which is really the wrong place for it. There are aspects of the code that you might be able to re-use, but not factored like that.
I'd start with a function that puts an known block of memory into the clipboard.
procedure ClipboardError;
begin
raise Exception.Create('Could not complete clipboard operation.');
// substitute something more specific that Exception in your code
end;
procedure CheckClipboardHandle(Handle: HGLOBAL);
begin
if Handle=0 then begin
ClipboardError;
end;
end;
procedure CheckClipboardPtr(Ptr: Pointer);
begin
if not Assigned(Ptr) then begin
ClipboardError;
end;
end;
procedure PutInClipboard(ClipboardFormat: UINT; Buffer: Pointer; Count: Integer);
var
Handle: HGLOBAL;
Ptr: Pointer;
begin
Clipboard.Open;
Try
Handle := GlobalAlloc(GMEM_MOVEABLE, Count);
Try
CheckClipboardHandle(Handle);
Ptr := GlobalLock(Handle);
CheckClipboardPtr(Ptr);
Move(Buffer^, Ptr^, Count);
GlobalUnlock(Handle);
Clipboard.SetAsHandle(ClipboardFormat, Handle);
Except
GlobalFree(Handle);
raise;
End;
Finally
Clipboard.Close;
End;
end;
We're also going to need to be able to make double-null terminated lists of strings. Like this:
function DoubleNullTerminatedString(const Values: array of string): string;
var
Value: string;
begin
Result := '';
for Value in Values do
Result := Result + Value + #0;
Result := Result + #0;
end;
Perhaps you might add an overload that accepted a TStrings instance.
Now that we have all this we can concentrate on making the structure needed for the CF_HDROP format.
procedure CopyFileNamesToClipboard(const FileNames: array of string);
var
Size: Integer;
FileList: string;
DropFiles: PDropFiles;
begin
FileList := DoubleNullTerminatedString(FileNames);
Size := SizeOf(TDropFiles) + ByteLength(FileList);
DropFiles := AllocMem(Size);
try
DropFiles.pFiles := SizeOf(TDropFiles);
DropFiles.fWide := True;
Move(Pointer(FileList)^, (PByte(DropFiles) + SizeOf(TDropFiles))^,
ByteLength(FileList));
PutInClipboard(CF_HDROP, DropFiles, Size);
finally
FreeMem(DropFiles);
end;
end;
Since you use Delphi XE, strings are Unicode, but you are not taking the size of character into count when you allocate and move memory.
Change the line allocating memory to
hGlobal := GlobalAlloc(GMEM_SHARE or GMEM_MOVEABLE or GMEM_ZEROINIT,
SizeOf(TDropFiles) + iLen * SizeOf(Char));
and the line copying memory, to
Move(FileList[1], (PByte(DropFiles) + SizeOf(TDropFiles))^, iLen * SizeOf(Char));
Note the inclusion of *SizeOf(Char) in both lines and change of PChar to PByte on second line.
Then, also set the fWide member of DropFiles to True
DropFiles^.fWide := True;
All of these changes are already in the code from Remy, referred to by David.

Resources