│ English (en) │ français (fr) │ 中文（中国大陆） (zh_CN) │

Windows 编程技巧

This article applies to Windows only.

本文专门介绍桌面版（含服务器版） Windows 编程技巧。

关于 Windows 编程的文章

高 DPI - 如何让应用程序感知 Windows 7 的高分辨率 DPI。
Aero Glass - 在 Windows 7 中如何让 Lazarus Form 应用 Aero Glass 透明特效。
Windows 图标 - 如何设计尺寸合适的图标。
Inno Setup 的用法 - 如何创建支持文件关联的安装文件。

Windows 特有的编译选项

最明显的选项是 -W。GUI 应用程序则需要 -WG，参见项目选项 / 编译器选项 / 配置和目标 / 特定目标选项 / Win32 图形界面应用程序。GUI 应用程序不会显示控制台，writeln 和 readln 也就不可用了，否则会报 File not open 错误。不选中 -WG 选项则会创建控制台应用程序（等效于 -WC）。

编写适用于 Windows 的跨平台代码

虽然可以使用仅 Windows 支持的代码（比如 windows 单元），但只要稍加小心，即可做好跨平台的准备（如使用 lclintf 单元）。

详情请参阅 [[Multiplatform Programming Guide#Windows specific issues|Windows 相关议题]。

COM 编程

导入并使用 COM 库

若要导入并使用 COM 库，第一步是从中生成接口定义。可以利用 Free Pascal 的 importtl 程序，位于 fpc/utils/importtl。编译好的二进制文件在此：http://sourceforge.net/projects/p-tools/files/ImportTL/

例如可如下用于 MSAA：

importtl.exe C:\Windows\system32\oleacc.dll

这会在当前目录生成 pascal 类库单元 Accessibility_1_1_TLB.pas，

创建导出 COM 对象的库

ToDo

Windows Sensor/Location API

自 Windows 7 开始支持。参见可能的 Windows 实现代码

ActiveX 控件

较新的 Lazarus 中可以使用 ActiveX 控件，参见 LazActiveX。

系统服务程序

用 Lazarus 和 FPC 很容易编写 Windows 服务程序。参见守护程序和服务程序。

sleep(n) 和 Application.ProcessMessages 的用法

Windows 有一套消息机制（参见 https://docs.microsoft.com/en-us/windows/desktop/winmsg/messages-and-message-queues），用于与所有正在运行的应用程序进行“对话”。而用了 sleep(n) 则会阻止消息的传递。在这种情况下，请使用 Application.ProcessMessages 替换阻塞式运行的 sleep(n)。操作系统必须有时间来处理消息队列。Application.ProcessMessages 会处理应用程序消息队列中所有等待着的系统消息。

sleep(0) 是个例外。它含义特殊，意味着放弃时间片。其他任何 sleep(n) 调用几乎肯定都是不良的编程。

请注意，在每个事件之后（如在每次 OnClick 之后），LCL 都会自动调用 Application.ProcessMessages。因此，只有事件处理程序中执行了某些耗时明显的处理时，才需要显式调用它。当然，可能事件处理程序本就不应该去执行什么耗时明显的处理任务。而是应该去调用其他函数，该函数可能需要用 Application.ProcessMessages 确保应用程序能继续响应事件，而不会失去响应。不过即使是这种情况下，最好还是用“busy”光标或进度条提醒用户，处理时间会比较长（比如在压缩文件的时候）。

谨防意外后果......在代码中像撒魔粉一样到处使用 Application.ProcessMessages 貌似不错，但请考虑一下，如果应用程序忙于处理任务时，不耐烦的用户再次点击了按钮，那会发生什么呢。第二次点击将被放入 Windows 消息队列，第二个同样的任务会被触发。那么结果可能会交错输出到文件中，而这可能不应该发生。

Windows 可执行文件的代码签名

对 Windows 可执行文件进行代码签名，可以避免最终用户在运行时收到软件发布者“未知”的警告，详情请参阅 Windows 中的代码签名。

示例代码片段

文件关联

若要向文件关联添加图标并注册，请用 FileAssociation 组件。如果由于某种原因不能使用 FileAssociation 组件，或者程序需不经提权即以管理员身份供所有用户运行，那么 Inno Setup 脚本可能最合适了。请参阅 Inno Setup。

确保单例运行

若要确保程序只能运行单个实例，可以使用 UniqueInstance 组件，Windows 和 Linux 均支持（请注意，macOS 默认就禁止同一应用程序多次运行）。

或者，也可如下使用 mutex 单元，Windows 和 Linux 也都支持：

{Author: Serguei Tarassov (from  https://arbinada.com/en/node/1426)}

unit mutex;

{$mode objfpc}{$H+}

interface

type
  TMutex = class
  private
    FFileHandle: integer;
  public
    constructor Create(const AName: string; const WaitForMSec: integer = 10000);
    destructor Destroy; override;
  end;

implementation

uses
  Classes, SysUtils, DateUtils,
  {$IFDEF WINDOWS}
  Windows
  {$ENDIF};

function GetTempDir: string;
begin
{$IFDEF WINDOWS}
  SetLength(Result, 255);
  SetLength(Result, GetTempPath(255, (PChar(Result))));
{$ENDIF}
{$IFDEF LINUX}
  Result := GetEnv('TMPDIR');
  if Result = '' then
    Result := '/tmp/'
  else if Result[Length(Result)] <> PathDelim then
    Result := Result + PathDelim;
{$ENDIF}
end;

constructor TMutex.Create(const AName: string; const WaitForMSec: integer);
  function NextAttempt(const MaxTime: TDateTime): boolean;
  begin
    Sleep(1);
    Result := Now < MaxTime;
  end;

var
  MaxTime: TDateTime;
  LockFileName: string;
begin
  inherited Create;
  LockFileName := IncludeTrailingPathDelimiter(GetTempDir) + AName + '.tmp';
  MaxTime := IncMillisecond(Now, WaitForMSec);
  repeat
    if FileExists(LockFileName) then
      FFileHandle := FileOpen(LockFileName, fmShareExclusive)
    else
      FFileHandle := FileCreate(LockFileName, fmShareExclusive);
  until (FFileHandle <> -1) or not NextAttempt(MaxTime);
  if FFileHandle = -1 then
    raise Exception.CreateFmt('Unable to lock mutex (File: %s; waiting: %d msec)', [LockFileName, WaitForMSec]);
end;

destructor TMutex.Destroy;
begin
  if FFileHandle <> -1 then
    FileClose(FFileHandle);
  inherited;
end;

end.

如下加入项目文件即可使用：

{$IFDEF WINDOWS}
var
  MyMutex: TMutex;
{$ENDIF}
begin
  Application.Title := 'My App';

  {$IFDEF WINDOWS}
  Try
    MyMutex := TMutex.Create('MyAppMutex', 100);
  Except
    ShowMessage(Application.Title + ' is already running.');
    MyMutex.Free;
    Exit;
  End;
  {$ENDIF}

  Application.Initialize;
  Application.CreateForm(TForm1, Form1);
  Application.Run;

  {$IFDEF WINDOWS}
  MyMutex.Free;
  {$ENDIF}
end.

显示内存和硬盘空间

...
Uses
  Windows;
...

procedure TForm1.MemoryClick(Sender: TObject);
Var
  Memory: TMemoryStatus;

begin
  InfoMemo.Text := '';

  Memory.dwLength := SizeOf(Memory);
  GlobalMemoryStatus(Memory);

  InfoMemo.Lines.Add(Format('Memory total: %f GB', [Memory.dwTotalPhys /1024 /1024 /1024]));
  InfoMemo.Lines.Add(Format('Memory free: %f GB', [Memory.dwAvailPhys /1024 /1024 /1024]));
  InfoMemo.Lines.Add(Format('Memory in use: %d%%', [Memory.dwMemoryLoad]));
  InfoMemo.Lines.Add(Format('Pagefile size: %f GB', [Memory.dwTotalPageFile /1024 /1024 /1024]));
  InfoMemo.Lines.Add(Format('Pagefile free: %f GB', [Memory.dwAvailPageFile /1024 /1024 /1024]));
  InfoMemo.Lines.Add(Format('Virtual memory total: %f GB', [Memory.dwTotalVirtual /1024 /1024 /1024]));
  InfoMemo.Lines.Add(Format('Virtual memory free: %f GB', [Memory.dwAvailVirtual /1024 /1024 /1024]));
  InfoMemo.Lines.Add(Format('Disk space total: %f GB', [DiskSize(0) /1024 /1024 /1024]));
  InfoMemo.Lines.Add(Format('Disk space free: %f GB', [DiskFree(0) /1024 /1024 /1024])); 
end;

用 Windows 原生 wininet 访问 Web

{$IFDEF WINDOWS}
// 需用 Windows WinInet，
// 避免 TFPHttpClient 的 HTTPS 功能需提供两个 OpenSSL DLL 文件。
// WinINet API 也会读取 Internet Explorer 设置中的连接和代理设置，好事还是坏事？
 
uses
  wininet;

function GetWebPage(const Url: string): string;
var
  NetHandle: HINTERNET;
  UrlHandle: HINTERNET;
  Buffer: array[0..1023] of Byte;
  BytesRead: dWord;
  StrBuffer: UTF8String;
begin
  Result := '';
  BytesRead := Default(dWord);
  NetHandle := InternetOpen('Mozilla/5.0(compatible; WinInet)', INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
 
  // NetHandle valid?
  if Assigned(NetHandle) then
    Try
      UrlHandle := InternetOpenUrl(NetHandle, PChar(Url), nil, 0, INTERNET_FLAG_RELOAD, 0);
 
      // UrlHandle valid?
      if Assigned(UrlHandle) then
        Try
          repeat
            InternetReadFile(UrlHandle, @Buffer, SizeOf(Buffer), BytesRead);
            SetString(StrBuffer, PAnsiChar(@Buffer[0]), BytesRead);
            Result := Result + StrBuffer;
          until BytesRead = 0;
        Finally
          InternetCloseHandle(UrlHandle);
        end
      // o/w UrlHandle invalid
      else
        ShowMessage('Cannot open URL: ' + Url);
    Finally
      InternetCloseHandle(NetHandle);
    end
  // NetHandle invalid
  else
    raise Exception.Create('Unable to initialize WinInet');
end;
{$ENDIF}

列出所有可用的磁盘驱动器

program listdevices;

{$ifdef fpc}{$mode delphi}{$endif}
{$apptype console}

uses
  Windows;

var
  Drive: Char;
  DriveLetter: string;
  OldMode: Word; 
begin
  WriteLn('The following drives were found in this computer:');
  WriteLn('');

  // 软盘或 Zip 驱动器为空，可能会触发 Windows 错误。
  // 这里禁止报错
  // 注意，忽略这类报错的其他方案是利用 DEVICE_IO_CONTROL.
  OldMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  try 

    // 搜索所有驱动器字母
    for Drive := 'A' to 'Z' do
    begin
      DriveLetter := Drive + ':\';
   
      case GetDriveType(PChar(DriveLetter)) of
       DRIVE_REMOVABLE: WriteLn(DriveLetter + ' Floppy Drive');
       DRIVE_FIXED:     WriteLn(DriveLetter + ' Fixed Drive');
       DRIVE_REMOTE:    WriteLn(DriveLetter + ' Network Drive');
       DRIVE_CDROM:     WriteLn(DriveLetter + ' CD-ROM Drive');
       DRIVE_RAMDISK:   WriteLn(DriveLetter + ' RAM Disk');
      end;
    end;

  finally
    // 恢复之前的 Windows 检错模式
    SetErrorMode(OldMode); 
  end;

  // 暂停一下
  WriteLn('');
  WriteLn('Please press <ENTER> to exit the program.');
  ReadLn(DriveLetter);
end.

创建快捷方式（.lnk）文件

在桌面上（放在任何位置都很简单）创建快捷方式。改编自 Felipe Monteiro de Carvalho 的帖子。ISLink 对象还有更多用于修改快捷方式的方法……

uses
...
windows, shlobj {用于特殊文件夹}, ActiveX, ComObj;
...
procedure CreateDesktopShortCut(Target, TargetArguments, ShortcutName: string);
var
  IObject: IUnknown;
  ISLink: IShellLink;
  IPFile: IPersistFile;
  PIDL: PItemIDList;
  InFolder: array[0..MAX_PATH] of Char;
  TargetName: String;
  LinkName: WideString;
begin
  { 创建 IShellLink 实例}
  IObject := CreateComObject(CLSID_ShellLink);
  ISLink := IObject as IShellLink;
  IPFile := IObject as IPersistFile;

  ISLink.SetPath(pChar(Target));
  ISLink.SetArguments(pChar(TargetArguments));
  ISLink.SetWorkingDirectory(pChar(ExtractFilePath(Target)));

  { 获取桌面位置 }
  SHGetSpecialFolderLocation(0, CSIDL_DESKTOPDIRECTORY, PIDL);
  SHGetPathFromIDList(PIDL, InFolder);
  LinkName := InFolder + PathDelim + ShortcutName+'.lnk';

  { 创建链接 }
  IPFile.Save(PWChar(LinkName), false);
end;

弹出/关闭 CD or DVD

Windows 下的代码请参阅 CD open close。

启用或禁用设备

以下代码可启用或禁用 Windows 设备，比如重置串口或 USB 设备可能就很有用。

unit controlwindevice;

{ Enable Disable windows devices

  Copyright (c) 2010-2012 Ludo Brands

  Permission is hereby granted, free of charge, to any person obtaining a copy
  of this software and associated documentation files (the "Software"), to
  deal in the Software without restriction, including without limitation the
  rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
  sell copies of the Software, and to permit persons to whom the Software is
  furnished to do so, subject to the following conditions:

  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
  IN THE SOFTWARE.
}


{$mode delphi}{$H+}

interface

uses
  Classes, SysUtils,dynlibs,windows;

const
  GUID_DEVCLASS_NET : TGUID = '{4D36E972-E325-11CE-BFC1-08002BE10318}';
  GUID_DEVCLASS_PORT : TGUID = '{4D36E978-E325-11CE-BFC1-08002BE10318}';

type
  TDeviceControlResult=(DCROK,DCRErrEnumDeviceInfo,DCRErrSetClassInstallParams,
    DCRErrDIF_PROPERTYCHANGE);

function LoadDevices(GUID_DevClass:TGUID):TStringList;
function EnableDevice(SelectedItem: DWord):TDeviceControlResult;
function DisableDevice(SelectedItem: DWord):TDeviceControlResult;

implementation

// 设置 API，基于 SetupApi.pas JEDI 库
const
    DIF_PROPERTYCHANGE                = $00000012;
    DICS_ENABLE     = $00000001;
    DICS_DISABLE    = $00000002;
    DICS_FLAG_GLOBAL         = $00000001;  // make change in all hardware profiles
    DIGCF_PRESENT         = $00000002;
    SPDRP_DEVICEDESC                  = $00000000; // DeviceDesc (R/W)
    SPDRP_CLASS                       = $00000007; // Class (R--tied to ClassGUID)
    SPDRP_CLASSGUID                   = $00000008; // ClassGUID (R/W)
    SPDRP_FRIENDLYNAME                = $0000000C; // FriendlyName (R/W)

type
  HDEVINFO = Pointer;
  DI_FUNCTION = LongWord;    // Function type for device installer

  PSPClassInstallHeader = ^TSPClassInstallHeader;
  SP_CLASSINSTALL_HEADER = packed record
    cbSize: DWORD;
    InstallFunction: DI_FUNCTION;
  end;
  TSPClassInstallHeader = SP_CLASSINSTALL_HEADER;

  PSPPropChangeParams = ^TSPPropChangeParams;
  SP_PROPCHANGE_PARAMS = packed record
    ClassInstallHeader: TSPClassInstallHeader;
    StateChange: DWORD;
    Scope: DWORD;
    HwProfile: DWORD;
  end;
  TSPPropChangeParams = SP_PROPCHANGE_PARAMS;

  PSPDevInfoData = ^TSPDevInfoData;
  SP_DEVINFO_DATA = packed record
    cbSize: DWORD;
    ClassGuid: TGUID;
    DevInst: DWORD; // DEVINST handle
    Reserved: ULONG_PTR;
  end;
  TSPDevInfoData = SP_DEVINFO_DATA;

  TSetupDiEnumDeviceInfo = function(DeviceInfoSet: HDEVINFO;
    MemberIndex: DWORD; var DeviceInfoData: TSPDevInfoData): LongBool; stdcall;
  TSetupDiSetClassInstallParamsA = function(DeviceInfoSet: HDEVINFO;
    DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader;
    ClassInstallParamsSize: DWORD): LongBool; stdcall;
  TSetupDiSetClassInstallParamsW = function(DeviceInfoSet: HDEVINFO;
    DeviceInfoData: PSPDevInfoData; ClassInstallParams: PSPClassInstallHeader;
    ClassInstallParamsSize: DWORD): LongBool; stdcall;
  TSetupDiSetClassInstallParams = TSetupDiSetClassInstallParamsA;
  TSetupDiCallClassInstaller = function(InstallFunction: DI_FUNCTION;
    DeviceInfoSet: HDEVINFO; DeviceInfoData: PSPDevInfoData): LongBool; stdcall;
  TSetupDiGetClassDevs = function(ClassGuid: PGUID; const Enumerator: PAnsiChar;
    hwndParent: HWND; Flags: DWORD): HDEVINFO; stdcall;
  TSetupDiGetDeviceRegistryPropertyA = function(DeviceInfoSet: HDEVINFO;
    const DeviceInfoData: TSPDevInfoData; Property_: DWORD;
    var PropertyRegDataType: DWORD; PropertyBuffer: PBYTE; PropertyBufferSize: DWORD;
    var RequiredSize: DWORD): BOOL; stdcall;
  TSetupDiGetDeviceRegistryPropertyW = function(DeviceInfoSet: HDEVINFO;
    const DeviceInfoData: TSPDevInfoData; Property_: DWORD;
    var PropertyRegDataType: DWORD; PropertyBuffer: PBYTE; PropertyBufferSize: DWORD;
    var RequiredSize: DWORD): BOOL; stdcall;
  TSetupDiGetDeviceRegistryProperty = TSetupDiGetDeviceRegistryPropertyA;

var
  DevInfo: hDevInfo;
  SetupDiEnumDeviceInfo: TSetupDiEnumDeviceInfo;
  SetupDiSetClassInstallParams: TSetupDiSetClassInstallParams;
  SetupDiCallClassInstaller: TSetupDiCallClassInstaller;
  SetupDiGetClassDevs: TSetupDiGetClassDevs;
  SetupDiGetDeviceRegistryProperty: TSetupDiGetDeviceRegistryProperty;

var
  SetupApiLoadCount:integer=0;

function LoadSetupApi: Boolean;
var SetupApiLib:TLibHandle;
begin
  Result := True;
  Inc(SetupApiLoadCount);
  if SetupApiLoadCount > 1 then
    Exit;
  SetupApiLib:=LoadLibrary('SetupApi.dll');
  Result := SetupApiLib<>0;
  if Result then
  begin
    SetupDiEnumDeviceInfo := GetProcedureAddress(SetupApiLib, 'SetupDiEnumDeviceInfo');
    SetupDiSetClassInstallParams := GetProcedureAddress(SetupApiLib, 'SetupDiSetClassInstallParamsA');
    SetupDiCallClassInstaller := GetProcedureAddress(SetupApiLib, 'SetupDiCallClassInstaller');
    SetupDiGetClassDevs := GetProcedureAddress(SetupApiLib, 'SetupDiGetClassDevsA');
    SetupDiGetDeviceRegistryProperty := GetProcedureAddress(SetupApiLib, 'SetupDiGetDeviceRegistryPropertyA');
  end;
end;

// implementation

function StateChange(NewState, SelectedItem: DWord;
  hDevInfo: hDevInfo): TDeviceControlResult;
var
  PropChangeParams: TSPPropChangeParams;
  DeviceInfoData: TSPDevInfoData;
begin
  PropChangeParams.ClassInstallHeader.cbSize := SizeOf(TSPClassInstallHeader);
  DeviceInfoData.cbSize := SizeOf(TSPDevInfoData);
  // 获取选中项的句柄
  if (not SetupDiEnumDeviceInfo(hDevInfo, SelectedItem, DeviceInfoData)) then
  begin
    Result := DCRErrEnumDeviceInfo;
    exit;
  end;
  // 设置 PropChangeParams 结构体.
  PropChangeParams.ClassInstallHeader.InstallFunction := DIF_PROPERTYCHANGE;
  PropChangeParams.Scope := DICS_FLAG_GLOBAL;
  PropChangeParams.StateChange := NewState;
  if (not SetupDiSetClassInstallParams(hDevInfo, @DeviceInfoData,
     PSPClassInstallHeader(@PropChangeParams), SizeOf(PropChangeParams))) then
  begin
    Result := DCRErrSetClassInstallParams;
    exit;
  end;
  // 调用 ClassInstaller 并执行修改
  if (not SetupDiCallClassInstaller(DIF_PROPERTYCHANGE, hDevInfo, @DeviceInfoData)) then
  begin
    Result := DCRErrDIF_PROPERTYCHANGE;
    exit;
  end;
  Result := DCROK;
end;

function GetRegistryProperty(PnPHandle: HDEVINFO;
  DevData: TSPDevInfoData; Prop: DWORD; Buffer: PChar;
  dwLength: DWord): Boolean;
var
  aBuffer: array[0..256] of Char;
begin
  dwLength := 0;
  aBuffer[0] := #0;
  SetupDiGetDeviceRegistryProperty(PnPHandle, DevData, Prop, Prop, PBYTE(@aBuffer[0]), SizeOf(aBuffer), dwLength);
  StrCopy(Buffer, aBuffer);
  Result := Buffer^ <> #0;
end;

function ConstructDeviceName(DeviceInfoSet: hDevInfo;
  DeviceInfoData: TSPDevInfoData; Buffer: PChar; dwLength: DWord): Boolean;
const
  UnknownDevice = '<Unknown Device>';
begin
  if (not GetRegistryProperty(DeviceInfoSet, DeviceInfoData, SPDRP_FRIENDLYNAME, Buffer, dwLength)) then
  begin
    if (not GetRegistryProperty(DeviceInfoSet, DeviceInfoData, SPDRP_DEVICEDESC, Buffer, dwLength)) then
    begin
      if (not GetRegistryProperty(DeviceInfoSet, DeviceInfoData, SPDRP_CLASS, Buffer, dwLength)) then
      begin
        if (not GetRegistryProperty(DeviceInfoSet, DeviceInfoData, SPDRP_CLASSGUID, Buffer, dwLength)) then
        begin
          dwLength := DWord(SizeOf(UnknownDevice));
          Buffer := Pointer(LocalAlloc(LPTR, Cardinal(dwLength)));
          StrCopy(Buffer, UnknownDevice);
        end;
      end;
    end;
  end;
  Result := true;
end;


function LoadDevices(GUID_DevClass:TGUID):TStringList;
var
  DeviceInfoData: TSPDevInfoData;
  i: DWord;
  pszText: PChar;

begin
  if (not LoadSetupAPI) then
    begin
    result:=nil;
    exit;
    end;
  DevInfo := nil;
  // 获取指向系统所有设备的句柄
  DevInfo := SetupDiGetClassDevs(@GUID_DevClass, nil, 0, DIGCF_PRESENT);
  if (DevInfo = Pointer(INVALID_HANDLE_VALUE)) then
  begin
    result:=nil;
    exit;
  end;
  Result:=TStringList.Create;
  DeviceInfoData.cbSize := SizeOf(TSPDevInfoData);
  i := 0;
  // 遍历获取每个设备
  while SetupDiEnumDeviceInfo(DevInfo, i, DeviceInfoData) do
  begin
    GetMem(pszText, 256);
    try
      // 获取设备的名称
      ConstructDeviceName(DevInfo, DeviceInfoData, pszText, DWord(nil));
      Result.AddObject(pszText,Tobject(i));
    finally
      FreeMem(pszText);
      inc(i);
    end;
  end;
end;

function EnableDevice(SelectedItem: DWord):TDeviceControlResult;

begin
  result:=StateChange(DICS_ENABLE, SelectedItem , DevInfo);
end;

function DisableDevice(SelectedItem: DWord):TDeviceControlResult;

begin
  result:=StateChange(DICS_DISABLE, SelectedItem , DevInfo);
end;

end.

以下程序列出所有端口，前面带有数字。

输入某个数字，对应端口将被禁用。再敲回车，端口将被启用。

program devicetest;

{$mode delphi}{$H+}

uses
  Classes, controlwindevice;
var
  sl:tstringlist;
  i:integer;
begin
  sl:=Loaddevices(GUID_DEVCLASS_PORT);
  for i:=0 to sl.count-1 do
    writeln(i,' : ',sl[i]);
  readln(i);
  if DisableDevice(i)=DCROK then
    writeln(sl[i],' disabled');
  readln;
  if EnableDevice(i)=DCROK then
    writeln(sl[i],' enabled');
  sl.Free;
  readln;
end.

用 urlmon 下载文件

Windows 内置的 Urlmon.dll 可用于完成从网址下载文件之类的任务，并且支持 SSL/TLS 连接。

仅限 Windows 系统；跨平台解决方案请查看 fphttpclient、Synapse 和 Indy。

function URLDownloadToFile(pCaller: pointer; URL: PChar; FileName: PChar; Reserved: DWORD; lpfnCB : pointer): HResult; stdcall; external 'urlmon.dll' name 'URLDownloadToFileA';

procedure TForm1.Button1Click(Sender: TObject);
var Source, Dest: string;
begin
 Source:='http://lazarus.freepascal.org';
 Dest:='C:\Windows\temp\data.txt';
 if URLDownloadToFile(nil, PChar(Source), PChar(Dest), 0, nil)=0 then
  showmessage('Download ok!')
 else
  showMessage('Error downloading '+Source);
end;

显示/查找进程

以下代码可根据可执行文件名称查找进程句柄（类似于 tasklist 命令）：

program ProcessFindPID;

{$mode objfpc}{$H+}

uses 
  Classes, Sysutils, Windows, JwaTlHelp32;

function QueryFullProcessImageNameW(hProcess: HANDLE; dwFlags: DWORD; lpExeName: LPTSTR;
var lpdwSize: DWORD): BOOL; stdcall; external 'KERNEL32';

function FindInProcesses(const PName: string): DWord;
  // Looks for process with PName executable and return
var
  i: integer;
  CPID: DWORD;
  CProcName: array[0..259] of char;
  S: HANDLE;
  PE: TProcessEntry32;
begin
  Result := 0;
  CProcName := '';
  S := CreateToolHelp32Snapshot(TH32CS_SNAPALL, 0); // Create snapshot
  PE.DWSize := SizeOf(PE); // Set size before use
  I := 1;
  if Process32First(S, PE) then
    repeat
      CProcName := PE.szExeFile;
      CPID := PE.th32ProcessID;
      //if CProcName = '' then Writeln(IntToStr(i) + ' - (' + IntToStr(CPID) + ') Failed to get a process name')
      Inc(i);
      if UpperCase(CProcName) = UpperCase(PName) then
        // Found the name. Set Result to the PID of process found
        Result := CPID;
    until not Process32Next(S, PE);
  CloseHandle(S);
end;

begin
  writeln('Explorer.exe has process id '+inttostr(FindInProcesses('explorer.exe')));
end.

识别 Windows 版本

代码示例见 WindowsVersion。

检测浅色或深色主题

Windows 10 在 2019 年 5 月的更新中引入了深色主题。用户可以通过“设置 > 个性化 > 颜色”功能启用或禁用深色主题。在“选择颜色”下拉菜单选择“浅色”、“深色”或“自定义”即可。浅色或深色主题会修改 Windows 开始菜单和内置应用程序的外观。有关如何检测主题的详细信息，请参阅深色主题。

任务栏图标无法显示在第二个显示器

不用屏幕 dump 时，问题描述如下：

Lazarus IDE 在左显示器（主显示器）。
应用程序用 XML 保存最近的窗口位置，显示在右显示器（第二显示器）。
应用程序图标总是显示在主显示器的任务栏中，无论是在 IDE 中运行还是在外独立运行。

解决方案是在调用之前将下述行加入项目源文件中：置于 Application.CreateForm() 之前。

{$IFDEF WINDOWS}
Application.MainFormOnTaskBar := True;
{$ENDIF}

若要针对多种操作系统进行编译，则需使用 $IFDEF/$ENDIF，因为是特定于 Windows 的代码。

获取硬盘序列号等

在项目中加入以下单元：

unit hddinfo;
{$ifdef fpc}{$mode delphi}{$endif}
interface

uses Windows, SysUtils, Classes;

const
  IOCTL_STORAGE_QUERY_PROPERTY = $2D1400;

type
THDDInfo = class (TObject)
private
  FDriveNumber: Byte;
  FFileHandle: Cardinal;
  FInfoAvailable: Boolean;
  FProductRevision: string;
  FProductId: string;
  FSerialNumber: string;
  FVendorId: string;
  procedure ReadInfo;
  procedure SetDriveNumber(const Value: Byte);
public
  constructor Create;
  property DriveNumber: Byte read FDriveNumber write SetDriveNumber;
  property VendorId: string read FVendorId;
  property ProductId: string read FProductId;
  property ProductRevision: string read FProductRevision;
  property SerialNumber: string read FSerialNumber;
  function SerialNumberInt: Cardinal;
  function SerialNumberText: string;
  function IsInfoAvailable: Boolean;
end;

implementation

type

STORAGE_PROPERTY_QUERY = packed record
  PropertyId: DWORD;
  QueryType: DWORD;
  AdditionalParameters: array[0..3] of Byte;
end;

STORAGE_DEVICE_DESCRIPTOR = packed record
  Version: ULONG;
  Size: ULONG;
  DeviceType: Byte;
  DeviceTypeModifier: Byte;
  RemovableMedia: Boolean;
  CommandQueueing: Boolean;
  VendorIdOffset: ULONG;
  ProductIdOffset: ULONG;
  ProductRevisionOffset: ULONG;
  SerialNumberOffset: ULONG;
  STORAGE_BUS_TYPE: DWORD;
  RawPropertiesLength: ULONG;
  RawDeviceProperties: array[0..511] of Byte;
end;

function ByteToChar(const B: Byte): Char;
begin
  Result := Chr(B + $30)
end;

function SerialNumberToCardinal (SerNum: String): Cardinal;
begin
  HexToBin(PChar(SerNum), PChar(@Result), SizeOf(Cardinal));
end;

function SerialNumberToString(SerNum: String): String;
var
  I, StrLen: Integer;
  Pair: string;
  B: Byte;
  Ch: Char absolute B;

begin
  Result := '';
  StrLen := Length(SerNum);

  if Odd(StrLen) then Exit;

  I := 1;

  while I < StrLen do
  begin
    Pair := Copy (SerNum, I, 2);
    HexToBin(PChar(Pair), PChar(@B), 1);
    Result := Result + Chr(B);
    Inc(I, 2);
  end;

  I := 1;

  while I < Length(Result) do
  begin
    Ch := Result[I];
    Result[I] := Result[I + 1];
    Result[I + 1] := Ch;
    Inc(I, 2);
  end;
end;

constructor THddInfo.Create;
begin
  inherited;

  SetDriveNumber(0);
end;

function THDDInfo.IsInfoAvailable: Boolean;
begin
  Result := FInfoAvailable
end;

procedure THDDInfo.ReadInfo;
type
  PCharArray = ^TCharArray;
  TCharArray = array[0..32767] of Char;

var
  Returned: Cardinal;
  Status: LongBool;
  PropQuery: STORAGE_PROPERTY_QUERY;
  DeviceDescriptor: STORAGE_DEVICE_DESCRIPTOR;
  PCh: PChar;

begin
  FInfoAvailable := False;
  FProductRevision := '';
  FProductId := '';
  FSerialNumber := '';
  FVendorId := '';

  try
    FFileHandle := CreateFile(
                     PChar('\\.\PhysicalDrive' + ByteToChar(FDriveNumber)),
                     0,
                     FILE_SHARE_READ or FILE_SHARE_WRITE,
                     nil,
                     OPEN_EXISTING,
                     0,
                     0
                   );

    if FFileHandle = INVALID_HANDLE_VALUE then RaiseLastOSError;

    ZeroMemory(@PropQuery, SizeOf(PropQuery));
    ZeroMemory(@DeviceDescriptor, SizeOf(DeviceDescriptor));

    DeviceDescriptor.Size := SizeOf(DeviceDescriptor);

    Status := DeviceIoControl(
                FFileHandle,
                IOCTL_STORAGE_QUERY_PROPERTY,
                @PropQuery,
                SizeOf(PropQuery),
                @DeviceDescriptor,
                DeviceDescriptor.Size,
                Returned,
                nil
              );

    if not Status then RaiseLastOSError;

    if DeviceDescriptor.VendorIdOffset <> 0 then
    begin
      PCh := @PCharArray(@DeviceDescriptor)^[DeviceDescriptor.VendorIdOffset];
      FVendorId := PCh;
    end;

    if DeviceDescriptor.ProductIdOffset <> 0 then
    begin
      PCh := @PCharArray(@DeviceDescriptor)^[DeviceDescriptor.ProductIdOffset];
      FProductId := PCh;
    end;

    if DeviceDescriptor.ProductRevisionOffset <> 0 then
    begin
      PCh := @PCharArray(@DeviceDescriptor)^[DeviceDescriptor.ProductRevisionOffset];
      FProductRevision := PCh;
    end;

    if DeviceDescriptor.SerialNumberOffset <> 0 then
    begin
      PCh := @PCharArray(@DeviceDescriptor)^[DeviceDescriptor.SerialNumberOffset];
      FSerialNumber := PCh;
    end;

    FInfoAvailable := True;
  finally
    if FFileHandle <> INVALID_HANDLE_VALUE then CloseHandle(FFileHandle);
  end;
end;

function THDDInfo.SerialNumberInt: Cardinal;
begin
  Result := 0;
  if ((IsInfoAvailable = True) and (FSerialNumber <> '')) then Result := SerialNumberToCardinal(FSerialNumber)
end;

function THDDInfo.SerialNumberText: string;
begin
  Result := '';
  if ((IsInfoAvailable = True) and (FSerialNumber <> '')) then Result := SerialNumberToString(FSerialNumber)
end;

procedure THDDInfo.SetDriveNumber(const Value: Byte);
begin
  FDriveNumber := Value;
  ReadInfo;
end;

end.

hddinfo 单元的用法如下：

unit Unit1;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, Hddinfo;

type

  { TForm1 }

  TForm1 = class(TForm)
    Button1: TButton;
    Memo1: TMemo;
    procedure Button1Click(Sender: TObject);
  private

  public

  end;

var
  Form1: TForm1;

implementation

{$R *.lfm}

{ TForm1 }

procedure TForm1.Button1Click(Sender: TObject);
var
  HDDInfo : THDDInfo;
begin
  HDDInfo := THDDInfo.Create();
  HDDInfo.DriveNumber := 0;
  if HDDInfo.IsInfoAvailable then
    try
      begin
        Memo1.Lines.Add('DriveNum  = ' + HDDInfo.DriveNumber.ToString);
        Memo1.Lines.Add('VendorID  = ' + HDDInfo.VendorId);
        Memo1.Lines.Add('ProductID = ' + HDDInfo.ProductId);
        Memo1.Lines.Add('Revision  = ' + HDDInfo.ProductRevision);
        Memo1.Lines.Add('SerialNo  = ' + HDDInfo.SerialNumberText);
        Memo1.Lines.Add('SerialNo  = ' + HDDInfo.SerialNumber);
        Memo1.Lines.Add('SerialNo  = ' + HDDInfo.SerialNumberInt.ToString);
      end;
    finally
      HDDInfo.Free;
    end;
end;

end.

注意：THDDInfo 单元的版权归 Artem Parlyuk 所有 - 可免费用于商业用途，但需确认版权（比如显示在“关于”中）。只要不作更改就允许发布源代码。

获取系统信息

SMBIOS（System Management BIOS）是 DMTF 开发的标准。SMBIOS 中的信息包括设备制造商、型号名称、序列号、BIOS 版本、资产标签、处理器、端口和已安装的设备内存。Object Pascal 语言（Delphi 或 Free Pascal）可用 TSMBIOS 库访问 SMBIOS。

答疑

A referral was returned from the server

Windows 7 及以上版本可能会报此错误，显示一个对话框，包含消息“A referral was returned from the server”，并且不会执行程序。事实证明，罪魁祸首是启用了“项目选项 > 应用程序 > 用户界面访问（uiAccess）”。取消选中再重新编译，阻止运行的错误就会消失！

什么是用户界面访问？Microsoft 文档指出：“不提供辅助功能的应用程序应将此标志设为 false。需向桌面其他窗口（例如屏幕键盘）提供输入驱动的应用程序，应将此值设为 true。

32 位 Lazarus：带有调试信息运行时触发 External SIGSEGV 异常

32 位的 Lazarus 有一个常见问题：如果调试信息类型选为“自动”，Lazarus 会选择“Stabs”格式，该格式在 Windows 中已经过时了。

请到 Lazarus 菜单中，“项目 > 项目选项 > 编译器选项 > 调试”，然后将“调试器信息类型”选为“带集合的 Dwarf2”。

FPC 2.6.x/Lazarus 警告（Missing support for SEH）

Warning: 尽可能避免使用 FPC 2.6.x 及以下版本（即 Lazarus 1.x）的 Win64 版。详见下文。

请小心，所有 Lazarus 1.x 版本都使用了 FPC 2.6.x。FPC 2.6.x（可能还有更早版本）无法正确支持 Windows 64 位。因此，在 Win64 中请使用 32 位的 Lazarus IDE。如果真的需要编译 64 位可执行文件（如资源管理器扩展），请为 32 位 IDE 安装 64 位交叉编译器插件。

详细缺陷信息：在 Windows 64 上，使用 SEH 可能会触发（第三方）DLL 中的异常。这些异常应在 DLL 内部处理。

但 FPC 会检测到（不正确的）异常，可能会导致程序（或 Lazarus）崩溃。这适用于打印机驱动程序、数据库驱动程序、Windows 资源管理器扩展等 DLL。

此问题已在 FPC 开发版中修复，但这是一项重大更改，在 FPC 2.6.x 中不会再做改动了。

相关的缺陷报告见 http://bugs.freepascal.org/view.php?id=12742。

Other Interfaces

Lazarus known issues (things that will never be fixed) - A list of interface compatibility issues
Win32/64 Interface - The Windows API (formerly Win32 API) interface for Windows 95/98/Me/2000/XP/Vista/10, but not CE
Windows CE Interface - For Pocket PC and Smartphones
Carbon Interface - The Carbon 32 bit interface for macOS (deprecated; removed from macOS 10.15)
Cocoa Interface - The Cocoa 64 bit interface for macOS
Qt Interface - The Qt4 interface for Unixes, macOS, Windows, and Linux-based PDAs
Qt5 Interface - The Qt5 interface for Unixes, macOS, Windows, and Linux-based PDAs
GTK1 Interface - The gtk1 interface for Unixes, macOS (X11), Windows
GTK2 Interface - The gtk2 interface for Unixes, macOS (X11), Windows
GTK3 Interface - The gtk3 interface for Unixes, macOS (X11), Windows
fpGUI Interface - Based on the fpGUI library, which is a cross-platform toolkit completely written in Object Pascal
Custom Drawn Interface - A cross-platform LCL backend written completely in Object Pascal inside Lazarus. The Lazarus interface to Android.

Platform specific Tips

Android Programming - For Android smartphones and tablets
iPhone/iPod development - About using Objective Pascal to develop iOS applications
FreeBSD Programming Tips - FreeBSD programming tips
Linux Programming Tips - How to execute particular programming tasks in Linux
macOS Programming Tips - Lazarus tips, useful tools, Unix commands, and more...
WinCE Programming Tips - Using the telephone API, sending SMSes, and more...
Windows Programming Tips - Desktop Windows programming tips

Interface Development Articles

Carbon interface internals - If you want to help improving the Carbon interface
Windows CE Development Notes - For Pocket PC and Smartphones
Adding a new interface - How to add a new widget set interface
LCL Defines - Choosing the right options to recompile LCL
LCL Internals - Some info about the inner workings of the LCL
Cocoa Internals - Some info about the inner workings of the Cocoa widgetset

Windows Programming Tips/zh CN