DDevExtensions 2.86

Andreas HausladenさんのDDevExtensionsがアップデートされてVersion 2.86になっています。RAD Studio 10.4 Sydney対応ではなく、TListViewのOwnerDataの問題を修正して、"Find Unit" replacement dialogのパフォーマンスが向上したとのことです。

DDevExtensions 2.86 for Delphi 2009-10.3.3 – Andy's Blog and Tools

DDevExtensions 2.85

Andreas HausladenさんのDDevExtensionsがアップデートされてVersion 2.85になっています。RAD Studio 10.3 Rio対応と、いくつかの改善が行われています。

DDevExtensions and DFMCheck released for Delphi 10.3 Rio – Andy's Blog and Tools

IDE Fix Pack 5.95

Andreas HausladenさんのIDE Fix PackがアップデートされてVersion 5.95となっています。RAD Studio/Delphi/C++Builder 10.1 Berlin対応といくつかの新しいパッチが追加されています。

IDE Fix Pack 5.95 for Delphi 10.1 Berlin | Andy's Blog and Tools

DDevExtensions 2.84

Andreas HausladenさんのDDevExtensionsがアップデートされてVersion 2.84となっています。RAD Studio 10.1 Berlinへの対応とちょっとした機能追加が行われています。

DDevExtensions and DFMCheck for 10.1 Berlin | Andy's Blog and Tools

ちなみにAndreas Hausladenさんが休暇から戻ったらGoogle+とメールはIDEFixPackの10.1 Berlin対応のリクエストで一杯だったとのこと。

Windowsがサーバ版かどうかを調べる

プログラムが動作している環境(Windows)がサーバ版かどうかを調べたいことがまれにあります(WMIでサーバ版Windowsではサポートされていない項目の問い合わせをするときなど)。RTLのソースをちょっと覗いてみたところ、Win32APIのGetVersionEx (ja)関数で取得したOSVERSIONINFOEX構造体のwProductTypeがVER_NT_WORKSTATIONかどうかで判断できるようなのですが、GetVersionEx関数のRemarksにはVerifyVersionInfo (ja)関数を使ったほうがパフォーマンス上望ましい、と書いてあるようなので、VerifyVersionInfo関数(とそのパラメータを組み立てるためにVerSetConditionMask関数の組み合わせ)で実現してみました。

function IsWindowsServer: Boolean;
var
  OSVI: TOSVersionInfoEx;
  ConditionMask: UInt64;
begin

  FillChar(OSVI,SizeOf(TOSVersionInfoEX),0);
  OSVI.dwOSVersionInfoSize := SizeOf(OSVI);
  OSVI.wProductType := VER_NT_WORKSTATION;

  ConditionMask := VerSetConditionMask(0,VER_PRODUCT_TYPE,VER_EQUAL);

  Result := not (VerifyVersionInfo(OSVI,VER_PRODUCT_TYPE,ConditionMask));

end;

OSVERSIONINFOEX構造体を初期化後、wProductTypeにVER_NT_WORKSTATIONを格納し、これに対応する条件マスク(VER_PRODUCT_TYPEがVER_EQUAL)をVerifyVersionInfoで作成してVerifyVersionInfoで問い合わせて、結果がFalse(wProductTypeがVER_NT_WORKSTATION以外)ならサーバ版Windows、という判定です。

→Windowsがサーバ版かどうかを調べる(Gist)

整数の中で立っているビットの数を数える

それほど機会が多いわけではありませんが、整数の中で立っているビットの数を数えたいということがあります。C++であればstd::bitsetのcountを使えば一発ですが、残念ながらDelphiでは符号なし整数型のヘルパ(TByteHelper/TWordHelper/TCardinalHelper/TUInt64Helper)を含め、標準ではそのような機能がありません。でちょっと検索してみたところ、population countあるいはHamming weightというキーワードが浮かんできました。最近のCPUには専用の命令(x86だとSSE4.2以降のPOPCNT)がありますが、移植性などを考慮して、Delphiで実装してみました。とはいってもCで書かれたものをそのままDelphiに置き換えただけです。詳細や原理については○×つくろーどっとコムさんのその17 ビット演算あれこれや中村実さんのビットを数える・探すアルゴリズムなどを、またx86/x64のPOPCNT命令との比較についてはtakesakoさんのx86x64 SSE4.2 POPCNTあたりを参照してください。

function PopulationCount(Value: UInt8): Integer;
begin

  Value := (Value and $55) + ((Value shr 1) and $55);
  Value := (Value and $33) + ((Value shr 2) and $33);
  Value := (Value and $0F) + ((Value shr 4) and $0F);
  Result := Value;

end;

function PopulationCount(Value: UInt16): Integer;
begin

  Value := (Value and $5555) + ((Value shr 1) and $5555);
  Value := (Value and $3333) + ((Value shr 2) and $3333);
  Value := (Value and $0F0F) + ((Value shr 4) and $0F0F);
  Value := (Value and $00FF) + ((Value shr 8) and $00FF);
  Result := Value;

end;

function PopulationCount(Value: UInt32): Integer;
begin

  Value := (Value and $55555555) + ((Value shr  1) and $55555555);
  Value := (Value and $33333333) + ((Value shr  2) and $33333333);
  Value := (Value and $0F0F0F0F) + ((Value shr  4) and $0F0F0F0F);
  Value := (Value and $00FF00FF) + ((Value shr  8) and $00FF00FF);
  Value := (Value and $0000FFFF) + ((Value shr 16) and $0000FFFF);
  Result := Value;

end;

function PopulationCount(Value: UInt64): Integer;
begin

  Value := (Value and $5555555555555555) + ((Value shr  1) and $5555555555555555);
  Value := (Value and $3333333333333333) + ((Value shr  2) and $3333333333333333);
  Value := (Value and $0F0F0F0F0F0F0F0F) + ((Value shr  4) and $0F0F0F0F0F0F0F0F);
  Value := (Value and $00FF00FF00FF00FF) + ((Value shr  8) and $00FF00FF00FF00FF);
  Value := (Value and $0000FFFF0000FFFF) + ((Value shr 16) and $0000FFFF0000FFFF);
  Value := (Value and $00000000FFFFFFFF) + ((Value shr 32) and $00000000FFFFFFFF);
  Result := Value;

end;

→整数の中で立っているビットの数を数える(Gist)

2020/06/01追記: Delphi 10.4 Sydneyでは標準関数(かつ組み込みルーチン(en))としてCountLeadingZeros32(先頭の(MSBからの)連続している0の数/32bit整数)、CountLeadingZeros64(先頭の(MSBからの)連続している0の数/64bit整数)、CountTrailingZeros32(末尾のの(LSBからの)連続している0の数/32bit整数)、CountTrailingZeros64(末尾のの(LSBからの)連続している0の数/64bit整数)、CountPopulation32(1になっているビットの数/32bit整数)、CountPopulation64(1になっているビットの数/64bit整数)が追加されました。これらの関数はコンパイラによってインラインで展開されるため、System.pasなどに定義がありません。またこれらの関数は現時点ではヘルプ上に記述がありません。

要素数が256を超える集合型を作る

このアーティクルはDelphi Advent Calendar 2015の14日目の記事です(3年ぶり3回目)。

Delphiの特徴的な型として集合型というものがあります。これは基底型となる列挙型、部分範囲型の組み合わせを保持できるというもので、C言語のビットフィールドに相当するものですが、各種演算子などが用意されており、非常に便利な言語機能です。しかし集合型にはその基底型の要素数が256以下、正確には順序値として0から255まで、という制約があります。しかし状況によっては256要素を超えるような、あるいは基底型で負値となるものを含むような集合型が欲しいということがあります。そこで既存の集合型になるべく近い形で実装してみることにします。ただしDelphiのジェネリックスはC++のテンプレートとは実装が異なり文法的制約が厳しい(というか値型にはほぼ使えない)ため、ジェネリックスによる汎用の実装ではなく個別の実装になってしまいます。また本来の集合型と同様に使えるよう、参照型(クラスによる実装)ではなく値型である高度なレコード型による実装とします。

まず基底型となる列挙型を定義します。

type
  TFoo = (Foo0 = -1,
          Foo1,
          Foo2,
          Foo3,
          Foo4,
          Foo5,
          FooMax = 256);

順序値が-1から256なのでこれを基底型とする集合型を定義すると

type
  TFooSet = set of TFoo;  // Error: E2028 Sets may have at most 256 elements

(当然ですが)エラーになります。では代替となる高度なレコード型を定義していきます。

const
  BYTE_BIT = 8;  //  Number of bits in byte

type
  TFooSet = record
  private
    FData: array [0..((Ord(High(TFoo)) - Ord(Low(TFoo)) + 1 + (BYTE_BIT - 1)) div BYTE_BIT) - 1] of Byte;
  public
    procedure   Empty;
    function    IsEmpty: Boolean;
  end;

procedure TFooSet.Empty;
begin

  FillChar(FData[0],SizeOf(FData),0);

end;

function TFooSet.IsEmpty: Boolean;
var
  Offset: Integer;
begin

  Result := False;

  for Offset := Low(FData) to High(FData) do
  begin
    if FData[Offset] <> 0 then
    begin
      Result := True;
      Exit;
    end;
  end;

end;

FDataは基底型に対応したビット列を実際に格納する領域で、Emptyはその領域を0クリアするメソッド、IsEmptyはビット列が全て0となっているかどうかをチェックするメソッドです。

次に基底型に対応する要素を追加、削除するメソッド(Include、Exclude)です。単独の要素、複数の要素(array of)のどちらにも対応します。

type
  TFooSet = record
  private
    ...
    class procedure CalcOffsets(Value: TFoo; var AOffset: Integer; var ABit: Byte); static;
  public
    ...
    procedure   Include(Value: TFoo); overload;
    procedure   Include(const Values: array of TFoo); overload;
    procedure   Exclude(Value: TFoo); overload;
    procedure   Exclude(const Values: array of TFoo); overload;
  end;

procedure TFooSet.Include(Value: TFoo);
var
  Offset: Integer;
  Bit: Byte;
begin

  CalcOffsets(Value,Offset,Bit);
  FData[Offset] := FData[Offset] or Bit;

end;

procedure TFooSet.Include(const Values: array of TFoo);
var
  Value: TFoo;
begin

  if Length(Values) > 0 then
  begin
    for Value in Values do
    begin
      Include(Value);
    end;
  end;

end;

procedure TFooSet.Exclude(Value: TFoo);
var
  Offset: Integer;
  Bit: Byte;
begin

  CalcOffsets(Value,Offset,Bit);
  FData[Offset] := FData[Offset] and (not Bit);

end;

procedure TFooSet.Exclude(const Values: array of TFoo);
var
  Value: TFoo;
begin

  for Value in Values do
  begin
    Exclude(Value);
  end;

end;

class procedure TFooSet.CalcOffsets(Value: TFoo; var AOffset: Integer; var ABit: Byte);
var
  RelPos: Integer;
begin

  RelPos  := Ord(Value) - Ord(Low(TFoo));
  AOffset := RelPos div BYTE_BIT;
  ABit    := 1 shl (RelPos mod BYTE_BIT);

end;

CalcOffsetsは基底型の要素がどのビット位置に割り当てられているのかを計算します。

次は基底型の要素が含まれているかどうかを調べるInメソッドです。Inは予約語のため"&"で修飾します。

type
  TFooSet = record
    ...
  public
    ...
    function    &In(Value: TFoo): Boolean;
  end;

function TFooSet.&In(Value: TFoo): Boolean;
var
  Offset: Integer;
  Bit: Byte;
begin

  CalcOffsets(Value,Offset,Bit);
  Result := (FData[Offset] and Bit) <> 0;

end;

あとは何らかの形で文字列化できないと不便なので、16進文字列化するToStringと16進文字列からレコード型に値を入れるParseを用意します。

type
  TFooSet = record
    ...
  public
    ...
    function    ToString(ZeroSuppression: Boolean = True): String;
    class function Parse(const Value: String): TFooSet; static;
  end;

function TFooSet.ToString(ZeroSuppression: Boolean): String;
var
  Index: Integer;
  Len: Integer;
  Offset: Integer;
begin

  Result := '';

  for Offset := Low(FData) to High(FData) do
  begin
    Result := IntToHex(FData[Offset],2) + Result;
  end;

  if ZeroSuppression = True then
  begin
    Index := 1;
    Len := Length(Result);
    while (Index < Len) and (Result[Index] = '0') do
    begin
      Index := Index + 1;
    end;

    if Index > 1 then
    begin
      Delete(Result,1,Index - 1);
    end;
  end;

end;

class function TFooSet.Parse(const Value: String): TFooSet;
var
  Offset: Integer;
  S: String;
begin

  Result.Clear;

  S := StringOfChar('0',(SizeOf(Result.FData) * 2) - Length(Value)) + Value;

  for Offset := Low(Result.FData) to High(Result.FData) do
  begin
    Result.FData[Offset] := StrToInt('$' + Copy(S,(SizeOf(Result.FData) * 2) - (Offset * 2) - 1,2));
  end;

end;

必要な処理はこれで概ね揃いましたが、まだ既存の集合型と同じように使う、というわけにはいきません。そこで演算子オーバロードを用意します。集合型に対応する演算子には"+"(和集合)、"-"(差集合)、"*"(積集合)、"<="(サブセット)。">="(スーパーセット)、"="(等しい)、"<>"(等しくない)、"in"(メンバかどうか)の8つがあります。まず基底型の配列からの暗黙的な型キャストを行うImplicitと、"+"(class operator Add)、"-"(class operator Subtract)、"*"(class operator Multiply)の3つの演算子オーバロードです。

type
  TFooSet = record
    ...
  public
    ...
{$IF CompilerVersion>=24.00}
    class operator Implicit(const Values: array of TFoo): TFooSet;
{$IFEND}
    class operator Add(const lvalue: TFooSet; const rvalue: TFooSet): TFooSet; overload;
{$IF CompilerVersion>=28.00}
    class operator Add(const lvalue: TFooSet; const rvalue: array of TFoo): TFooSet; overload;
{$IFEND}
    class operator Subtract(const lvalue: TFooSet; const rvalue: TFooSet): TFooSet; overload;
{$IF CompilerVersion>=28.00}
    class operator Subtract(const lvalue: TFooSet; const rvalue: array of TFoo): TFooSet; overload;
{$IFEND}
    class operator Multiply(const lvalue: TFooSet; const rvalue: TFooSet): TFooSet; overload;
{$IF CompilerVersion>=28.00}
    class operator Multiply(const lvalue: TFooSet; const rvalue: array of TFoo): TFooSet; overload;
{$IFEND}
  end;

{$IF CompilerVersion>=24.00}
class operator TFooSet.Implicit(const Values: array of TFoo): TFooSet;
begin

  Result.Clear;
  Result.Include(Values);

end;
{$IFEND}

class operator TFooSet.Add(const lvalue: TFooSet; const rvalue: TFooSet): TFooSet;
var
  Offset: Integer;
begin

  Result.Clear;

  for Offset := Low(Result.FData) to High(Result.FData) do
  begin
    Result.FData[Offset] := lvalue.FData[Offset] or rvalue.FData[Offset];
  end;

end;

{$IF CompilerVersion>=28.00}
class operator TFooSet.Add(const lvalue: TFooSet; const rvalue: array of TFoo): TFooSet;
var
  Value: TFoo;
begin

  Result := lvalue;

  for Value in rvalue do
  begin
    Result.Include(Value);
  end;

end;
{$IFEND}

class operator TFooSet.Subtract(const lvalue: TFooSet; const rvalue: TFooSet): TFooSet;
var
  Offset: Integer;
begin

  Result.Clear;

  for Offset := Low(Result.FData) to High(Result.FData) do
  begin
    Result.FData[Offset] := lvalue.FData[Offset] and (not rvalue.FData[Offset]);
  end;

end;

{$IF CompilerVersion>=28.00}
class operator TFooSet.Subtract(const lvalue: TFooSet; const rvalue: array of TFoo): TFooSet;
var
  Value: TFoo;
begin

  Result := lvalue;

  for Value in rvalue do
  begin
    Result.Exclude(Value);
  end;

end;
{$IFEND}

class operator TFooSet.Multiply(const lvalue: TFooSet; const rvalue: TFooSet): TFooSet;
var
  Offset: Integer;
begin

  Result.Clear;

  for Offset := Low(Result.FData) to High(Result.FData) do
  begin
    Result.FData[Offset] := lvalue.FData[Offset] and rvalue.FData[Offset];
  end;

end;

{$IF CompilerVersion>=28.00}
class operator TFooSet.Multiply(const lvalue: TFooSet; const rvalue: array of TFoo): TFooSet;
begin

  Result := lvalue * TFooSet(rvalue);

end;
{$IFEND}

ここで明示的な型キャストを行うExplicitを用意しなかったのは、"TFooSet([Foo0,Foo2])"の"[Foo0,Foo2]"の部分がarray of TFooではなくset of TFooと解釈されてしまいコンパイルエラー(E1012)となる問題を解決できなかったためです。また同様の理由からImplicitはXE3以降、Add/Subtract/Multiplyの2番目のoverload(右項がarray of TFoo)はXE7以降のみ有効です。

次に"<="(class operator LessThanOrEqual)。">="(class operator GreaterThanOrEqual)、"="(class operator Equal)、"<>"(class operator NotEqual)、"in"(class operator In)です。

type
  TFooSet = record
    ...
  public
    ...
    class operator LessThanOrEqual(const lvalue: TFooSet; const rvalue: TFooSet): Boolean; overload;
    class operator GreaterThanOrEqual(const lvalue: TFooSet; const rvalue: TFooSet): Boolean; overload;
    class operator Equal(const lvalue: TFooSet; const rvalue: TFooSet): Boolean; overload;
    class operator NotEqual(const lvalue: TFooSet; const rvalue: TFooSet): Boolean; overload;
    class operator In(lvalue: TFoo; const rvalue: TFooSet): Boolean;
  end;

class operator TFooSet.LessThanOrEqual(const lvalue: TFooSet; const rvalue: TFooSet): Boolean;
var
  Offset: Integer;
begin

  for Offset := Low(lvalue.FData) to High(lvalue.FData) do
  begin
    if (lvalue.FData[Offset] and rvalue.FData[Offset]) <> lvalue.FData[Offset] then
    begin
      Result := False;
      Exit;
    end;
  end;

  Result := True;

end;

class operator TFooSet.GreaterThanOrEqual(const lvalue: TFooSet; const rvalue: TFooSet): Boolean;
var
  Offset: Integer;
begin

  for Offset := Low(lvalue.FData) to High(lvalue.FData) do
  begin
    if (lvalue.FData[Offset] and rvalue.FData[Offset]) <> rvalue.FData[Offset] then
    begin
      Result := False;
      Exit;
    end;
  end;

  Result := True;

end;

class operator TFooSet.Equal(const lvalue: TFooSet; const rvalue: TFooSet): Boolean;
var
  Offset: Integer;
begin

  for Offset := Low(lvalue.FData) to High(lvalue.FData) do
  begin
    if (lvalue.FData[Offset] xor rvalue.FData[Offset]) <> 0 then
    begin
      Result := False;
      Exit;
    end;
  end;

  Result := True;

end;

class operator TFooSet.NotEqual(const lvalue: TFooSet; const rvalue: TFooSet): Boolean;
begin

  Result := not (lvalue = rvalue);

end;

class operator TFooSet.In(lvalue: TFoo; const rvalue: TFooSet): Boolean;
begin

  Result := rvalue.&In(lvalue);

end;

ここでclass operator LessThanOrEqual/GreaterThanOrEqual/Equal/NotEqualにAdd/Subtract/Multiplyのようにarray of TFooを第2パラメータ(右項)とするものを用意しなかったのもExplicitと同様の理由です。

これでTFooSetに対する演算子も一通り揃いました。残るはfor-inループ構造への対応です。必要なものはfor 文を使用するコンテナの繰り返しにあるように、Booleanを返し次の値を指し示すMoveNextメソッドとコレクションに含まれる値を返すCurrentプロパティとを持つようなクラス、インタフェース、レコードのいずれかを返すGetEnumeratorメソッド、ということになります。ここではネストした形でクラスを定義します。

type
  PFooSet = ^TFooSet;
  TFooSet = record
  private
    type
      TEnumerator = class(TObject)
      private
        FContainer: PFooSet;
        FIndex: Integer;
        function GetCurrent: TFoo;
      public
        constructor Create(Container: PFooSet);
        function MoveNext: Boolean;
        property Current: TFoo
                   read GetCurrent;
      end;
  public
    ...
    function GetEnumerator: TEnumerator;
  end;

function TFooSet.GetEnumerator: TEnumerator;
begin

  Result := TEnumerator.Create(@Self);

end;

constructor TFooSet.TEnumerator.Create(Container: PFooSet);
begin

  inherited Create;

  FIndex := Ord(Low(TFoo)) - 1;
  FContainer := Container;

end;

function TFooSet.TEnumerator.MoveNext: Boolean;
begin

  while (FIndex < Ord(High(TFoo))) do
  begin
    FIndex := FIndex + 1;
    if TFoo(FIndex) in FContainer^ then
    begin
      Result := True;
      Exit;
    end;
  end;

  Result := False;

end;

function TFooSet.TEnumerator.GetCurrent: TFoo;
begin

  Result := TFoo(FIndex);

end;

これでTFooSetに対して通常の集合型のように"+"、"-"、"*"のような演算や"="、"<>"のような比較、for..inによる要素の取り出しを行うことができるようになりました。 同様にすることで部分範囲型で値が0..255に収まらないようなものを基底型とするような集合型も実装することができます。 →要素数が256を超える列挙型の集合型(Gist) →値範囲が0..255に収まらない部分範囲型の集合型(Gist)

IDE Fix Pack 5.94

Andreas HausladenさんのIDE Fix PackがアップデートされてVersion 5.94となっています。RAD Studio/Delphi/C++Builder 10 Seattle対応といくつかの新しいパッチが追加されています。

IDE Fix Pack 5.94 released – RAD Studio 10 Seattle support | Andy's Blog and Tools

2015/11/02追記: SSE4.2非サポートのCPUの対応に不具合があり差し替えになっています。ご注意ください。

IDE Fix Pack 5.93

Andreas HausladenさんのIDE Fix PackがアップデートされてVersion 5.93となっています。今回はWindows 10対応(Windows 10が関数アライメントのパディングにNOPではなくINT3を使うことに対応)だけとのことです。

IDE Fix Pack 5.93 – Windows 10 support | Andy's Blog and Tools

IDE Fix Pack 5.92

Andreas HausladenさんのIDE Fix PackがアップデートされてVersion 5.92となっています。不具合を2点修正とのことです。

IDE Fix Pack 5.92 released | Andy's Blog and Tools

IDE Fix Pack 5.91

Andreas HausladenさんのIDE Fix PackがアップデートされてVersion 5.91となっています。

IDE Fix Pack 5.91 – Bugfix release | Andy's Blog and Tools

DDevExtensions 2.83/IDE Fix Pack 5.9

Andreas HausladenさんのDDevExtensionsとIDE Fix PackがRAD Studio XE8に対応しました。

DDevExtensions 2.83 for XE8 released | Andy's Blog and Tools
IDE Fix Pack 5.9 for RAD Studio 2009-XE8 | Andy's Blog and Tools

2015/09/20追記: DDevExtensionsがRAD Studio/Delphi/C++Builder 10 Seattleに対応して再リリースされています。内容に変更はないとのことで、バージョンも2.83のままとなっています。

IDE Fix Pack 5.8

Andreas HausladenさんのIDE Fix PackがアップデートされてVersion 5.8になっています。このバージョンでは規模の大きなパッケージが別の大きなパッケージに依存しているときのパフォーマンスの改善などの新機能と、Windows 8.1環境下でのDelphi 2009起動時の問題や、一部の環境でIDE Fix Packをインストール/アンインストールしようとしたときにエラーが発生する問題などの修正が行われています、

IDE Fix Pack 5.8 for 2009-XE7 released | Andy's Blog and Tools

シリアルポートをフレンドリ名で列挙する

以前使用できるシリアルポートをレジストリから列挙する方法について書きましたが、今度はシリアルポートをそのフレンドリ名(デバイスマネージャ上で表示される表記)とともに列挙する方法です。

フレンドリ名の取得にはSetup APIを使用しますが、残念ながらDelphiにはSetup API関係の定義が含まれていない(C++Builderならsetupapi.hがあるのですが)ため、まずは必要なWin32APIと構造体を定義します。

{ Setup APIs }
type
  { HDEVINFO }
  HDEVINFO = THandle;
  {$EXTERNALSYM HDEVINFO}

  { SP_DEVINFO_DATA }
  SP_DEVINFO_DATA = packed record
    cbSize: DWORD;
    ClassGuid: TGUID;
    DevInst: DWORD;
    Reserved: ULONG_PTR;
  end;
  {$EXTERNALSYM SP_DEVINFO_DATA}

const
  { Flags for SetupDiGetClassDevs }
  DIGCF_PRESENT         = $00000002;
  {$EXTERNALSYM DIGCF_PRESENT}

  { Property for SetupDiGetDeviceRegistryProperty }
  SPDRP_DEVICEDESC      = $00000000;
  {$EXTERNALSYM SPDRP_DEVICEDESC}
  SPDRP_FRIENDLYNAME    = $0000000C;
  {$EXTERNALSYM SPDRP_FRIENDLYNAME}

  { Scope for SetupDiOpenDevRegKey }
  DICS_FLAG_GLOBAL      = $00000001;
  {$EXTERNALSYM DICS_FLAG_GLOBAL}

  { KeyType for SetupDiOpenDevRegKey }
  DIREG_DEV             = $00000001;
  {$EXTERNALSYM DIREG_DEV}

{ SetupDiClassGuidsFromName }
function SetupDiClassGuidsFromName(const ClassName: PChar;
                                   ClassGuidList: PGUID;
                                   ClassGuidListSize: DWORD;
                                   var RequiredSize: DWORD): BOOL; stdcall;
  external 'SetupApi.dll' name
{$IFDEF UNICODE}
  'SetupDiClassGuidsFromNameW';
{$ELSE}
  'SetupDiClassGuidsFromNameA';
{$ENDIF}
{$EXTERNALSYM SetupDiClassGuidsFromName}

{ SetupDiGetClassDevs }
function SetupDiGetClassDevs(ClassGuid: PGUID;
                             const Enumerator: PChar;
                             hwndParent: HWND;
                             Flags: DWORD): HDEVINFO; stdcall;
  external 'SetupApi.dll' name
{$IFDEF UNICODE}
  'SetupDiGetClassDevsW';
{$ELSE}
  'SetupDiGetClassDevsA';
{$ENDIF}
{$EXTERNALSYM SetupDiGetClassDevs}

{ SetupDiDestroyDeviceInfoList }
function SetupDiDestroyDeviceInfoList(DeviceInfoSet: HDEVINFO): BOOL; stdcall;
  external 'SetupApi.dll' name 'SetupDiDestroyDeviceInfoList';
{$EXTERNALSYM SetupDiDestroyDeviceInfoList}

{ SetupDiEnumDeviceInfo }
function SetupDiEnumDeviceInfo(DeviceInfoSet: HDEVINFO;
                               MemberIndex: DWORD;
                               var DeviceInfoData: SP_DEVINFO_DATA): BOOL; stdcall;
  external 'SetupApi.dll' name 'SetupDiEnumDeviceInfo';
{$EXTERNALSYM SetupDiEnumDeviceInfo}

{ SetupDiGetDeviceRegistryProperty }
function SetupDiGetDeviceRegistryProperty(DeviceInfoSet: HDEVINFO;
                                          const DeviceInfoData: SP_DEVINFO_DATA;
                                          Prop: DWORD;
                                          PropertyRegDataType: PDWORD;
                                          PropertyBuffer: Pointer;
                                          PropertyBufferSize: DWORD;
                                          var RequiredSize: DWORD): BOOL; stdcall;
  external 'SetupApi.dll' name
{$IFDEF UNICODE}
  'SetupDiGetDeviceRegistryPropertyW';
{$ELSE}
  'SetupDiGetDeviceRegistryPropertyA';
{$ENDIF}
{$EXTERNALSYM SetupDiGetDeviceRegistryProperty}

{ SetupDiOpenDevRegKey }
function SetupDiOpenDevRegKey(DeviceInfoSet: HDEVINFO;
                              var DeviceInfoData: SP_DEVINFO_DATA;
                              Scope: DWORD;
                              HwProfile: DWORD;
                              KeyType: DWORD;
                              samDesired: REGSAM): HKEY; stdcall;
  external 'SetupApi.dll' name 'SetupDiOpenDevRegKey';
{$EXTERNALSYM SetupDiOpenDevRegKey}

これらを使用してシリアルポートをそのフレンドリ名とともに取得します。

function EnumSerialCommWithFriendlyName(const S: TStrings): Integer;
var
  Guid: TGUID;
  Size: DWORD;
  hDevInf: HDEVINFO;
  Index: DWORD;
  DevInfoData: SP_DEVINFO_DATA;
  S1: String;
  hRegKey: HKEY;
  S2: String;
  RegType: DWORD;
  PortNo: Integer;
begin

  Result := 0;

  Size := 0;
  if SetupDiClassGuidsFromName('Ports',@Guid,1,Size) = False then
  begin
    RaiseLastOSError;
  end;

  hDevInf := SetupDiGetClassDevs(@Guid,nil,0,DIGCF_PRESENT);
  if hDevInf = INVALID_HANDLE_VALUE then
  begin
    RaiseLastOSError;
  end;

  try
    Index := 0;
    while True do
    begin
      FillChar(DevInfoData,SizeOf(DevInfoData),0);
      DevInfoData.cbSize := SizeOf(DevInfoData);
      if SetupDiEnumDeviceInfo(hDevInf,Index,DevInfoData) = False then
      begin
        Break;
      end;

      SetupDiGetDeviceRegistryProperty(hDevInf,DevInfoData,SPDRP_FRIENDLYNAME,
                                       nil,nil,0,Size);
      SetLength(S1,(Size + SizeOf(Char)) div SizeOf(Char));

      if SetupDiGetDeviceRegistryProperty(hDevInf,DevInfoData,SPDRP_FRIENDLYNAME,
                                          nil,PChar(S1),Size,Size) = True then
      begin
        SetLength(S1,StrLen(PChar(S1)));
        hRegKey := SetupDiOpenDevRegKey(hDevInf,DevInfoData,DICS_FLAG_GLOBAL,0,DIREG_DEV,KEY_READ);
        if hRegKey <> INVALID_HANDLE_VALUE then
        begin
          try
            if RegQueryInfoKey(hRegKey,nil,nil,nil,nil,nil,nil,nil,nil,
                               @Size,nil,nil) = ERROR_SUCCESS then
            begin
              SetLength(S2,(Size + SizeOf(Char)) div SizeOf(Char));
              if (RegQueryValueEx(hRegKey,'PortName',nil,@RegType,Pointer(PChar(S2)),
                                  @Size) = ERROR_SUCCESS) and
                 (RegType = REG_SZ) then
              begin
                SetLength(S2,StrLen(PChar(S2)));
                if CompareText(Copy(S2,1,3),'COM') = 0 then
                begin
                  if TryStrToInt(Copy(S2,4,Length(S2)),PortNo) = True then
                  begin
                    S.AddObject(S1,Pointer(PortNo));
                    if Result < PortNo then
                    begin
                      Result := PortNo;
                    end;
                  end;
                end;
              end;
            end;

          finally
            RegCloseKey(hRegKey);
          end;
        end;
      end;

      Index := Index + 1;
    end;

  finally
    SetupDiDestroyDeviceInfoList(hDevInf);
  end;

end;

手順ですが、まずSetupDiClassGuidsFromNameでデバイスインタフェースクラスが'Ports'のGUIDを取得し、そのGUIDを使用してSetupDiGetClassDevsで現在システムに認識されているDevice Information Setsを取得し、SetupDiEnumDeviceInfoでDevice Information Set一つずつの情報をSP_DEVINFO_DATAに取り出して、SetupDiGetDeviceRegistryPropertyでフレンドリ名を取得します。さらにSetupDiOpenDevRegKeyでデバイス固有情報の含まれるレジストリキー('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Enum'の下のデバイスごとのキーに含まれる'Device Parameters'キー)を開き、RegQueryValueExで'PortName'という名前でREG_SZの値のデータを文字列として取得し、'COM'で始まっていたらシリアルポートとしてフレンドリ名とともにパラメータ(S: TStrings)に格納します。全てのDevice Information Setをチェックし終わったらSetupDiDestroyDeviceInfoListでDevice Information Sets全体を解放します。 以前のものと同様に必ずしもポート番号順にはなっていないため、必要に応じて結果をソートしてください。

→シリアルポートをフレンドリ名で列挙 (Gist)

DDevExtensions 2.82/IDE Fix Pack 5.7

Andreas HausladenさんのDDevExtensionsがアップデートされてVersion 2.82になっています。クラス補完関係の機能追加とXE6上での不具合修正が含まれています。またIDE Fix PackもアップデートされてVersion 5.7になっています。こちらはいくつかのfixが追加されています。

DDevExtensions 2.82 and IDE Fix Pack 5.7 released | Andy's Blog and Tools

IDE Fix Pack 5.5

Andreas HausladenさんのIDE Fix Pack 2009-XE5がアップデートされてVersion 5.5になっています。なおDelphi 2010/XE2/XE3/XE4についてはこのバージョンで更新終了とのことです。

IDE Fix Pack 5.5 (2009-XE5) released | Andy's Blog and Tools

DDevExtensions 2.81

Andreas HausladenさんのDDevExtensionsがアップデートされてVersion 2.81になっています。RAD Studio XE6対応とバグフィックスです。

DDevExtensions, DFMCheck and ByteStrings for XE6 | Andy's Blog and Tools

IDE Fix Pack 5.4.1

Andreas HausladenさんのIDE Fix Pack 2009-XE5がアップデートされてVersion 5.4.1になっています。RAD Studio XE5 Update 2でのコンパイラの変更に対応しているとのことです。

IDE Fix Pack 5.4.1 – Support for XE5 Updater 2 | Andy's Blog and Tools

DDevExtensions 2.8

Andreas HausladenさんのDDevExtensionsがアップデートされてVersion 2.8になっています。RAD Studio XE5対応とバグフィックスが含まれています。

DDevExtensions 2.8 released (2009-XE5) | Andy's Blog and Tools

IDE Fix Pack 5.4

Andreas HausladenさんのIDE Fix Pack 2009-XE5がアップデートされてVersion 5.4になっています。RAD Studio XE5対応のほか、いくつかのバグフィックスとコンパイラの最適化が含まれているとのことです。

IDE Fix Pack 5.4 for 2009-XE5 released | Andy's Blog and Tools