unit USerialPortList;
interface
// Autor: Ekkehard Domning (edo@domis.de)
// Lizenz: Public Domain, aber bitte damit keine Lebewesen quälen oder töten!
// Datum: 2019-02-10
// Die ursprüngliche Idee zu dieser Liste stammt von Christian Nöding
// und ist auf dieser Seite
// https://www.delphipraxis.net/118592-com-ports-im-system-auslesen.html
// zu finden
uses
System.SysUtils, System.Classes,
Winapi.Windows,
// Jedi SetupAPI
// https://sourceforge.net/projects/jedi-apilib/files/
// Herunterladen und auspacken, keine Installation nötig
// Die Verzeichnisse
//(...)\jwa\branches\2.3\SaCMAPI;
//(...)\jwa\branches\2.3\Includes;
//(...)\jwa\branches\2.3\Common;
//(...)\jwa\branches\2.3\Win32API
// müssen in die Suchpfade eingetragen werden
// Menü Projekt->Optionen,
// dann oben Ziel "Alle Konfigurationen - Alle Plattformen" auswählen,
// dann links "Delphi-Compiler" (oberster Eintrag) auswählen
// dann rechts "Suchpfad" auf "..." klicken und Pfade einzeln raussuchen und eintragen
// ACHTUNG wenn die Zielplattform 64-Bit Windows ist müssen zwei kleine Änderungen
// in "SetupApi.pas" vorgenommen werden, die aber auch zu 32-Bit rückwärtskompatibel sind.
// In den Zeilen 851 und 856 muss jeweils der ULONG_PTR durch Pointer ersetzt werden
// Reserved: Pointer;
// Dies betrifft die Records SP_DEVINFO_DATA und SP_DEVICE_INTERFACE_DATA
// Diese Änderungen sind nötig um die Größen der Records auf das erforderliche Maß zu bringen
JwaWinType, SetupApi, Cfg, CfgMgr32;
type
TSerialPortListEnhancedSimpleListFlag = (slFriendlyNames, slDeviceDescriptions, slSymbolicNames, slBusses);
TSerialPortListEnhancedSimpleListFlags =
set of TSerialPortListEnhancedSimpleListFlag;
// Class TSerialPortListEnhanced
// Klasse die Ports erkennt und in eine Struktur bringt.
TSerialPortListEnhanced =
class(TObject)
private
FLastError : Integer;
FPortNames : TStringList;
FFriendlyNames : TStringList;
FDeviceDescriptions : TStringList;
FSymbolicNames : TStringList;
FBusses : TStringList;
function GetPortCount : Integer;
function GetPortNames(
Index : Integer) :
String;
function GetFriendlyNames(
Index : Integer) :
String;
function GetDeviceDescriptions(
Index : Integer) :
String;
function GetSymbolicNames(
Index : Integer) :
String;
function GetBusses(
Index : Integer) :
String;
procedure Clear;
procedure Sort;
public
property LastError : Integer
read FLastError;
// Wenn nach Create oder Update der LastError <> 0 ist, ging was schief
// PortCount enthält Anzahl der gefundenen CommPorts (Schnittstellen). In den nachfolgenden Properties kann von 0 bis PortCount-1 abgefragt werden
property PortCount : Integer
read GetPortCount;
property PortNames[
Index : Integer] :
String read GetPortNames;
//Namen der gefundenen Ports z.B. 'COM8'
property FriendlyNames[
Index : Integer] :
String read GetFriendlyNames;
//Anzeigename wie im Devicemanager 'Prolific USB-to-Serial Comm Port (COM8)'
property DeviceDescriptions[
Index : Integer] :
String read GetDeviceDescriptions;
//zB. 'Prolific USB-to-Serial Comm Port'
property SymbolicNames[
Index : Integer] :
String read GetSymbolicNames;
// Langer GeräteName, zB '\??\USB#VID_067B&PID_2303#6&1cf66e6e&0&2#{a5dcbf10-6530-11d2-901f-00c04fb951ed}'
property Busses[
Index : Integer] :
String read GetBusses;
//Bus zB 'USB'
// Update aktualisiert die Liste, dh die Liste ändert sich dann, wenn Ports hinzugekommen sind oder entfernt wurden
procedure Update;
// SimpleList gibt den Inhalt der Liste formatiert zurück
procedure SimpleList(
const Items : TStrings;
const Flags : TSerialPortListEnhancedSimpleListFlags = []);
// Create legt die Liste an und ruft Update auf, damit gleich alle Daten verfügbar sind
constructor Create;
destructor Destroy;
override;
end;
// Mit SerialPortAPIsLoaded kann geprüft werden ob die nötigen DLLs geladen wurden
function SerialPortAPIsLoaded : Boolean;
implementation
// Delphi wrapper for CM_Get_Device_ID
function GetDeviceID(
const Inst: DEVINST):
String;
var
Size: ULONG;
begin
CM_Get_Device_ID_Size(Size, Inst, 0);
// Required! See DDK help for CM_Get_Device_ID
Inc(Size);
SetLength(Result,Size);
CM_Get_Device_ID(Inst, PTSTR(@Result[1]), Size, 0);
end;
// Delphi wrapper for SetupDiGetDeviceRegistryProperty
function GetRegistryPropertyString(
const PnPHandle: HDEVINFO;
const DevData: TSPDevInfoData;
const Prop: DWORD):
String;
var
BytesReturned: DWORD;
RegDataType: DWORD;
begin
BytesReturned := 0;
RegDataType := 0;
SetLength(Result,512);
SetupDiGetDeviceRegistryProperty(PnPHandle, DevData, Prop,
RegDataType, PByte(@Result[1]), Length(Result)*SizeOf(Char), BytesReturned);
if BytesReturned > 0
then
SetLength(Result,(BytesReturned
div SizeOf(Char))-1)
//Abschließende #0 entfernen
else
SetLength(Result,0);
end;
function ExtractBus(
const ADeviceID:
String):
String;
var
posi : Integer;
begin
Result := ADeviceID;
posi := Pos('
\', ADeviceID) - 1;
if posi > 0
then
SetLength(Result,posi);
end;
function TSerialPortListEnhanced.GetPortCount;
begin
Result := FPortNames.Count;
end;
function TSerialPortListEnhanced.GetPortNames(
Index : Integer) :
String;
begin
Result := FPortNames[
Index];
end;
function TSerialPortListEnhanced.GetFriendlyNames(
Index : Integer) :
String;
begin
Result := FFriendlyNames[
Index];
end;
function TSerialPortListEnhanced.GetDeviceDescriptions(
Index : Integer) :
String;
begin
Result := FDeviceDescriptions[
Index];
end;
function TSerialPortListEnhanced.GetSymbolicNames(
Index : Integer) :
String;
begin
Result := FSymbolicNames[
Index];
end;
function TSerialPortListEnhanced.GetBusses(
Index : Integer) :
String;
begin
Result := FBusses[
Index];
end;
procedure TSerialPortListEnhanced.Clear;
begin
FPortNames.Clear;
FFriendlyNames.Clear;
FDeviceDescriptions.Clear;
FSymbolicNames.Clear;
FBusses.Clear;
end;
procedure TSerialPortListEnhanced.Sort;
var
lPortNames : TStringList;
lDeviceDescriptions : TStringList;
lSymbolicNames : TStringList;
lBusses : TStringList;
lFriendlyNames : TStringList;
i : Integer;
ndx : Integer;
begin
if PortCount < 2
then Exit;
// Leere Liste oder nur ein Element, muss nicht sortiert werden
lPortNames :=
Nil;
lFriendlyNames :=
Nil;
lDeviceDescriptions :=
Nil;
lSymbolicNames :=
Nil;
lBusses :=
Nil;
try
lPortNames := TStringList.Create;
lPortNames.Assign(FPortNames);
//Aktuelle Liste sichern
FPortNames.Sort;
// Sortieren
if FPortNames.Text = lPOrtNames.Text
then Exit;
// Keine Änderungen, also raus
// Lokale Listen anlegen
lFriendlyNames := TStringList.Create;
lDeviceDescriptions := TStringList.Create;
lSymbolicNames := TStringList.Create;
lBusses := TStringList.Create;
// Gegenwärtige Reihenfolge sichern
lFriendlyNames.Assign(FFriendlyNames);
lDeviceDescriptions.Assign(FDeviceDescriptions);
lSymbolicNames.Assign(FSymbolicNames);
lBusses.Assign(FBusses);
// Durch alle Portnamen in alter Reihenfolge laufen
for i := 0
to lPortNames.Count-1
do
begin
ndx := FPortNames.IndexOf(lPortNames[i]);
//Index des alten PortNamens in der neuen Reihenfolge suchen
if ndx <> i
then // Wenn nicht am gleichen Platz, dann
begin // Inhalte kopieren
FFriendlyNames[ndx] := lFriendlyNames[i];
FDeviceDescriptions[ndx] := lDeviceDescriptions[i];
FSymbolicNames[ndx] := lSymbolicNames[i];
FBusses[ndx] := lBusses[i];
end;
end;
finally
if Assigned(lPortNames)
then
lPortNames.Free;
if Assigned(lFriendlyNames)
then
lFriendlyNames.Free;
if Assigned(lDeviceDescriptions)
then
lDeviceDescriptions.Free;
if Assigned(lSymbolicNames)
then
lSymbolicNames.Free;
if Assigned(lBusses)
then
lBusses.Free;
end;
end;
procedure TSerialPortListEnhanced.Update;
const
// Drei Positionen wo die Ports sein können
GUID_DEVINTERFACE_COMPORT: TGUID = '
{86e0d1e0-8089-11d0-9ce4-08003e301f73}';
GUID_DEVINTERFACE_SERENUM_BUS_ENUMERATOR: TGUID = '
{4D36E978-E325-11CE-BFC1-08002BE10318}';
GUID_DEVINTERFACE_USB_DEVICE: TGUID = '
{A5DCBF10-6530-11D2-901F-00C04FB951ED}';
var
PnPHandle: HDEVINFO;
DevData: TSPDevInfoData;
DeviceInterfaceData: TSPDeviceInterfaceData;
FunctionClassDeviceData: PSPDeviceInterfaceDetailData;
FunctionClassDeviceDataBuffer :
array of Byte;
Success: LongBool;
Devn: NativeInt;
BytesReturned: DWORD;
SerialGUID: TGUID;
Inst: DEVINST;
RegKey: HKEY;
RegBuffer:
array [0..1023]
of Char;
RegSize, RegType: DWORD;
lFriendlyName:
string;
lPortName:
string;
lDeviceDescription:
string;
lSymbolicName :
String;
lBus:
string;
i : Integer;
ndx : Integer;
begin
Clear;
FLastError := ERROR_SUCCESS;
SetLength(FunctionClassDeviceDataBuffer,256);
for i := 0
to 2
do
begin
// Einige Port Emulatoren tragen sich nicht als ComPort ein, werden aber als solche benutzt
case i
of
0 : SerialGUID := GUID_DEVINTERFACE_COMPORT;
1 : SerialGUID := GUID_DEVINTERFACE_SERENUM_BUS_ENUMERATOR;
else
SerialGUID := GUID_DEVINTERFACE_USB_DEVICE;
end;
PnPHandle := SetupDiGetClassDevs(@SerialGUID,
nil, 0, DIGCF_PRESENT
or DIGCF_DEVICEINTERFACE);
if PnPHandle = Pointer(INVALID_HANDLE_VALUE)
then
begin
FLastError := GetLastError;
Continue;
end;
try
Devn := 0;
repeat
DeviceInterfaceData.cbSize := SizeOf(TSPDeviceInterfaceData);
Success := SetupDiEnumDeviceInterfaces(PnPHandle,
nil, SerialGUID, Devn, DeviceInterfaceData);
if Success
then
begin
DevData.cbSize := SizeOf(DevData);
BytesReturned := 0;
// get size required for call
success := SetupDiGetDeviceInterfaceDetail(PnPHandle, @DeviceInterfaceData,
nil, 0, BytesReturned, @DevData);
FLastError := GetLastError;
if (BytesReturned <> 0)
and (FLastError = ERROR_INSUFFICIENT_BUFFER)
then
begin
// allocate buffer and initialize it for call
if Length(FunctionClassDeviceDataBuffer) < BytesReturned
then
SetLength(FunctionClassDeviceDataBuffer,BytesReturned);
FunctionClassDeviceData := @FunctionClassDeviceDataBuffer[0];
FunctionClassDeviceData.cbSize := SizeOf(TSPDeviceInterfaceDetailData);
{$IFDEF WIN64}
// Sonderaktion für 64 Bit, da stimmt die Größe des Records nicht, ist aber auch egal
// weil die Daten natürlich extra angelegt sind
FunctionClassDeviceData.cbSize := 8;
{$ENDIF}
success := SetupDiGetDeviceInterfaceDetail(PnPHandle, @DeviceInterfaceData,
FunctionClassDeviceData, BytesReturned, BytesReturned, @DevData);
if not success
then
FLastError := GetLastError;
if success
then
begin
// gives the friendly name of the device as shown in Device Manager
lFriendlyName := GetRegistryPropertyString(PnPHandle, DevData, SPDRP_FRIENDLYNAME);
// gives a device description
lDeviceDescription := GetRegistryPropertyString(PnPHandle, DevData, SPDRP_DEVICEDESC);
// now try to get the assigned COM port name
lPortName := '
';
lSymbolicName := '
';
RegKey := SetupDiOpenDevRegKey(PnPHandle, DevData, DICS_FLAG_GLOBAL, 0, DIREG_DEV, KEY_READ);
try
RegType := REG_SZ;
RegSize := SizeOf(RegBuffer);
if 0 = RegQueryValueEx(RegKey, '
PortName',
nil, @RegType, @RegBuffer[0], @RegSize)
then
begin
lPortName := RegBuffer;
RegSize := SizeOf(RegBuffer);
if 0 = RegQueryValueEx(RegKey, '
SymbolicName',
nil, @RegType, @RegBuffer[0], @RegSize)
then
lSymbolicName := RegBuffer;
end;
finally
RegCloseKey(RegKey);
end;
Inst := DevData.DevInst;
CM_Get_Parent(Inst, Inst, 0);
lBus := ExtractBus(GetDeviceID(Inst));
// Informationen der COM-Ports in die Liste eintragen
if Length(lPortName) > 0
then // Port wurde gefunden
begin
ndx := FPortNames.IndexOf(lPortName);
// Nachschauen ob der Port schon einmal gefunden wurde
if ndx < 0
then
ndx := FPortNames.Add(lPortName);
while FFriendlyNames.Count <= ndx
do
FFriendlyNames.Add('
');
FFriendlyNames[ndx] := lFriendlyName;
while FDeviceDescriptions.Count <= ndx
do
FDeviceDescriptions.Add('
');
FDeviceDescriptions[ndx] := lDeviceDescription;
while FSymbolicNames.Count <= ndx
do
FSymbolicNames.Add('
');
FSymbolicNames[ndx] := lSymbolicName;
while FBusses.Count <= ndx
do
FBusses.Add('
');
FBusses[ndx] := lBus;
end;
end;
end;
end
else
begin
FLastError := GetLastError;
if FLastError = ERROR_NO_MORE_ITEMS
then
FLastError := ERROR_SUCCESS;
end;
Inc(Devn);
until not Success;
// Liste(n) sortieren
Sort;
finally
SetupDiDestroyDeviceInfoList(PnPHandle);
end;
end;
end;
procedure TSerialPortListEnhanced.SimpleList(
const Items : TStrings;
const Flags : TSerialPortListEnhancedSimpleListFlags);
var
i : Integer;
s :
String;
begin
Items.BeginUpdate;
try
Items.Clear;
for i := 0
to PortCount-1
do
begin
if Flags = []
then
Items.Add(PortNames[i])
else
begin
s := PortNames[i]+ '
(';
if slFriendlyNames
in Flags
then
s := s + '
"'+FriendlyNames[i]+'
", ';
if slDeviceDescriptions
in Flags
then
s := s + '
"'+DeviceDescriptions[i]+'
", ';
if slSymbolicNames
in Flags
then
s := s + '
"'+SymbolicNames[i]+'
", ';
if slBusses
in Flags
then
s := s + '
"'+Busses[i]+'
", ';
if Copy(s,Length(s)-1) = '
, '
then
SetLength(s,Length(s)-2);
s := s + '
)';
Items.Add(s);
end;
end;
finally
Items.EndUpdate;
end;
end;
constructor TSerialPortListEnhanced.Create;
begin
inherited;
FPortNames := TStringList.Create;
FFriendlyNames := TStringList.Create;
FDeviceDescriptions := TStringList.Create;
FSymbolicNames := TStringList.Create;
FBusses := TStringList.Create;
Update;
end;
destructor TSerialPortListEnhanced.Destroy;
begin
if Assigned(FPortNames)
then
FreeAndNil(FPortNames);
if Assigned(FFriendlyNames)
then
FreeAndNil(FFriendlyNames);
if Assigned(FDeviceDescriptions)
then
FreeAndNil(FDeviceDescriptions);
if Assigned(FSymbolicNames)
then
FreeAndNil(FSymbolicNames);
if Assigned(FBusses)
then
FreeAndNil(FBusses);
end;
var
SetupAPILoaded : Boolean;
ConfigManagerApiLoaded : Boolean;
function SerialPortAPIsLoaded : Boolean;
begin
Result := SetupAPILoaded
and ConfigManagerApiLoaded;
end;
initialization
// these API conversions are loaded dynamically by default
SetupAPILoaded :=LoadSetupApi;
ConfigManagerApiLoaded := LoadConfigManagerApi;
finalization
// unload API conversions
if SetupAPILOaded
then
UnloadSetupApi;
if ConfigManagerApiLoaded
then
UnloadConfigManagerApi;
end.