با سلام.
توجه داشته باشید که برای این کار باید مجموعه jvcl را نصب کرده باشید. ابتدا یونیتهای Registry و JvSetupApi را به بخش uses اضافه کنید و سپس تابع زیر را بنویسید:
function GetAvailableComPorts: TStringList;var
RequiredSize: Cardinal;
GUIDSize: DWORD;
Guid: TGUID;
DevInfoHandle: HDEVINFO;
DeviceInfoData: TSPDevInfoData;
MemberIndex: Cardinal;
PropertyRegDataType: DWORD;
RegProperty: Cardinal;
RegTyp: Cardinal;
Key: Hkey;
Info: TRegKeyInfo;
S1, S2: string;
hc: THandle;
begin
Result := Nil;
// If we cannot access the setupapi.dll then we return a nil pointer.
if not LoadsetupAPI then
Exit;
try
// get 'Ports' class guid from name
GUIDSize := 1;
// missing from original code - need to tell function that the Guid structure contains a single GUID
if SetupDiClassGuidsFromName('Ports', @Guid, GUIDSize, RequiredSize) then
begin
// get object handle of 'Ports' class to interate all devices
DevInfoHandle := SetupDiGetClassDevs(@Guid, Nil, 0, DIGCF_PRESENT);
if Cardinal(DevInfoHandle) <> Invalid_Handle_Value then
begin
try
MemberIndex := 0;
Result := TStringList.Create;
// iterate device list
repeat
FillChar(DeviceInfoData, SizeOf(DeviceInfoData), 0);
DeviceInfoData.cbSize := SizeOf(DeviceInfoData);
// get device info that corresponds to the next memberindex
if Not SetupDiEnumDeviceInfo(DevInfoHandle, MemberIndex,
DeviceInfoData) then
Break;
// query friendly device name LIKE 'BlueTooth Communication Port (COM8)' etc
RegProperty := SPDRP_FriendlyName;
{ SPDRP_Driver, SPDRP_SERVICE, SPDRP_ENUMERATOR_NAME,SPDRP_PHYSICAL_DEVICE_OBJECT _NAME,SPDRP_FRIENDLYNAME, }
SetupDiGetDeviceRegistryProperty(DevInfoHandle, DeviceInfoData,
RegProperty, PropertyRegDataType, NIL, 0, RequiredSize);
SetLength(S1, RequiredSize);
if SetupDiGetDeviceRegistryProperty(DevInfoHandle,
DeviceInfoData, RegProperty, PropertyRegDataType, @S1[1],
RequiredSize, RequiredSize) then
begin
Key := SetupDiOpenDevRegKey(DevInfoHandle, DeviceInfoData,
DICS_FLAG_GLOBAL, 0, DIREG_DEV, KEY_READ);
if Key <> Invalid_Handle_Value then
begin
FillChar(Info, SizeOf(Info), 0);
// query the real port name from the registry value 'PortName'
if RegQueryInfoKey(Key, nil, nil, nil, @Info.NumSubKeys,
@Info.MaxSubKeyLen, nil, @Info.NumValues,
@Info.MaxValueLen, @Info.MaxDataLen, nil,
@Info.FileTime) = ERROR_SUCCESS then
begin
RequiredSize := Info.MaxValueLen + 1;
SetLength(S2, RequiredSize);
if RegQueryValueEx(Key, 'PortName', Nil, @RegTyp,
@S2[1], @RequiredSize) = ERROR_SUCCESS then
begin
If (Pos('COM', S2) <> 0) then
begin
// Test if the device can be used
hc := CreateFile(pchar('\\.\' + S2 + #0),
GENERIC_READ or GENERIC_WRITE, 0, nil,
OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
if hc <> Invalid_Handle_Value then
begin
Result.Add(Strpas(pchar(S2)) + ': = ' +
Strpas(pchar(S1)));
CloseHandle(hc);
end;
end;
end;
end;
RegCloseKey(Key);
end;
end;
Inc(MemberIndex);
until False;
// If we did not found any free com. port we return a NIL pointer.
if Result.Count = 0 then
begin
Result.Free;
Result := NIL;
end
finally
SetupDiDestroyDeviceInfoList(DevInfoHandle);
end;
end;
end;
finally
UnloadSetupApi;
end;
end;
حال برای نمایش لیست پورتهای com می توانید از کدی شبیه به این استفاده کنید:
procedure TForm1.Button1Click(Sender: TObject);var
ComPortList: TStringList;
begin
ComPortList := GetAvailableComPorts;
try
ShowMessage(ComPortList.Text);
finally
ComPortList.Free;
end;
end;