HOME > エクセルVBA > サンプル > GetSystemInfo

GetSystemInfo


【ファイル名】GetSystemInfo.xlsm
【バージョン】Ver 1.0.0.0
【作成日】2021年05月11日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】GetSystemInfo.zip
【説明】Windows APIのGetSystemInfoを使用したプロセッサの情報を表示するサンプルです。

メモリの情報の画面

【外部リンク】Windows > Apps > Win32 > API > System Services > Sysinfoap.h > GetSystemInfo function
【外部リンク】Windows > Apps > Win32 > API > System Services > Sysinfoap.h > GetNativeSystemInfo function
【外部リンク】Windows > Apps > Win32 > API > Sysinfoap.h > SYSTEM_INFO structure

customUI14.xml
<?xml version="1.0" encoding="utf-8"?>
<customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui" onLoad="onLoad">
  <ribbon startFromScratch="false">
    <tabs>
      <tab id="Tab1" label="サンプル" insertBeforeMso="TabHome" keytip="S">
        <group id="Group1" label="プロセッサの情報">
          <button id="ShowFormButton" label="フォームを表示(&amp;S)" supertip="フォームを表示します。" onAction="onAction" />
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

UserForm1
このページの上

Option Explicit

#If Win64 Then
' https://docs.microsoft.com/en-us/windows/win32/api/sysinfoapi/ns-sysinfoapi-system_info

  Private Type SYSTEM_INFO
    wProcessorArchitecture As Integer ' 使わない
    wReserved As Integer ' 使わない
    dwPageSize                  As Long    ' メモリページのサイズ
    lpMinimumApplicationAddress As LongPtr ' アプリケーションが利用可能なメモリ空間の最下位アドレス
    lpMaximumApplicationAddress As LongPtr ' アプリケーションが利用可能なメモリ空間の最上位アドレス
    dwActiveProcessorMask       As LongPtr ' システム中に存在するプロセッサのビットマスク
    dwNumberOfProcessors        As Long    ' システム中に存在するプロセッサの数
    dwProcessorType             As Long    ' プロセッサの種類
    dwAllocationGranularity     As Long    ' メモリ空間割り当ての最小単位
    wProcessorLevel             As Integer ' プロセッサの種類
    wProcessorRevision          As Integer ' プロセッサのバージョン
  End Type
  
' https://docs.microsoft.com/en-us/windows/win32/api/sysinfoapi/nf-sysinfoapi-getsysteminfo
  Private Declare PtrSafe Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
  
' https://docs.microsoft.com/en-us/windows/win32/api/sysinfoapi/nf-sysinfoapi-getnativesysteminfo
  Private Declare PtrSafe Sub GetNativeSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)

#Else
  Private Type SYSTEM_INFO
    wProcessorArchitecture As Integer
    wReserved As Integer
    dwPageSize As Long
    lpMinimumApplicationAddress As Long
    lpMaximumApplicationAddress As Long
    dwActiveProcessorMask As Long
    dwNumberOfProcessors As Long
    dwProcessorType As Long
    dwAllocationGranularity As Long
    wProcessorLevel As Integer
    wProcessorRevision As Integer
  End Type

  Private Declare Sub GetSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
  Private Declare Sub GetNativeSystemInfo Lib "kernel32" (lpSystemInfo As SYSTEM_INFO)
#End If

' プロセッサの情報を取得する
Private Sub CommandButton1_Click()
  Dim lpSystemInfo As SYSTEM_INFO
  Dim str As String
  
  Call GetSystemInfo(lpSystemInfo)
'  Call GetNativeSystemInfo(lpSystemInfo)
  
  str = ""
  With lpSystemInfo
    str = str & "dwPageSize = " & Format(.dwPageSize, "#,##0") & vbCrLf
    str = str & "lpMinimumApplicationAddress = " & Format(.lpMinimumApplicationAddress, "#,##0") & vbCrLf
    str = str & "lpMaximumApplicationAddress = " & Format(.lpMaximumApplicationAddress, "#,##0") & vbCrLf
    str = str & "dwActiveProcessorMask = " & Format(.dwActiveProcessorMask, "#,##0") & vbCrLf
    str = str & "dwNumberOfProcessors = " & Format(.dwNumberOfProcessors, "#,##0") & vbCrLf
    str = str & "dwProcessorType = " & Format(.dwProcessorType, "#,##0") & vbCrLf
    str = str & "dwAllocationGranularity = " & Format(.dwAllocationGranularity, "#,##0") & vbCrLf
    str = str & "wProcessorLevel = " & Format(.wProcessorLevel, "#,##0") & vbCrLf
    str = str & "wProcessorRevision = " & Format(.wProcessorRevision, "#,##0") & vbCrLf
  End With
  
  RefEdit1.Text = str
  RefEdit1.SelStart = 0
  RefEdit1.SelLength = 0
End Sub

Private Sub ExitButton_Click()
  Unload Me
End Sub

Private Sub UserForm_Initialize()
  CommandButton1_Click
End Sub
Module1
Option Explicit

Private rbRibbonUI As IRibbonUI   ' リボン

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  Set rbRibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbRibbonUI.Invalidate ' リボンの表示を更新します。
End Sub

Sub onAction(control As IRibbonControl) ' 各メニューの処理
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  Select Case control.ID
    Case "ShowFormButton"
      UserForm1.Show vbModal
    Case Else
      Beep ' 警告音
      MsgBox Prompt:=control.ID & "の処理がありません!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
      Exit Sub
  End Select
  
  Exit Sub
'
ErrorHandler: ' エラー処理ルーチン
  Beep ' 警告音
  MsgBox Prompt:="エラー番号:" & Err.Number & vbCrLf & Err.Description, Buttons:=vbCritical + vbSystemModal, Title:="エラー"
End Sub
このページの上