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

ShellAbout


【ファイル名】ShellAbout.xlsm
【バージョン】Ver 1.0.0.0
【作成日】2021年04月30日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】ShellAbout.zip
【説明】Windowsのバージョン情報のダイアログを表示するサンプルです。
メニュー

Windows APIでshell32.dllファイルのShellAboutW関数で、Windowsのバージョン情報のダイアログを表示します。
アプリケーションの名前とスタッフの名前を指定できます。
ShellAbout

【外部リンク】Windows > Apps > Win32 > API > The Windows Shell > Shellapi.h > ShellAboutW function

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="ShellAbout">
          <box id="Box1" boxStyle="vertical">
            <editBox id="AppEditBox" label="アプリケーション名:" keytip="A" screentip="アプリケーションの名前"
                     supertip="アプリケーションの名前を入力してください。" sizeString="WWWWWMMMMMWWWWWMMMMMWWWWWMMMMM" getText="getText" onChange="onChange" />
            <editBox id="StuffEditBox" label="スタッフ名:" keytip="S" screentip="スタッフの名前"
                     supertip="スタッフの名前を入力してください。" sizeString="WWWWWMMMMMWWWWWMMMMMWWWWWMMMMM" getText="getText" onChange="onChange" />
            <button id="ShellAboutButton" label="ShellAboutを表示" keytip="D" supertip="ShellAboutのダイアログを表示します。" onAction="onAction" />
          </box>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

Module1
Option Explicit

Private rbRibbonUI As IRibbonUI   ' リボン
Private rbAppText As String ' editBoxの文字列
Private rbStuffText As String ' editBoxの文字列

Sub onLoad(ribbon As IRibbonUI) ' リボンの初期処理
  rbAppText = "アプリケーションの名前"
  rbStuffText = "スタッフの名前"
  Set rbRibbonUI = ribbon ' リボンの表示を更新できるようにするためにリボンをセットする
  rbRibbonUI.Invalidate ' リボンの表示を更新します。
End Sub

Sub onAction(control As IRibbonControl) ' ボタンの処理
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  Select Case control.ID
    Case "ShellAboutButton"
      Call WindowsAPIModule.Show_ShellAbout(rbAppText, rbStuffText)
    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

Sub getText(control As IRibbonControl, ByRef returnedVal) ' editBoxに文字列を代入する
  Select Case control.ID
    Case "AppEditBox"
      returnedVal = rbAppText
    Case "StuffEditBox"
      returnedVal = rbStuffText
  End Select
End Sub

Sub onChange(control As IRibbonControl, text As String) ' editBoxで[Enter]キーを押したか、他のコントロールに移動した場合のイベント
  Select Case control.ID
    Case "AppEditBox"
      rbAppText = text
    Case "StuffEditBox"
      rbStuffText = text
  End Select
End Sub
このページの上

WindowsAPIModule
Option Explicit

#If Win64 Then
' https://docs.microsoft.com/en-us/windows/win32/api/shellapi/nf-shellapi-shellaboutw
  Private Declare PtrSafe Function ShellAbout Lib "shell32.dll" Alias "ShellAboutW" ( _
                  ByVal hwnd As LongPtr, _
                  ByVal szApp As LongPtr, _
                  ByVal szOtherStuff As LongPtr, _
                  ByVal hIcon As LongPtr) As Long

#Else
  Private Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutW" ( _
                  ByVal hwnd As Long, _
                  ByVal szApp As Long, _
                  ByVal szOtherStuff As Long, _
                  ByVal hIcon As Long) As Long
#End If

#If Win64 Then
Public Sub Show_ShellAbout(Optional ApplicationName As String = vbNullString, Optional StuffName As String = vbNullString, Optional hIcon As LongPtr = 0)
#Else
Public Sub Show_ShellAbout(Optional ApplicationName As String = vbNullString, Optional StuffName As String = vbNullString, Optional hIcon As Long = 0)
#End If
  Call ShellAbout(Application.hwnd, StrPtr(ApplicationName), StrPtr(StuffName), hIcon)
End Sub
このページの上