Sign in Join
Wiki copytemporary

Windows Programming Tips: what changed

Revision 0 to 1. Removed lines have a minus sign; added lines have a plus sign.

Title: Windows Programming Tips

OldNewLine
1+*(Windows only)*
2+
3+This page is dedicated to desktop Windows - including server - **Windows programming tips**.
4+
5+## Articles about Windows Programming
6+
7+- [[High DPI]] - How to make your application DPI-aware on Windows 7.
8+- [[Aero Glass]] - How to apply Aero Glass effect in a Lazarus Form on Windows 7.
9+- [[Windows Icon]] - How to design your icon with the right sizes.
10+- [[Inno Setup Usage]] - How to create setup files with File Association support.
11+
12+## Windows specific compiler options
13+
14+The most prominent options are the **-W** flags. A GUI application requires the **-WG** flag. See *Project Options / Compiler Options / Linking / Target OS Specific options / Win32 GUI application*. No console is shown, **writeln** and **readln** are not possible, you will get **File not open** errors. Omitting this option creates a console application (same as passing -WC).
15+
16+## Writing cross-platform code that works on Windows
17+
18+While you can use Windows-only code (such as the **windows** unit), with a little care you can often prepare for cross-platform use (e.g. use the [[lclintf]] unit).
19+
20+See [[Multiplatform Programming Guide|Windows specific issues]] for more details.
21+
22+## COM Programming
23+
24+### Importing and using a COM library
25+
26+The first step to import and use a COM library is generating the interface definitions from it. Use the program importtl which is located in Free Pascal in fpc/utils/importtl. A pre-compiled binary of this program can be found here: <http://sourceforge.net/projects/p-tools/files/ImportTL/>
27+
28+You can call it, for example for MSAA like this:
29+
30+importtl.exe C:\Windows\system32\oleacc.dll
31+
32+And it will generate the type library pascal unit Accessibility_1_1_TLB.pas in the folder where it is.
33+
34+### Creating a library which exports a COM object
35+
36+ToDo: write me
37+
38+### Windows Sensor/Location API
39+
40+Available since Windows 7. See [[LazDeviceAPIs|possible Windows implementation]]
41+
42+## ActiveX controls
43+
44+You can use ActiveX controls in recent Lazarus versions. See [[LazActiveX]]
45+
46+## Services
47+
48+Lazarus and FPC make writing Windows services easy. See [[Daemons and Services]]
49+
50+## Using sleep(n) and Application.ProcessMessages
51+
52+Windows has a messaging system (see <https://docs.microsoft.com/en-us/windows/desktop/winmsg/messages-and-message-queues>) and uses messages to "talk" to all running applications. You obstruct that when using sleep(n). In such a case use Application.ProcessMessages instead of sleep(n) which is blocking. You have to give the OS the time to process its message queue. Application.ProcessMessages handles all waiting system messages in an application's message queue.
53+
54+There is one exception: sleep(0). This has a special meaning and means relinquish time slice. Any other sleep is almost always bad programming.
55+
56+Note that Application.ProcessMessages is called by the LCL automatically after every message (eg after every event like OnClick). So you would only need to call it in your event handler where there is a significant delay doing some processing. Of course, event handlers should probably not be doing any significant processing. Instead, you should be calling another function or procedure which may require the use of Application.ProcessMessages to ensure the application continues to respond to events and does not appear to have locked up. However, even in that case, it might be better to simply alert the user to the extended processing time (eg when compressing a file) by using the appropriate "busy" cursor or a progress bar.
57+
58+Beware of unintended consequences... sprinkling Application.ProcessMessages through your code like fairy dust may sound like a good idea, but consider what happens if your application is still busy with the task and an impatient user clicks that button a second time. That second click will be put into the Windows message queue and a second identical task will now be triggered. The result may be, for example, interleaved output to a file which is probably not what you intended.
59+
60+## Code signing Windows executables
61+
62+For details of code signing Windows executables to avoid your end users receiving warnings that the publisher of the software is "unknown" when attempting to run an executable, see [[Code Signing for Windows]].
63+
64+## Code snippets
65+
66+### File Association
67+
68+To add icons to file associations, and register them for use with a program, use the [[FileAssociation]] component. If the FileAssociation component for some reason does not work for you, or you need to run it as administrator for all users without elevating your application privileges, an Inno Setup Script may fit your needs best. See [[Inno Setup Usage|Inno Setup]].
69+
70+### Ensure only a single instance can run
71+
72+To ensure only a single instance of your program can run, you can use the [[UniqueInstance]] component which supports Windows and Linux (note that macOS prevents the same application from running more than once by default).
73+
74+Alternatively, you can use the mutex unit below which also supports Windows and Linux:
75+
76+``` pascal
77+{Author: Serguei Tarassov (from https://arbinada.com/en/node/1426)}
78+
79+unit mutex;
80+
81+{$mode objfpc}{$H+}
82+
83+interface
84+
85+type
86+ TMutex = class
87+ private
88+ FFileHandle: integer;
89+ public
90+ constructor Create(const AName: string; const WaitForMSec: integer = 10000);
91+ destructor Destroy; override;
92+ end;
93+
94+implementation
95+
96+uses
97+ Classes, SysUtils, DateUtils,
98+ {$IFDEF WINDOWS}
99+ Windows
100+ {$ENDIF};
101+
102+function GetTempDir: string;
103+begin
104+{$IFDEF WINDOWS}
105+ SetLength(Result, 255);
106+ SetLength(Result, GetTempPath(255, (PChar(Result))));
107+{$ENDIF}
108+{$IFDEF LINUX}
109+ Result := GetEnv('TMPDIR');
110+ if Result = '' then
111+ Result := '/tmp/'
112+ else if Result[Length(Result)] <> PathDelim then
113+ Result := Result + PathDelim;
114+{$ENDIF}
115+end;
116+
117+constructor TMutex.Create(const AName: string; const WaitForMSec: integer);
118+ function NextAttempt(const MaxTime: TDateTime): boolean;
119+ begin
120+ Sleep(1);
121+ Result := Now < MaxTime;
122+ end;
123+
124+var
125+ MaxTime: TDateTime;
126+ LockFileName: string;
127+begin
128+ inherited Create;
129+ LockFileName := IncludeTrailingPathDelimiter(GetTempDir) + AName + '.tmp';
130+ MaxTime := IncMillisecond(Now, WaitForMSec);
131+ repeat
132+ if FileExists(LockFileName) then
133+ FFileHandle := FileOpen(LockFileName, fmShareExclusive)
134+ else
135+ FFileHandle := FileCreate(LockFileName, fmShareExclusive);
136+ until (FFileHandle <> -1) or not NextAttempt(MaxTime);
137+ if FFileHandle = -1 then
138+ raise Exception.CreateFmt('Unable to lock mutex (File: %s; waiting: %d msec)', [LockFileName, WaitForMSec]);
139+end;
140+
141+destructor TMutex.Destroy;
142+begin
143+ if FFileHandle <> -1 then
144+ FileClose(FFileHandle);
145+ inherited;
146+end;
147+
148+end.
149+```
150+
151+To use it, add in your project file:
152+
153+``` pascal
154+{$IFDEF WINDOWS}
155+var
156+ MyMutex: TMutex;
157+{$ENDIF}
158+begin
159+ Application.Title := 'My App';
160+
161+ {$IFDEF WINDOWS}
162+ Try
163+ MyMutex := TMutex.Create('MyAppMutex', 100);
164+ Except
165+ ShowMessage(Application.Title + ' is already running.');
166+ MyMutex.Free;
167+ Exit;
168+ End;
169+ {$ENDIF}
170+
171+ Application.Initialize;
172+ Application.CreateForm(TForm1, Form1);
173+ Application.Run;
174+
175+ {$IFDEF WINDOWS}
176+ MyMutex.Free;
177+ {$ENDIF}
178+end.
179+```
180+
181+### Showing Memory, Disk Space Information
182+
183+``` pascal
184+...
185+Uses
186+ Windows;
187+...
188+
189+procedure TForm1.MemoryClick(Sender: TObject);
190+Var
191+ Memory: TMemoryStatus;
192+
193+begin
194+ InfoMemo.Text := '';
195+
196+ Memory.dwLength := SizeOf(Memory);
197+ GlobalMemoryStatus(Memory);
198+
199+ InfoMemo.Lines.Add(Format('Memory total: %f GB', [Memory.dwTotalPhys /1024 /1024 /1024]));
200+ InfoMemo.Lines.Add(Format('Memory free: %f GB', [Memory.dwAvailPhys /1024 /1024 /1024]));
201+ InfoMemo.Lines.Add(Format('Memory in use: %d%%', [Memory.dwMemoryLoad]));
202+ InfoMemo.Lines.Add(Format('Pagefile size: %f GB', [Memory.dwTotalPageFile /1024 /1024 /1024]));
203+ InfoMemo.Lines.Add(Format('Pagefile free: %f GB', [Memory.dwAvailPageFile /1024 /1024 /1024]));
204+ InfoMemo.Lines.Add(Format('Virtual memory total: %f GB', [Memory.dwTotalVirtual /1024 /1024 /1024]));
205+ InfoMemo.Lines.Add(Format('Virtual memory free: %f GB', [Memory.dwAvailVirtual /1024 /1024 /1024]));
206+ InfoMemo.Lines.Add(Format('Disk space total: %f GB', [DiskSize(0) /1024 /1024 /1024]));
207+ InfoMemo.Lines.Add(Format('Disk space free: %f GB', [DiskFree(0) /1024 /1024 /1024]));
208+end;
209+```
210+
211+### Using Windows native wininet for web retrieval
212+
213+``` pascal
214+{$IFDEF WINDOWS}
215+// Need to use Windows WinInet to avoid issue with HTTPS
216+// needing two OpenSSL DLLs to be provided with application
217+// if using TFPHttpClient.
218+// The WinINet API also gets any connection and proxy settings
219+// set by Internet Explorer. Blessing or curse?
220+
221+uses
222+ wininet;
223+
224+function GetWebPage(const Url: string): string;
225+var
226+ NetHandle: HINTERNET;
227+ UrlHandle: HINTERNET;
228+ Buffer: array[0..1023] of Byte;
229+ BytesRead: dWord;
230+ StrBuffer: UTF8String;
231+begin
232+ Result := '';
233+ BytesRead := Default(dWord);
234+ NetHandle := InternetOpen('Mozilla/5.0(compatible; WinInet)', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
235+
236+ // NetHandle valid?
237+ if Assigned(NetHandle) then
238+ Try
239+ UrlHandle := InternetOpenUrl(NetHandle, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0);
240+
241+ // UrlHandle valid?
242+ if Assigned(UrlHandle) then
243+ Try
244+ repeat
245+ InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesRead);
246+ SetString(StrBuffer, PAnsiChar(@Buffer[0]), BytesRead);
247+ Result := Result + StrBuffer;
248+ until BytesRead = 0;
249+ Finally
250+ InternetCloseHandle(UrlHandle);
251+ end
252+ // o/w UrlHandle invalid
253+ else
254+ ShowMessage('Cannot open URL: ' + Url);
255+ Finally
256+ InternetCloseHandle(NetHandle);
257+ end
258+ // NetHandle invalid
259+ else
260+ raise Exception.Create('Unable to initialize WinInet');
261+end;
262+{$ENDIF}
263+```
264+
265+### Listing all available drives
266+
267+``` pascal
268+program listdevices;
269+
270+{$ifdef fpc}{$mode delphi}{$endif}
271+{$apptype console}
272+
273+uses
274+ Windows;
275+
276+var
277+ Drive: Char;
278+ DriveLetter: string;
279+ OldMode: Word;
280+begin
281+ WriteLn('The following drives were found in this computer:');
282+ WriteLn('');
283+
284+ // Empty Floppy or Zip drives can generate a Windows error.
285+ // We disable system errors during the listing.
286+ // Note that another way to skip these errors would be to use DEVICE_IO_CONTROL.
287+ OldMode := SetErrorMode(SEM_FAILCRITICALERRORS);
288+ try
289+
290+ // Search all drive letters
291+ for Drive := 'A' to 'Z' do
292+ begin
293+ DriveLetter := Drive + ':\';
294+
295+ case GetDriveType(PChar(DriveLetter)) of
296+ DRIVE_REMOVABLE: WriteLn(DriveLetter + ' Floppy Drive');
297+ DRIVE_FIXED: WriteLn(DriveLetter + ' Fixed Drive');
298+ DRIVE_REMOTE: WriteLn(DriveLetter + ' Network Drive');
299+ DRIVE_CDROM: WriteLn(DriveLetter + ' CD-ROM Drive');
300+ DRIVE_RAMDISK: WriteLn(DriveLetter + ' RAM Disk');
301+ end;
302+ end;
303+
304+ finally
305+ // Restores previous Windows error mode.
306+ SetErrorMode(OldMode);
307+ end;
308+
309+ // Also add a stop to see the result under Windows
310+ WriteLn('');
311+ WriteLn('Please press <ENTER> to exit the program.');
312+ ReadLn(DriveLetter);
313+end.
314+```
315+
316+### Creating a shortcut (.lnk) file
317+
318+Creating a shortcut on the Desktop (can be easily adapted to any location). Adapted from [post by Felipe Monteiro de Carvalho](http://www.mail-archive.com/fpc-pascal@lists.freepascal.org/msg13325.html) The ISLink object has more methods that you can use to modify your shortcut...
319+
320+``` pascal
321+uses
322+...
323+windows, shlobj {for special folders}, ActiveX, ComObj;
324+...
325+procedure CreateDesktopShortCut(Target, TargetArguments, ShortcutName: string);
326+var
327+ IObject: IUnknown;
328+ ISLink: IShellLink;
329+ IPFile: IPersistFile;
330+ PIDL: PItemIDList;
331+ InFolder: array[0..MAX_PATH] of Char;
332+ TargetName: String;
333+ LinkName: WideString;
334+begin
335+ { Creates an instance of IShellLink }
336+ IObject := CreateComObject(CLSID_ShellLink);
337+ ISLink := IObject as IShellLink;
338+ IPFile := IObject as IPersistFile;
339+
340+ ISLink.SetPath(pChar(Target));
341+ ISLink.SetArguments(pChar(TargetArguments));
342+ ISLink.SetWorkingDirectory(pChar(ExtractFilePath(Target)));
343+
344+ { Get the desktop location }
345+ SHGetSpecialFolderLocation(0, CSIDL_DESKTOPDIRECTORY, PIDL);
346+ SHGetPathFromIDList(PIDL, InFolder);
347+ LinkName := InFolder + PathDelim + ShortcutName+'.lnk';
348+
349+ { Create the link }
350+ IPFile.Save(PWChar(LinkName), false);
351+end;
352+```
353+
354+### Opening / Closing a CD or DVD
355+
356+See the [[CD open close]] article for Windows code.
357+
358+### Recently used programs list
359+
360+To make your program appear in the Recently Used Programs List on the Windows Start Menu, see [[recently used programs list|this article]].
361+
362+### Getting special folders (My documents, Desktop, local application data, etc)
363+
364+Often it is useful to get the location of a special folder such as the desktop. The example below shows how you can get the LocalAppData directory - where you can store user-specific configuration files etc for your programs.
365+
366+Use the MyDocuments folder (or a subfolder) to store documents.
367+
368+Look in the [shlobj](http://delphi-miranda-plugins.googlecode.com/svn-history/r105/trunk/FPC/units/src/shlobj.pp) unit (note: link may not be up to date) for more defines that let you look up the Desktop (note: use CSIDL_DESKTOPDIRECTORY, not CSIDL_DESKTOP), Recycle Bin, etc.
369+
370+``` pascal
371+uses
372+...
373+shlobj;
374+
375+var
376+ AppDataPath: Array[0..MaxPathLen] of Char; //Allocate memory
377+...
378+begin
379+...
380+ AppDataPath:='';
381+ SHGetSpecialFolderPath(0,AppDataPath,CSIDL_LOCAL_APPDATA,false);
382+ writeln('Your local appdata path is: ' + AppDataPath);
383+```
384+
385+Another way to achieve the task without using the Windows API is to query a specific environment variable. This solution allows the writing of a more homogeneous system code since, depending on the OS, only the variable name may have to be changed.
386+
387+For example:
388+
389+``` pascal
390+program UseEnv;
391+
392+uses sysutils;
393+
394+begin
395+ writeln(GetEnvironmentVariable('APPDATA'));
396+ writeln(GetEnvironmentVariable('PROGRAMFILES'));
397+ writeln(GetEnvironmentVariable('HOMEPATH'));
398+ readln;
399+end.
400+```
401+
402+However this solution is not always as accurate as **SHGetSpecialFolderPath()**, since it is sometimes necessary to check several variables.
403+
404+The available variables can be retrieved with **GetEnvironmentString()**:
405+
406+``` pascal
407+program ListEnv;
408+
409+uses sysutils;
410+
411+var
412+ i: integer;
413+
414+begin
415+ for i in [0..GetEnvironmentVariableCount-1] do
416+ writeln(GetEnvironmentString(i));
417+ readln;
418+end.
419+```
420+
421+### Enabling and disabling devices
422+
423+The following code can be used to enable and disable Windows devices; it is useful to e.g. reset a serial port or USB device. An example program follows below.
424+
425+``` pascal
426+unit controlwindevice;
427+
428+{ Enable Disable windows devices
429+
430+ Copyright (c) 2010-2012 Ludo Brands
431+
432+ Permission is hereby granted, free of charge, to any person obtaining a copy
433+ of this software and associated documentation files (the "Software"), to
434+ deal in the Software without restriction, including without limitation the
435+ rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
436+ sell copies of the Software, and to permit persons to whom the Software is
437+ furnished to do so, subject to the following conditions:
438+
439+ The above copyright notice and this permission notice shall be included in
440+ all copies or substantial portions of the Software.
441+
442+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
443+ IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
444+ FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
445+ AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
446+ LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
447+ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
448+ IN THE SOFTWARE.
449+}
450+
451+{$mode delphi}{$H+}
452+
453+interface
454+
455+uses
456+ Classes, SysUtils,dynlibs,windows;
457+
458+const
459+ GUID_DEVCLASS_NET : TGUID = '{4D36E972-E325-11CE-BFC1-08002BE10318}';
460+ GUID_DEVCLASS_PORT : TGUID = '{4D36E978-E325-11CE-BFC1-08002BE10318}';
461+
462+type
463+ TDeviceControlResult=(DCROK,DCRErrEnumDeviceInfo,DCRErrSetClassInstallParams,
464+ DCRErrDIF_PROPERTYCHANGE);
465+
466+function LoadDevices(GUID_DevClass:TGUID):TStringList;
467+function EnableDevice(SelectedItem: DWord):TDeviceControlResult;
468+function DisableDevice(SelectedItem: DWord):TDeviceControlResult;
469+
470+implementation
471+
472+// Setup api, based on SetupApi.pas JEDI library
473+const
474+ DIF_PROPERTYCHANGE = $00000012;
475+ DICS_ENABLE = $00000001;
476+ DICS_DISABLE = $00000002;
477+ DICS_FLAG_GLOBAL = $00000001; // make change in all hardware profiles
478+ DIGCF_PRESENT = $00000002;
479+ SPDRP_DEVICEDESC = $00000000; // DeviceDesc (R/W)
480+ SPDRP_CLASS = $00000007; // Class (R--tied to ClassGUID)
481+ SPDRP_CLASSGUID = $00000008; // ClassGUID (R/W)
482+ SPDRP_FRIENDLYNAME = $0000000C; // FriendlyName (R/W)
483+
484+type
485+ HDEVINFO = Pointer;
486+ DI_FUNCTION = LongWord; // Function type for device installer
487+
488+ PSPClassInstallHeader = ^TSPClassInstallHeader;
489+ SP_CLASSINSTALL_HEADER = packed record
490+ cbSize: DWORD;
491+ InstallFunction: DI_FUNCTION;
492+ end;
493+ TSPClassInstallHeader = SP_CLASSINSTALL_HEADER;
494+
495+ PSPPropChangeParams = ^TSPPropChangeParams;
496+ SP_PROPCHANGE_PARAMS = packed record
497+ ClassInstallHeader: TSPClassInstallHeader;
498+ StateChange: DWORD;
499+ Scope: DWORD;
500+ HwProfile: DWORD;
501+ end;
502+ TSPPropChangeParams = SP_PROPCHANGE_PARAMS;
503+
504+ PSPDevInfoData = ^TSPDevInfoData;
505+ SP_DEVINFO_DATA = packed record
506+ cbSize: DWORD;
507+ ClassGuid: TGUID;
508+ DevInst: DWORD; // DEVINST handle
509+ Reserved: ULONG_PTR;
510+ end;
511+ TSPDevInfoData = SP_DEVINFO_DATA;
512+
513+ TSetupDiEnumDeviceInfo = function(DeviceInfoSet: HDEVINFO;
514+ MemberIndex: DWORD; var DeviceInfoData: TSPDevInfoData): LongBool; stdcall;
515+ TSetupDiSetClassInstallParamsA = function(DeviceInfoSet: HDEVINFO;
516+ DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader;
517+ ClassInstallParamsSize: DWORD): LongBool; stdcall;
518+ TSetupDiSetClassInstallParamsW = function(DeviceInfoSet: HDEVINFO;
519+ DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader;
520+ ClassInstallParamsSize: DWORD): LongBool; stdcall;
521+ TSetupDiSetClassInstallParams = TSetupDiSetClassInstallParamsA;
522+ TSetupDiCallClassInstaller = function(InstallFunction: DI_FUNCTION;
523+ DeviceInfoSet: HDEVINFO; DeviceInfoData: PSPDevInfoData): LongBool; stdcall;
524+ TSetupDiGetClassDevs = function(ClassGuid: PGUID; const Enumerator: PAnsiChar;
525+ hwndParent: HWND; Flags: DWORD): HDEVINFO; stdcall;
526+ TSetupDiGetDeviceRegistryPropertyA = function(DeviceInfoSet: HDEVINFO;
527+ const DeviceInfoData: TSPDevInfoData; Property_: DWORD;
528+ var PropertyRegDataType: DWORD; PropertyBuffer: PBYTE; PropertyBufferSize: DWORD;
529+ var RequiredSize: DWORD): BOOL; stdcall;
530+ TSetupDiGetDeviceRegistryPropertyW = function(DeviceInfoSet: HDEVINFO;
531+ const DeviceInfoData: TSPDevInfoData; Property_: DWORD;
532+ var PropertyRegDataType: DWORD; PropertyBuffer: PBYTE; PropertyBufferSize: DWORD;
533+ var RequiredSize: DWORD): BOOL; stdcall;
534+ TSetupDiGetDeviceRegistryProperty = TSetupDiGetDeviceRegistryPropertyA;
535+
536+var
537+ DevInfo: hDevInfo;
538+ SetupDiEnumDeviceInfo: TSetupDiEnumDeviceInfo;
539+ SetupDiSetClassInstallParams: TSetupDiSetClassInstallParams;
540+ SetupDiCallClassInstaller: TSetupDiCallClassInstaller;
541+ SetupDiGetClassDevs: TSetupDiGetClassDevs;
542+ SetupDiGetDeviceRegistryProperty: TSetupDiGetDeviceRegistryProperty;
543+
544+var
545+ SetupApiLoadCount:integer=0;
546+
547+function LoadSetupApi: Boolean;
548+var SetupApiLib:TLibHandle;
549+begin
550+ Result := True;
551+ Inc(SetupApiLoadCount);
552+ if SetupApiLoadCount > 1 then
553+ Exit;
554+ SetupApiLib:=LoadLibrary('SetupApi.dll');
555+ Result := SetupApiLib<>0;
556+ if Result then
557+ begin
558+ SetupDiEnumDeviceInfo := GetProcedureAddress(SetupApiLib, 'SetupDiEnumDeviceInfo');
559+ SetupDiSetClassInstallParams := GetProcedureAddress(SetupApiLib, 'SetupDiSetClassInstallParamsA');
560+ SetupDiCallClassInstaller := GetProcedureAddress(SetupApiLib, 'SetupDiCallClassInstaller');
561+ SetupDiGetClassDevs := GetProcedureAddress(SetupApiLib, 'SetupDiGetClassDevsA');
562+ SetupDiGetDeviceRegistryProperty := GetProcedureAddress(SetupApiLib, 'SetupDiGetDeviceRegistryPropertyA');
563+ end;
564+end;
565+
566+// implementation
567+
568+function StateChange(NewState, SelectedItem: DWord;
569+ hDevInfo: hDevInfo): TDeviceControlResult;
570+var
571+ PropChangeParams: TSPPropChangeParams;
572+ DeviceInfoData: TSPDevInfoData;
573+begin
574+ PropChangeParams.ClassInstallHeader.cbSize := SizeOf(TSPClassInstallHeader);
575+ DeviceInfoData.cbSize := SizeOf(TSPDevInfoData);
576+ // Get a handle to the Selected Item.
577+ if (not SetupDiEnumDeviceInfo(hDevInfo, SelectedItem, DeviceInfoData)) then
578+ begin
579+ Result := DCRErrEnumDeviceInfo;
580+ exit;
581+ end;
582+ // Set the PropChangeParams structure.
583+ PropChangeParams.ClassInstallHeader.InstallFunction := DIF_PROPERTYCHANGE;
584+ PropChangeParams.Scope := DICS_FLAG_GLOBAL;
585+ PropChangeParams.StateChange := NewState;
586+ if (not SetupDiSetClassInstallParams(hDevInfo, @DeviceInfoData,
587+ PSPClassInstallHeader(@PropChangeParams), SizeOf(PropChangeParams))) then
588+ begin
589+ Result := DCRErrSetClassInstallParams;
590+ exit;
591+ end;
592+ // Call the ClassInstaller and perform the change.
593+ if (not SetupDiCallClassInstaller(DIF_PROPERTYCHANGE, hDevInfo, @DeviceInfoData)) then
594+ begin
595+ Result := DCRErrDIF_PROPERTYCHANGE;
596+ exit;
597+ end;
598+ Result := DCROK;
599+end;
600+
601+function GetRegistryProperty(PnPHandle: HDEVINFO;
602+ DevData: TSPDevInfoData; Prop: DWORD; Buffer: PChar;
603+ dwLength: DWord): Boolean;
604+var
605+ aBuffer: array[0..256] of Char;
606+begin
607+ dwLength := 0;
608+ aBuffer[0] := #0;
609+ SetupDiGetDeviceRegistryProperty(PnPHandle, DevData, Prop, Prop, PBYTE(@aBuffer[0]), SizeOf(aBuffer), dwLength);
610+ StrCopy(Buffer, aBuffer);
611+ Result := Buffer^ <> #0;
612+end;
613+
614+function ConstructDeviceName(DeviceInfoSet: hDevInfo;
615+ DeviceInfoData: TSPDevInfoData; Buffer: PChar; dwLength: DWord): Boolean;
616+const
617+ UnknownDevice = '<Unknown Device>';
618+begin
619+ if (not GetRegistryProperty(DeviceInfoSet, DeviceInfoData, SPDRP_FRIENDLYNAME, Buffer, dwLength)) then
620+ begin
621+ if (not GetRegistryProperty(DeviceInfoSet, DeviceInfoData, SPDRP_DEVICEDESC, Buffer, dwLength)) then
622+ begin
623+ if (not GetRegistryProperty(DeviceInfoSet, DeviceInfoData, SPDRP_CLASS, Buffer, dwLength)) then
624+ begin
625+ if (not GetRegistryProperty(DeviceInfoSet, DeviceInfoData, SPDRP_CLASSGUID, Buffer, dwLength)) then
626+ begin
627+ dwLength := DWord(SizeOf(UnknownDevice));
628+ Buffer := Pointer(LocalAlloc(LPTR, Cardinal(dwLength)));
629+ StrCopy(Buffer, UnknownDevice);
630+ end;
631+ end;
632+ end;
633+ end;
634+ Result := true;
635+end;
636+
637+function LoadDevices(GUID_DevClass:TGUID):TStringList;
638+var
639+ DeviceInfoData: TSPDevInfoData;
640+ i: DWord;
641+ pszText: PChar;
642+
643+begin
644+ if (not LoadSetupAPI) then
645+ begin
646+ result:=nil;
647+ exit;
648+ end;
649+ DevInfo := nil;
650+ // Get a handle to all devices in all classes present on system
651+ DevInfo := SetupDiGetClassDevs(@GUID_DevClass, nil, 0, DIGCF_PRESENT);
652+ if (DevInfo = Pointer(INVALID_HANDLE_VALUE)) then
653+ begin
654+ result:=nil;
655+ exit;
656+ end;
657+ Result:=TStringList.Create;
658+ DeviceInfoData.cbSize := SizeOf(TSPDevInfoData);
659+ i := 0;
660+ // Enumerate though all the devices.
661+ while SetupDiEnumDeviceInfo(DevInfo, i, DeviceInfoData) do
662+ begin
663+ GetMem(pszText, 256);
664+ try
665+ // Get a friendly name for the device.
666+ ConstructDeviceName(DevInfo, DeviceInfoData, pszText, DWord(nil));
667+ Result.AddObject(pszText,Tobject(i));
668+ finally
669+ FreeMem(pszText);
670+ inc(i);
671+ end;
672+ end;
673+end;
674+
675+function EnableDevice(SelectedItem: DWord):TDeviceControlResult;
676+
677+begin
678+ result:=StateChange(DICS_ENABLE, SelectedItem , DevInfo);
679+end;
680+
681+function DisableDevice(SelectedItem: DWord):TDeviceControlResult;
682+
683+begin
684+ result:=StateChange(DICS_DISABLE, SelectedItem , DevInfo);
685+end;
686+
687+end.
688+```
689+
690+Example program that lists all ports preceeded by a number.
691+
692+Enter a number and the port will be disabled. Enter return again and the port will be enabled again.
693+
694+``` pascal
695+program devicetest;
696+
697+{$mode delphi}{$H+}
698+
699+uses
700+ Classes, controlwindevice;
701+var
702+ sl:tstringlist;
703+ i:integer;
704+begin
705+ sl:=Loaddevices(GUID_DEVCLASS_PORT);
706+ for i:=0 to sl.count-1 do
707+ writeln(i,' : ',sl[i]);
708+ readln(i);
709+ if DisableDevice(i)=DCROK then
710+ writeln(sl[i],' disabled');
711+ readln;
712+ if EnableDevice(i)=DCROK then
713+ writeln(sl[i],' enabled');
714+ sl.Free;
715+ readln;
716+end.
717+```
718+
719+### Downloading a file using urlmon
720+
721+Urlmon.dll is built into Windows and can be used to e.g. download a file from a web site. It supports SSL/TLS connections.
722+
723+Windows-only; please look into libraries like [[fphttpclient]], [[Synapse]] and [[Indy]] for cross-platform solutions.
724+
725+``` pascal
726+function URLDownloadToFile(pCaller: pointer; URL: PChar; FileName: PChar; Reserved: DWORD; lpfnCB : pointer): HResult; stdcall; external 'urlmon.dll' name 'URLDownloadToFileA';
727+
728+procedure TForm1.Button1Click(Sender: TObject);
729+var Source, Dest: string;
730+begin
731+ Source:='http://lazarus.freepascal.org';
732+ Dest:='C:\Windows\temp\data.txt';
733+ if URLDownloadToFile(nil, PChar(Source), PChar(Dest), 0, nil)=0 then
734+ showmessage('Download ok!')
735+ else
736+ showMessage('Error downloading '+Source);
737+end;
738+```
739+
740+### Showing/finding processes
741+
742+Use code like this to find a process handle based on the executable name (akin to the tasklist command):
743+
744+``` pascal
745+program ProcessFindPID;
746+
747+{$mode objfpc}{$H+}
748+
749+uses
750+ Classes, Sysutils, Windows, JwaTlHelp32;
751+
752+function QueryFullProcessImageNameW(hProcess: HANDLE; dwFlags: DWORD; lpExeName: LPTSTR;
753+var lpdwSize: DWORD): BOOL; stdcall; external 'KERNEL32';
754+
755+function FindInProcesses(const PName: string): DWord;
756+ // Looks for process with PName executable and return
757+var
758+ i: integer;
759+ CPID: DWORD;
760+ CProcName: array[0..259] of char;
761+ S: HANDLE;
762+ PE: TProcessEntry32;
763+begin
764+ Result := 0;
765+ CProcName := '';
766+ S := CreateToolHelp32Snapshot(TH32CS_SNAPALL, 0); // Create snapshot
767+ PE.DWSize := SizeOf(PE); // Set size before use
768+ I := 1;
769+ if Process32First(S, PE) then
770+ repeat
771+ CProcName := PE.szExeFile;
772+ CPID := PE.th32ProcessID;
773+ //if CProcName = '' then Writeln(IntToStr(i) + ' - (' + IntToStr(CPID) + ') Failed to get a process name')
774+ Inc(i);
775+ if UpperCase(CProcName) = UpperCase(PName) then
776+ // Found the name. Set Result to the PID of process found
777+ Result := CPID;
778+ until not Process32Next(S, PE);
779+ CloseHandle(S);
780+end;
781+
782+begin
783+ writeln('Explorer.exe has process id '+inttostr(FindInProcesses('explorer.exe')));
784+end.
785+```
786+
787+### Identify Windows Version
788+
789+There is a code example at [[WindowsVersion]]
790+
791+### Detecting Light or Dark theme
792+
793+A dark theme was introduced in the Windows 10 May 2019 Update. Users can enable or disable the dark theme via Settings \> Personalization \> Colors. Select the drop-down menu for "Choose your color" and pick Light, Dark, or Custom. Light or Dark changes the look of the Windows Start menu and the built-in applications. For details of how to detect the theme, see [[Dark theme]].
794+
795+### Task bar icon not showing on secondary monitor
796+
797+Without using a screen dump, here is a description of the issue:
798+
799+- The Lazarus IDE is on the left (primary) monitor.
800+- The application uses XML to save the last window position, and appears on the right (secondary) monitor.
801+- The application's icon always appears on the primary monitor taskbar, both when run from inside the IDE and when run standalone outside the IDE.
802+
803+The solution is to add these lines to the application's project source file before the `Application.CreateForm()` call:
804+
805+``` pascal
806+{$IFDEF WINDOWS}
807+Application.MainFormOnTaskBar := True;
808+{$ENDIF}
809+```
810+
811+The \$IFDEF/\$ENDIF is needed if you are compiling the application for multiple operating systems because this is a Windows-specific code.
812+
813+### Retrieving hard disk serial number etc
814+
815+Add this unit to your project:
816+
817+``` pascal
818+unit hddinfo;
819+{$ifdef fpc}{$mode delphi}{$endif}
820+interface
821+
822+uses Windows, SysUtils, Classes;
823+
824+const
825+ IOCTL_STORAGE_QUERY_PROPERTY = $2D1400;
826+
827+type
828+THDDInfo = class (TObject)
829+private
830+ FDriveNumber: Byte;
831+ FFileHandle: Cardinal;
832+ FInfoAvailable: Boolean;
833+ FProductRevision: string;
834+ FProductId: string;
835+ FSerialNumber: string;
836+ FVendorId: string;
837+ procedure ReadInfo;
838+ procedure SetDriveNumber(const Value: Byte);
839+public
840+ constructor Create;
841+ property DriveNumber: Byte read FDriveNumber write SetDriveNumber;
842+ property VendorId: string read FVendorId;
843+ property ProductId: string read FProductId;
844+ property ProductRevision: string read FProductRevision;
845+ property SerialNumber: string read FSerialNumber;
846+ function SerialNumberInt: Cardinal;
847+ function SerialNumberText: string;
848+ function IsInfoAvailable: Boolean;
849+end;
850+
851+implementation
852+
853+type
854+
855+STORAGE_PROPERTY_QUERY = packed record
856+ PropertyId: DWORD;
857+ QueryType: DWORD;
858+ AdditionalParameters: array[0..3] of Byte;
859+end;
860+
861+STORAGE_DEVICE_DESCRIPTOR = packed record
862+ Version: ULONG;
863+ Size: ULONG;
864+ DeviceType: Byte;
865+ DeviceTypeModifier: Byte;
866+ RemovableMedia: Boolean;
867+ CommandQueueing: Boolean;
868+ VendorIdOffset: ULONG;
869+ ProductIdOffset: ULONG;
870+ ProductRevisionOffset: ULONG;
871+ SerialNumberOffset: ULONG;
872+ STORAGE_BUS_TYPE: DWORD;
873+ RawPropertiesLength: ULONG;
874+ RawDeviceProperties: array[0..511] of Byte;
875+end;
876+
877+function ByteToChar(const B: Byte): Char;
878+begin
879+ Result := Chr(B + $30)
880+end;
881+
882+function SerialNumberToCardinal (SerNum: String): Cardinal;
883+begin
884+ HexToBin(PChar(SerNum), PChar(@Result), SizeOf(Cardinal));
885+end;
886+
887+function SerialNumberToString(SerNum: String): String;
888+var
889+ I, StrLen: Integer;
890+ Pair: string;
891+ B: Byte;
892+ Ch: Char absolute B;
893+
894+begin
895+ Result := '';
896+ StrLen := Length(SerNum);
897+
898+ if Odd(StrLen) then Exit;
899+
900+ I := 1;
901+
902+ while I < StrLen do
903+ begin
904+ Pair := Copy (SerNum, I, 2);
905+ HexToBin(PChar(Pair), PChar(@B), 1);
906+ Result := Result + Chr(B);
907+ Inc(I, 2);
908+ end;
909+
910+ I := 1;
911+
912+ while I < Length(Result) do
913+ begin
914+ Ch := Result[I];
915+ Result[I] := Result[I + 1];
916+ Result[I + 1] := Ch;
917+ Inc(I, 2);
918+ end;
919+end;
920+
921+constructor THddInfo.Create;
922+begin
923+ inherited;
924+
925+ SetDriveNumber(0);
926+end;
927+
928+function THDDInfo.IsInfoAvailable: Boolean;
929+begin
930+ Result := FInfoAvailable
931+end;
932+
933+procedure THDDInfo.ReadInfo;
934+type
935+ PCharArray = ^TCharArray;
936+ TCharArray = array[0..32767] of Char;
937+
938+var
939+ Returned: Cardinal;
940+ Status: LongBool;
941+ PropQuery: STORAGE_PROPERTY_QUERY;
942+ DeviceDescriptor: STORAGE_DEVICE_DESCRIPTOR;
943+ PCh: PChar;
944+
945+begin
946+ FInfoAvailable := False;
947+ FProductRevision := '';
948+ FProductId := '';
949+ FSerialNumber := '';
950+ FVendorId := '';
951+
952+ try
953+ FFileHandle := CreateFile(
954+ PChar('\\.\PhysicalDrive' + ByteToChar(FDriveNumber)),
955+ 0,
956+ FILE_SHARE_READ or FILE_SHARE_WRITE,
957+ nil,
958+ OPEN_EXISTING,
959+ 0,
960+ 0
961+ );
962+
963+ if FFileHandle = INVALID_HANDLE_VALUE then RaiseLastOSError;
964+
965+ ZeroMemory(@PropQuery, SizeOf(PropQuery));
966+ ZeroMemory(@DeviceDescriptor, SizeOf(DeviceDescriptor));
967+
968+ DeviceDescriptor.Size := SizeOf(DeviceDescriptor);
969+
970+ Status := DeviceIoControl(
971+ FFileHandle,
972+ IOCTL_STORAGE_QUERY_PROPERTY,
973+ @PropQuery,
974+ SizeOf(PropQuery),
975+ @DeviceDescriptor,
976+ DeviceDescriptor.Size,
977+ Returned,
978+ nil
979+ );
980+
981+ if not Status then RaiseLastOSError;
982+
983+ if DeviceDescriptor.VendorIdOffset <> 0 then
984+ begin
985+ PCh := @PCharArray(@DeviceDescriptor)^[DeviceDescriptor.VendorIdOffset];
986+ FVendorId := PCh;
987+ end;
988+
989+ if DeviceDescriptor.ProductIdOffset <> 0 then
990+ begin
991+ PCh := @PCharArray(@DeviceDescriptor)^[DeviceDescriptor.ProductIdOffset];
992+ FProductId := PCh;
993+ end;
994+
995+ if DeviceDescriptor.ProductRevisionOffset <> 0 then
996+ begin
997+ PCh := @PCharArray(@DeviceDescriptor)^[DeviceDescriptor.ProductRevisionOffset];
998+ FProductRevision := PCh;
999+ end;
1000+
1001+ if DeviceDescriptor.SerialNumberOffset <> 0 then
1002+ begin
1003+ PCh := @PCharArray(@DeviceDescriptor)^[DeviceDescriptor.SerialNumberOffset];
1004+ FSerialNumber := PCh;
1005+ end;
1006+
1007+ FInfoAvailable := True;
1008+ finally
1009+ if FFileHandle <> INVALID_HANDLE_VALUE then CloseHandle(FFileHandle);
1010+ end;
1011+end;
1012+
1013+function THDDInfo.SerialNumberInt: Cardinal;
1014+begin
1015+ Result := 0;
1016+ if ((IsInfoAvailable = True) and (FSerialNumber <> '')) then Result := SerialNumberToCardinal(FSerialNumber)
1017+end;
1018+
1019+function THDDInfo.SerialNumberText: string;
1020+begin
1021+ Result := '';
1022+ if ((IsInfoAvailable = True) and (FSerialNumber <> '')) then Result := SerialNumberToString(FSerialNumber)
1023+end;
1024+
1025+procedure THDDInfo.SetDriveNumber(const Value: Byte);
1026+begin
1027+ FDriveNumber := Value;
1028+ ReadInfo;
1029+end;
1030+
1031+end.
1032+```
1033+
1034+To use the hddinfo unit:
1035+
1036+``` pascal
1037+unit Unit1;
1038+
1039+{$mode objfpc}{$H+}
1040+
1041+interface
1042+
1043+uses
1044+ Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, Hddinfo;
1045+
1046+type
1047+
1048+ { TForm1 }
1049+
1050+ TForm1 = class(TForm)
1051+ Button1: TButton;
1052+ Memo1: TMemo;
1053+ procedure Button1Click(Sender: TObject);
1054+ private
1055+
1056+ public
1057+
1058+ end;
1059+
1060+var
1061+ Form1: TForm1;
1062+
1063+implementation
1064+
1065+{$R *.lfm}
1066+
1067+{ TForm1 }
1068+
1069+procedure TForm1.Button1Click(Sender: TObject);
1070+var
1071+ HDDInfo : THDDInfo;
1072+begin
1073+ HDDInfo := THDDInfo.Create();
1074+ HDDInfo.DriveNumber := 0;
1075+ if HDDInfo.IsInfoAvailable then
1076+ try
1077+ begin
1078+ Memo1.Lines.Add('DriveNum = ' + HDDInfo.DriveNumber.ToString);
1079+ Memo1.Lines.Add('VendorID = ' + HDDInfo.VendorId);
1080+ Memo1.Lines.Add('ProductID = ' + HDDInfo.ProductId);
1081+ Memo1.Lines.Add('Revision = ' + HDDInfo.ProductRevision);
1082+ Memo1.Lines.Add('SerialNo = ' + HDDInfo.SerialNumberText);
1083+ Memo1.Lines.Add('SerialNo = ' + HDDInfo.SerialNumber);
1084+ Memo1.Lines.Add('SerialNo = ' + HDDInfo.SerialNumberInt.ToString);
1085+ end;
1086+ finally
1087+ HDDInfo.Free;
1088+ end;
1089+end;
1090+
1091+end.
1092+```
1093+
1094+Note: The THDDInfo Delphi unit is Copyright Artem Parlyuk - free for commercial use but requires the copyright to be acknowledged (eg in About). Distribution of the source code is allowed as long as no alternations are made to the contents.
1095+
1096+### Retrieving system information
1097+
1098+The SMBIOS (System Management BIOS) is a standard developed by the [DMTF](https://www.dmtf.org/). The information stored in the SMBIOS includes device manufacturers, model name, serial number, BIOS version, asset tag, processors, ports and installed device memory. The [TSMBIOS library](https://github.com/RRUZ/tsmbios/) allows access to the System Management BIOS (SMBIOS) using the Object Pascal language (Delphi or Free Pascal).
1099+
1100+## Troubleshooting
1101+
1102+### A referral was returned from the server
1103+
1104+From Windows 7 onwards this error can occur whereby a dialog box appears with the message "A referral was returned from the server" and your program will not execute. It turns out that the culprit is enabling "UI Access" in Project Options \> Application \> For Windows \[x\] UI Access. Uncheck that UI Access option, recompile and the blocking error disappears!
1105+
1106+What is UI Access? Microsoft documentation states: "Applications that are not providing accessibility should set this flag to false. Applications that are required to drive input to other windows on the desktop (on-screen keyboard, for example) should set this value to true."
1107+
1108+### Lazarus 32 bit: External SIGSEGV exception when running with debugging
1109+
1110+There is a common problem with Lazarus 32 Bit: If "Automatic" is choosen as type of debugging info, Lazarus chooses the "Stabs" format which is outdated for Windows.
1111+
1112+Go to Project \> Project options \> Compiler Options \> Debugging in the Lazarus Menu and choose "Dwarf with sets" as the debugger info.
1113+
1114+### FPC 2.6.x/Lazarus warning (Missing support for SEH)
1115+
1116+> **Warning:** If you can avoid it, do not use Win64 builds of Lazarus based on FPC 2.6.x and earlier (this includes Lazarus 1.x). See below for details.
1117+
1118+Please be aware that all Lazarus 1.x releases use FPC 2.6.x. FPC 2.6.x (and probably earlier versions as well) does not properly support Windows 64 bit. Therefore, please use the 32 bit Lazarus IDE on Win64. If it is absolutely necessary to build 64 bit executables (eg explorer extensions), please install the 64 bit cross compiler add-on for the 32 bit IDE.
1119+
1120+Details of the bug: on Windows 64, exceptions in (third party) DLLs may be raised using SEH. These exceptions should be handled within the DLL itself.
1121+
1122+However, FPC sees an (incorrect) FPC exception which may cause your programs (or Lazarus) to crash. This applies to DLLs like printer drivers, database drivers, Windows explorer extensions.
1123+
1124+The issue has been fixed in the FPC development version but it is a major change and it will not be backported to FPC 2.6.x.
1125+
1126+Relevant bug reports include <http://bugs.freepascal.org/view.php?id=12742>
1127+
1128+---
1129+*From the Free Pascal wiki, page "Windows Programming Tips", as it stood on 2022-09-09 after a change by Wp, out of the wiki's dump of 2024-05-26. Copyright stays with the author who wrote it, according to the old wiki's [[Licensing]] page. If you have concerns about this material, [message the admin](/wiki-contact).*

Back to history