Windows XP 対応アプリを作る

　Windows XP で動作すれば "Windows XP 対応" なのか？確かにある意味そうなのでしょうが、XP で実装された新機能も知らないで "XP対応" とはいかがなものかと...。

・フォント
 　Windows XP では固定ピッチフォント、正確に言うと "MS ゴシック / MS 明朝" のサイズが従来の Windows と異なり、半角文字と全角文字が完全に 1:2 になりました。よって、XP を視野に入れるには余裕を持ったコントロールの配置が必要となります。キャプションが切れているのに "XP 対応" なんて書いたら恥ずかしいですよ(^^;

・アイコン
 　Windows XP ではフルカラーアイコンが使えるようになりました。正確に言うと 32bit アイコンが使えるようになっています。RGB 各 256 階調 + 透明度 (アルファ) 256 階調です。このサイトにある MuRIC で作成する事ができます。

・視覚テーマ(ビジュアルスタイル)
 　Windows XP ではウィンドウの見た目を切り替える事ができます。具体的な作り方は以下を参照して下さい。

1.マニフェストファイル (*.manifest) を作成する。
 　 マニフェストファイルと呼ばれる XML 形式のファイルを作成します。赤い文字以外の所はそのままで構いません。
 
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0">
<assemblyIdentity
 version="バージョン"
 processorArchitecture="X86"
 name="アプリケーション名"
 type="win32"
/>
<description>アプリケーションの説明</description>
<dependency>
<dependentAssembly>
<assemblyIdentity
 type="win32"
 name="Microsoft.Windows.Common-Controls"
 version="6.0.0.0"
 processorArchitecture="X86"
 publicKeyToken="6595b64144ccf1df"
 language="*"
 />
</dependentAssembly>
</dependency>
</assembly>

　こんな内容のファイルを作成し、名前を "アプリケーション名.exe.manifest" とします (赤字の所は適宜書き換えてください)。日本語を使ったら文字コードセットをUTF-8形式で保存する事。

2.マニフェストファイルをリソース化し、EXE に統合する。
 　上記のマニフェストファイルを作成したら、リソーススクリプトファイル (*.rc) を書きます。

#define CREATEPROCESS_MANIFEST_RESOURCE_ID 1
#define CONTROL_PANEL_RESOURCE_ID 123
#define RT_MANIFEST 24
CREATEPROCESS_MANIFEST_RESOURCE_ID RT_MANIFEST "マニフェストファイル名"

　これを BRCC32.EXE 等のリソースコンパイラでコンパイルしてリソースファイル (*.res) を生成します。そして、プロジェクトファイル (*.dpr) に $R 指令でこのリソースファイルを指定します。

3.よく解らないけどユーザーメッセージを無視する
 　これをやらないとツールバーのボタンがマウスで押下しても引っ込まなかったり、操作不能になる事があります (情報提供: 飛龍＋＋氏)。

private
 { Private 宣言 }
  procedure AppMessage(var Msg: TMsg; var Handled: Boolean);

...  

procedure TForm1.FormCreate(Sender: TObject);
begin
  Application.OnMessage := AppMessage;
end;

procedure TForm1.AppMessage(var Msg: TMsg; var Handled: Boolean);
begin
  case Msg.Message of
    WM_USER + $0500:
      Handled := True;
  end;
end;

　上記のソースを参考に、アプリケーションにコードを追加して下さい。

<!> Delphi 7～2006 では XPMan を uses するだけで対応できます。Delphi 2007 以降なら、プロジェクトのオプションで "ランタイムテーマを有効にする" にチェックを入れるだけです。 <!>

Windows のバージョンを本格的に判断する。

　WindowsのバージョンはGetVersionEx() で簡単に取得できますが、"OS 名" ともなると結構面倒なものです。

function IsWinNT: Boolean;
var
  Version: TOSVERSIONINFO;
begin
  result := False;
  Version.dwOSVersionInfoSize := SizeOf(Version);
  if GetVersionEx(Version) then
    if Version.dwPlatformId = VER_PLATFORM_WIN32_NT then
      result := True;
end;

function GetOSVersion: Integer;
var
  Version: TOSVERSIONINFO;
begin
  result := 0;
  Version.dwOSVersionInfoSize := SizeOf(Version);
  if GetVersionEx(Version) then
    result := (Version.dwMajorVersion  * 1000000) + (Version.dwMinorVersion * 10000) + Version.dwBuildNumber;
end;

function GetOSName: String;
// http://msdn.microsoft.com/library/default.asp?url=/library/en-us/sysinfo/sysinfo_3a0i.asp
// http://msdn.microsoft.com/library/default.asp?url=/library/en-us/sysinfo/sysinfo_1o1e.asp
// http://www.microsoft.com/japan/support/kb/articles/JP158/2/38.asp
// http://msdn.microsoft.com/library/en-us/sysinfo/base/getting_the_system_version.asp
// http://msdn.microsoft.com/library/en-us/sysinfo/base/getnativesysteminfo.asp
// http://technet2.microsoft.com/WindowsServer/ja/Library/efd0febb-02d9-4963-b0f4-b82be29aba921041.mspx?mfr=true
// http://msdn2.microsoft.com/en-us/library/ms724358.aspx
type
TOSVERSIONINFOEX =
   packed record
     dwOSVersionInfoSize:Cardinal;
     dwMajorVersion     :Cardinal;
     dwMinorVersion     :Cardinal;
     dwBuildNumber      :Cardinal;
     dwPlatformId       :Cardinal;
     szCSDVersion       :array [0..127] of Char;
     wServicePackMajor  :Word;
     wServicePackMinor  :Word;
     wSuiteMask         :Word;
     wProductType       :Byte;
     wReserved          :Byte;
   end;
const
  VER_NT_WORKSTATION       = 1;
  VER_NT_DOMAIN_CONTROLLER = 2;
  VER_NT_SERVER            = 3;
  VER_SUITE_SMALLBUSINESS            = $0001;
  VER_SUITE_ENTERPRISE               = $0002;
  VER_SUITE_BACKOFFICE               = $0004;
  VER_SUITE_TERMINAL                 = $0010;
  VER_SUITE_SMALLBUSINESS_RESTRICTED = $0020;
  VER_SUITE_DATACENTER               = $0080;
  VER_SUITE_SINGLEUSERTS             = $0100;
  VER_SUITE_PERSONAL                 = $0200;
  VER_SUITE_BLADE                    = $0400;

  PROCESSOR_ARCHITECTURE_INTEL           =  0;
  PROCESSOR_ARCHITECTURE_MIPS            =  1;
  PROCESSOR_ARCHITECTURE_ALPHA           =  2;
  PROCESSOR_ARCHITECTURE_PPC             =  3;
  PROCESSOR_ARCHITECTURE_SHX             =  4;
  PROCESSOR_ARCHITECTURE_ARM             =  5;
  PROCESSOR_ARCHITECTURE_IA64            =  6;
  PROCESSOR_ARCHITECTURE_ALPHA64         =  7;
  PROCESSOR_ARCHITECTURE_MSIL            =  8;
  PROCESSOR_ARCHITECTURE_AMD64           =  9;
  PROCESSOR_ARCHITECTURE_IA32_ON_WIN64   = 10;

  SM_SERVERR2 = 80;

  PRODUCT_UNDEFINED                    = $00000000;
  PRODUCT_ULTIMATE                     = $00000001;
  PRODUCT_HOME_BASIC                   = $00000002;
  PRODUCT_HOME_PREMIUM                 = $00000003;
  PRODUCT_ENTERPRISE                   = $00000004;
  PRODUCT_HOME_BASIC_N                 = $00000005;
  PRODUCT_BUSINESS                     = $00000006;
  PRODUCT_STANDARD_SERVER              = $00000007;
  PRODUCT_DATACENTER_SERVER            = $00000008;
  PRODUCT_SMALLBUSINESS_SERVER         = $00000009;
  PRODUCT_ENTERPRISE_SERVER            = $0000000A;
  PRODUCT_STARTER                      = $0000000B;
  PRODUCT_DATACENTER_SERVER_CORE       = $0000000C;
  PRODUCT_STANDARD_SERVER_CORE         = $0000000D;
  PRODUCT_ENTERPRISE_SERVER_CORE       = $0000000E;
  PRODUCT_ENTERPRISE_SERVER_IA64       = $0000000F;
  PRODUCT_BUSINESS_N                   = $00000010;
  PRODUCT_WEB_SERVER                   = $00000011;
  PRODUCT_CLUSTER_SERVER               = $00000012;
  PRODUCT_HOME_SERVER                  = $00000013;
  PRODUCT_STORAGE_EXPRESS_SERVER       = $00000014;
  PRODUCT_STORAGE_STANDARD_SERVER      = $00000015;
  PRODUCT_STORAGE_WORKGROUP_SERVER     = $00000016;
  PRODUCT_STORAGE_ENTERPRISE_SERVER    = $00000017;
  PRODUCT_SERVER_FOR_SMALLBUSINESS     = $00000018;
  PRODUCT_SMALLBUSINESS_SERVER_PREMIUM = $00000019;
var
  Unknown: Boolean;
  SP, Dmy: String;
  Version: TOSVERSIONINFO;
  VersionEX: TOSVERSIONINFOEX;
  SystemInfo: SYSTEM_INFO;
  {StatusEx begin}
  function StatusEx: TOSVERSIONINFOEX;
  var
    po: TFarProc;
    DLLWnd: THandle;
    VEX: TOSVERSIONINFOEX;
    GetVersionEx2: function(var LPOSVERSIONINFO: TOSVERSIONINFOEX): Boolean; stdcall;
  begin
    po := nil;
    DLLWnd := LoadLibrary('kernel32');
    if DLLWnd > 0 then
      begin
        try
          {$IFDEF UNICODE}
          po := GetProcAddress(DLLWnd, 'GetVersionExW');
          {$ELSE}
          po := GetProcAddress(DLLWnd, 'GetVersionExA');
          {$ENDIF}
          if po <> nil then
            begin
              @GetVersionEx2 := po;
              VEX.dwOSVersionInfoSize := SizeOf(VEX);
              if GetVersionEx2(VEX) then
                result := VEX;
            end;
        finally
          FreeLibrary(DLLWnd);
        end;
      end;
  end;
  {StatusEx end}
  {StatusEx2 begin}
  function StatusEx2: SYSTEM_INFO;
  var
    po: TFarProc;
    DLLWnd: THandle;
    SI: SYSTEM_INFO;
    GetNativeSystemInfo: procedure(var LPSYSTEM_INFO: SYSTEM_INFO); stdcall;
  begin
    po := nil;
    DLLWnd := LoadLibrary('kernel32');
    if DLLWnd > 0 then
      begin
        try
          po := GetProcAddress(DLLWnd, 'GetNativeSystemInfo');
          if po <> nil then
            begin
              @GetNativeSystemInfo := po;
              GetNativeSystemInfo(SI);
              result := SI;
            end;
        finally
          FreeLibrary(DLLWnd);
        end;
      end;
  end;
  {StatusEx2 end}
  {StatusEx3 begin}
  function StatusEx3(OSMajor, OSMinor, SPMajor, SPMinor: DWORD): DWORD;
  var
    po: TFarProc;
    DLLWnd: THandle;
    PT: DWORD;
    GetProductInfo: function(AOSMajor, AOSMinor, ASPMajor, ASPMinor: DWORD; var ProductType: DWORD): Boolean; stdcall;
  begin
    po := nil;
    DLLWnd := LoadLibrary('kernel32');
    if DLLWnd > 0 then
      begin
        try
          po := GetProcAddress(DLLWnd, 'GetProductInfo');
          if po <> nil then
            begin
              @GetProductInfo := po;
              GetProductInfo(OSMajor, OSMinor, SPMajor, SPMinor, PT);
              result := PT;
            end;
        finally
          FreeLibrary(DLLWnd);
        end;
      end;
  end;
  {StatusEx3 end}
begin
  result := '';
  Version.dwOSVersionInfoSize := SizeOf(Version);
  if GetVersionEx(Version) then
    begin
      Dmy := 'Windows';
      SP := Trim(StrPas(Version.szCSDVersion));
      case Version.dwPlatformId of
        // Windows3.1(Win32s)
        VER_PLATFORM_WIN32s:
          Dmy := Dmy + Format('%d.%d(Win32s)',[Version.dwMajorVersion, Version.dwMinorVersion]);
        // Windows9x系
        VER_PLATFORM_WIN32_WINDOWS:
          begin
            case Version.dwMinorVersion of
              // Windows95
              00:begin
                   Dmy := Dmy + '95';
                   case LOWORD(Version.dwBuildNumber) of
                     1111:
                       Dmy := Dmy + ' OSR2';
                     1212..1213:
                       Dmy := Dmy + ' OSR2.1';
                     1214..9999:
                       Dmy := Dmy + ' OSR2.5';
                   end;
                 end;
              // Windows98
              10:begin
                   Dmy := Dmy + '98';
                   case LOWORD(Version.dwBuildNumber) of
                    2222..9999:
                     Dmy := Dmy + ' Second Edition';
                   end;
                 end;
              // WindowsMe
              90:Dmy := Dmy + 'Me';
            end;
          end;
        // WindowsNT系
        VER_PLATFORM_WIN32_NT:
          begin
            Unknown := False;
            case Version.dwMajorVersion of
              5:begin
                  VersionEx := StatusEx;
                  case Version.dwMinorVersion of
                    // 2000
                    0:begin
                        Dmy := Dmy + '2000 ';
                        case VersionEx.wProductType of
                          VER_NT_WORKSTATION:
                            Dmy := Dmy + 'Professional';
                        else
                          Dmy := Dmy + 'Server';
                        end;
                      end;
                    // XP
                    1:begin
                        case VersionEx.wProductType of
                          VER_NT_WORKSTATION:
                            begin
                              Dmy := Dmy + 'XP ';
                              if (VersionEx.wSuiteMask and VER_SUITE_PERSONAL) = VER_SUITE_PERSONAL then
                                Dmy := Dmy + 'Home Edition'
                              else
                                Dmy := Dmy + 'Professional';
                            end;
                        else
                          Dmy := Dmy + 'Server 2003';
                        end;
                      end;
                    // XP
                    2:begin
                        SystemInfo := StatusEx2;
                        case VersionEx.wProductType of
                          VER_NT_WORKSTATION:
                            begin
                              if SystemInfo.wProcessorArchitecture = PROCESSOR_ARCHITECTURE_AMD64 then
                                Dmy := Dmy + 'XP Professional x64 Edition'
                              else
                                Unknown := True;
                            end;
                          VER_NT_SERVER,
                          VER_NT_DOMAIN_CONTROLLER:
                            begin
                              Dmy := Dmy + 'Server 2003 ';
                              if GetSystemMetrics(SM_SERVERR2) = 1 then
                                Dmy := Dmy + 'R2 ';  
                              case SystemInfo.wProcessorArchitecture of
                                PROCESSOR_ARCHITECTURE_IA64:
                                  begin
                                    if (VersionEx.wSuiteMask and VER_SUITE_DATACENTER)      = VER_SUITE_DATACENTER then
                                      Dmy := Dmy + 'Datacenter Edition for Itanium-based Systems'
                                    else if (VersionEx.wSuiteMask and VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE then
                                      Dmy := Dmy + 'Enterprise Edition for Itanium-based Systems'
                                    else
                                      Dmy := Dmy + 'Standard Edition for Itanium-based Systems';
                                  end;
                                PROCESSOR_ARCHITECTURE_AMD64:
                                  begin
                                    if (VersionEx.wSuiteMask and VER_SUITE_DATACENTER)      = VER_SUITE_DATACENTER then
                                      Dmy := Dmy + 'Datacenter x64 Edition'
                                    else if (VersionEx.wSuiteMask and VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE then
                                      Dmy := Dmy + 'Enterprise x64 Edition'
                                    else
                                      Dmy := Dmy + 'Standard x64 Edition';
                                  end;
                              else
                                if (VersionEx.wSuiteMask and VER_SUITE_DATACENTER)      = VER_SUITE_DATACENTER then
                                  Dmy := Dmy + 'Datacenter Edition'
                                else if (VersionEx.wSuiteMask and VER_SUITE_ENTERPRISE) = VER_SUITE_ENTERPRISE then
                                  Dmy := Dmy + 'Enterprise Edition'
                                else if (VersionEx.wSuiteMask and VER_SUITE_BLADE)      = VER_SUITE_BLADE then
                                  Dmy := Dmy + 'Web Edition'
                                else
                                  Dmy := Dmy + 'Standard Edition';
                              end;    
                            end;
                          else
                            Unknown := True;
                        end;
                      end;
                  else
                    Unknown := True;
                  end;
                end;
              6:begin
                  VersionEx := StatusEx;
                  case Version.dwMinorVersion of
                    0, 1:
                      begin
                        case VersionEx.wProductType of
                          VER_NT_WORKSTATION:
                            begin
                              case Version.dwMinorVersion of
                                0:Dmy := Dmy + ' Vista ';
                                1:Dmy := Dmy + ' 7 ';
                              end;
                              case StatusEx3(Version.dwMajorVersion, Version.dwMinorVersion, 0, 0) of
                                PRODUCT_ULTIMATE:
                                  Dmy := Dmy + 'Ultimate';
                                PRODUCT_HOME_BASIC:
                                  Dmy := Dmy + 'Home Basic';
                                PRODUCT_HOME_PREMIUM:
                                  Dmy := Dmy + 'Home Premium';
                                PRODUCT_ENTERPRISE:
                                  Dmy := Dmy + 'Business';
                                PRODUCT_HOME_BASIC_N:
                                  Dmy := Dmy + 'Home Basic N';
                                PRODUCT_BUSINESS:
                                  Dmy := Dmy + 'Business';
                                PRODUCT_STARTER:
                                  Dmy := Dmy + 'Starter Edition';
                                PRODUCT_BUSINESS_N:
                                  Dmy := Dmy + 'Business N';
                              end;
                            end;
                        else
                          case Version.dwMinorVersion of
                            0:Dmy := Dmy + 'Server 2008 ';
                            1:Dmy := Dmy + 'Server 2008 R2 ';
                          end;
                          case StatusEx3(Version.dwMajorVersion, Version.dwMinorVersion, 0, 0) of
                            PRODUCT_STANDARD_SERVER:              
                              Dmy := Dmy + 'Standard Edition';
                            PRODUCT_DATACENTER_SERVER:
                              Dmy := Dmy + 'Datacenter Edition';
                            PRODUCT_SMALLBUSINESS_SERVER:
                              Dmy := Dmy + 'Small Business Server';
                            PRODUCT_ENTERPRISE_SERVER:
                              Dmy := Dmy + 'Enterprise Edition';
                            PRODUCT_DATACENTER_SERVER_CORE:
                              Dmy := Dmy + 'Datacenter Edition(Core)';
                            PRODUCT_STANDARD_SERVER_CORE:
                              Dmy := Dmy + 'Standard Edition(Core)';
                            PRODUCT_ENTERPRISE_SERVER_CORE:
                              Dmy := Dmy + 'Enterprise Edition(Core)';
                            PRODUCT_ENTERPRISE_SERVER_IA64:
                              Dmy := Dmy + 'Enterprise Edition for Itanium-based Systems';
                            PRODUCT_WEB_SERVER:
                              Dmy := Dmy + 'Web Server Edition';
                            PRODUCT_CLUSTER_SERVER:
                              Dmy := Dmy + 'Cluster Server Edition';
                            PRODUCT_HOME_SERVER:
                              Dmy := Dmy + 'Home Server Edition';
                            PRODUCT_STORAGE_EXPRESS_SERVER:
                              Dmy := Dmy + 'Storage Server Express Edition';
                            PRODUCT_STORAGE_STANDARD_SERVER:
                              Dmy := Dmy + 'Storage Server Standard Edition';
                            PRODUCT_STORAGE_WORKGROUP_SERVER:
                              Dmy := Dmy + 'Storage Server Workgroup Edition';
                            PRODUCT_STORAGE_ENTERPRISE_SERVER:
                              Dmy := Dmy + 'Storage Server Enterprise Edition';
                            PRODUCT_SERVER_FOR_SMALLBUSINESS:
                              Dmy := Dmy + 'for Small Business Edition';
                            PRODUCT_SMALLBUSINESS_SERVER_PREMIUM:
                              Dmy := Dmy + 'Small Business Server Premium Edition';
                          end;
                        end;
                        case SystemInfo.wProcessorArchitecture of
                          PROCESSOR_ARCHITECTURE_IA64:
                            Dmy := Dmy + '(IA64)';
                          PROCESSOR_ARCHITECTURE_AMD64:
                            Dmy := Dmy + '(x64)';
                        end;
                      end;
                  else
                    Unknown := True;
                  end;
                end;
            else
              Unknown := True;
            end;
            if Unknown then
              begin
                Dmy := Dmy + Format('NT%d.%d ',[Version.dwMajorVersion, Version.dwMinorVersion]);
                // NT4.0 SP6以降 or XP以降
                if (Version.dwMajorVersion >= 5) or
                   ((Version.dwMajorVersion = 4) and (Pos('6', SP) > 0)) then
                  begin
                    VersionEx := StatusEx;
                    case VersionEx.wProductType of
                      VER_NT_WORKSTATION:
                         Dmy := Dmy + 'WorkStation';
                    else
                      Dmy := Dmy + 'Server';
                    end;
                  end;
              end;
          end;
      end;
      if Length(SP) > 0 then
        Dmy := Dmy + Format(' [%s]',[SP]);
    end;
  result := Dmy;
end; 

<!> 動作させる OS を限定すれば、WMI で取得するのが簡単です。 <!>

印刷部数を指定して印刷する

　Printers 変数を用いてゴリゴリ印刷する場合のお話です。

procedure PrintProc(n: Integer);
var
  i, c: Integer;
begin
  if (pcCopies in Printer.Capabilities) then
    begin
      c := 1;
      Printer.Copies := n;
    end
  else
    begin
      c := n;
      Printer.Copies := 1;
    end;
  for i := 1 to c do
    begin
      Printer.BeginDoc;
      try
        // 印刷処理
      finally
        Printer.EndDoc;
      end;
    end;
end;

　このロジックは、"プリンタが部数印刷に対応していればそっちを利用する" というモノです。対応していない場合にはループで回して印刷します。

CPU を判断する

　ソフトの動作環境を調べる一つの手段ですね。絶対ではありませんが。

// http://www.dinop.com/vc/vctips.html
// http://www2u.biglobe.ne.jp/~M_manu/colum/comp/07.html
// http://www.mechatronics.mech.tohoku.ac.jp/~kumagai/research/library/linux/tips.html#rdtsc

function IsEnableCPUID: Boolean;
var
  dwTemp1,
  dwTemp2: DWORD;
begin
  asm
    pushfd
    pop eax
    mov dwTemp1,eax
    xor eax,00200000h
    push eax
    popfd
    pushfd
    pop eax
    mov dwTemp2,eax
  end;
  result := (dwTemp1 <> dwTemp2);
end;

function GetCPUFreq: Double;
var
  dwEAX1,
  dwEAX2,
  dwEDX1,
  dwEDX2,
  dwTime: DWORD;

  {IsEnableRDTSC Start}
  // IsProcessorFeaturePresent()は
  // NT系のOSでしか使えないため
  function IsEnableRDTSC: Boolean;
  var
    dwTemp: DWORD;
  begin
    result := False;
    if not IsEnableCPUID then
      Exit;
    asm
      pushad
      mov eax, 1
      DB 0Fh, 0A2h // cpuid
      mov dwTemp, edx
      popad
    end;
    result := ((dwTemp and $00000010) = $00000010);
  end;
  {IsEnableRDTSC End}
begin
  result := -1;
  if not IsEnableRDTSC then
    Exit;
  dwTime := GetTickCount;
  asm
    DB 0Fh,031h // rdtsc
    mov dwEAX1,eax
    mov dwEDX1,edx
  end;
  while True do // 2秒アイドル用の無限ループ
    begin
      if (GetTickCount - dwTime) > 2000 then
        Break;
    end;
  dwTime := GetTickCount - dwTime;
  asm
    DB 0Fh,031h // rdtsc
    mov dwEAX2,eax
    mov dwEDX2,edx
  end;
  dwEDX2 := dwEDX2 - dwEDX1;
  dwEAX2 := dwEAX2 - dwEAX1;
  result := (dwEDX2 shl 32) + dwEAX2; //Clock数
  result := result / (dwTime * 1000); //MHz
end;

function GetProcessorCount: Integer;
var
  SI: TSystemInfo;
begin
  GetSystemInfo(SI);
  result := SI.dwNumberOfProcessors;
end;

function GetCPUID(Func1, Func2: Byte): DWORD;
var
  dwEAX,
  dwEBX,
  dwECX,
  dwEDX: DWORD;
begin
  result := $FFFFFFFF;
  if not IsEnableCPUID then
    Exit;
  asm
    pushad
    mov eax, Func1
    DB 0Fh, 0A2h // cpuid
    mov dwEAX, eax
    mov dwEBX, ebx
    mov dwECX, ecx
    mov dwEDX, edx
    popad
  end;
  case Func2 of
    0: result := dwEAX;
    1: result := dwEBX;
    2: result := dwECX;
    3: result := dwEDX;
  end;
end;

Ex.

  1. GetProcessorCount でプロセッサ数を取得
  2. "1." が 1 以上だったら論理プロセッサ数はその値。
  3. GetCPUID(1, 3) で 28Bit 目を調べる
  4. "2." のフラグが立っていたら GetCPUID(1, 1) で Bit16～Bit23 を調べる
  5. "3." が 1 以上だったら論理プロセッサ数はその値そうでなければ論理プロセッサ数は 1

[Intel製CPUの機能一覧(一部)]

Func1
/
Func2		 0 (EAX) 1 (EBX) 2 (ECX) 3 (EDX)
0
(基本)		 Func1 (基本) に設定できる最大値 ベンダ ID 文字列
1～4 文字目		 ベンダ ID 文字列
9～12 文字目		 ベンダ ID 文字列
5～8 文字目
1
(基本)
Bit0-Bit3 ステッピングID
Bit4-Bit7 モデル番号
Bit8-Bit11 ファミリ・コード
Bit12-Bit13 プロセッサタイプ
Bit16-Bit19 拡張モデル
Bit20-Bit27 拡張ファミリ
Bit0-Bit7 ブランドID
Bit8-Bit15 チャンク
Bit16-Bit23 論理プロセッサ数
Bit24-Bit31 APIC ID
(reserved)
Bit0 オンチップ浮動小数点ユニット (FPU)
Bit1 仮想モード拡張 (VME)
Bit2 デバッグ拡張機能 (DE)
Bit3 ページサイズ拡張 (PSE)
Bit4 タイムスタンプカウンタ (TSC)
Bit5 モデル固有レジスタ (MSR)
Bit6 物理アドレス拡張 (PAE)
Bit7 マシンチェック例外 (MCE)
Bit8 CMPX CH8 命令のサポート (CX8)
Bit9 オンチップ APIC ハードウェアサポート (APIC)
Bit10 (reserved)
Bit11 高速システムコール (SEP)
Bit12 メモリタイプ・レンジレジスタ (MTRR)
Bit13 ページグローバルイネーブル (PGE)
Bit14 マシンチェックアーキテクチャ (MCA)
Bit15 条件付き移動命令のサポート (CMOV)
Bit16 ページ属性テーブル (PAT)
Bit17 36 ビットページ拡張 (PSE-36)
Bit18 プロセッサシリアルナンバーのサポートとイネーブル (PSN)
Bit19 CLFLUSH 命令のサポート (CLFLUSH)
Bit20 (reserved)
Bit21 デバッグストア (DS)
Bit22 温度モニタ及びソフトウェア制御されるクロック機能のサポート (ACPI)
Bit23 MMXテクノロジのサポート (MMX)
Bit24 浮動小数点コンテキストの高速セーブ / リストア (FXSR)
Bit25 ストリーミング SIMD 拡張命令のサポート (SSE)
Bit26 ストリーミング SIMD 拡張命令2のサポート (SSE2)
Bit27 セルフスヌープ (SS)
Bit28 ハイパースレッディングのサポート(HTT)
Bit29 温度モニタのサポート (TM)
Bit30 (reserved)
Bit31 (reserved)
2
(基本)		 キャッシュ特性とTLB特性 キャッシュ特性と TLB特性 キャッシュ特性とTLB特性 キャッシュ特性と TLB特性
3
(基本)		 (reserved) (reserved) 96Bit のプロセッサ・シリアルナンバーの Bit0～Bit31 96Bitの プロセッサ・シリアルナンバーの Bit32～Bit63

詳しくは以下の URL の資料を参照の事

 BACK