Einzelnen Beitrag anzeigen

ekke

Registriert seit: 14. Nov 2009
18 Beiträge
 
#26

AW: COM Ports im System auslesen

  Alt 10. Feb 2019, 19:06
Der Sonntagnachmittag ging mit Aufräumen und der 64-Bit-Adaption für den Code von Christian Nöding drauf.
Ich habe alle MemAlloc rausgebaut und durch dynamische Arrays ersetzt, diverse try..finally eingebaut, das Ganze in eine Klasse gepackt und das Laden und Entladen der nötige DLLs in den Fuß einer Unit.
Jetzt läuft alles schön rund.
Bitte die Kommentare hinsichtlich der 64-Bit Adaption beachten
Anbei der Code.
Viel Spaß damit.

Man braucht ein Form mit einem Knopf und einem Memofeld.
Delphi-Quellcode:
uses
  USerialPortList;

procedure TForm1.Button1Click(Sender: TObject);
var
  portlist : TSerialPortListEnhanced;
begin
  if SerialPortAPIsLoaded then
  begin
    portlist := TSerialPortListEnhanced.Create;
    try
      // Nur die Ports
      // portlist.SimpleList(Memo1.Lines);
      // Ports mit zusätzlichen Informationen
      portlist.SimpleList(Memo1.Lines, [slSymbolicNames, slFriendlyNames]);
      if portlist.PortCount <= 0 then
        Memo1.Lines.Add('No Ports found!');
      if portlist.LastError <> 0 then
        Memo1.Lines.Add(Format('Last Error: %d',[portlist.LastError]));
    finally
      portlist.Free;
    end;
  end
  else
    Memo1.Lines.Add('SetupAPI is not initialized!');
end;
Die Unit UserialPorts.pas sieht wie folgt aus.
Delphi-Quellcode:
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.
  Mit Zitat antworten Zitat