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

SearchPath


【ファイル名】SearchPath.xlsm
【バージョン】Ver 1.0.0.0
【作成日】2021年05月31日
【動作確認】Windows 10
【必要なソフト】Microsoft Excel 2010
【ダウンロード】SearchPath.zip
【説明】Windows APIのSearchPathW関数で、Where.exeのようにシステム、Winows、カレントディレクトリ、環境変数のPATHを検索してフルパス名を取得します。
画面

【外部リンク】Windows > Apps > Win32 > API > Data Access and Storage > Processenv.h >  SearchPathW 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="SearchPath">
          <box id="Box1" boxStyle="vertical">
            <editBox id="editBox1" label="ファイル名:" keytip="N" maxLength="1024" getText="getText" onChange="onChange"
                     supertip="ファイル名を入力して、Enter キーを押してください。"
                     sizeString="WWWWWMMMMMWWWWWMMMMMWWWWWMMMMM" />
            <button id="SearchPathButton" label="フルパス名" keytip="F" imageMso="HappyFace"
                    supertip="環境変数のPATHを検索してフルパス名を取得します。" onAction="onAction" />
            <labelControl id="labelControl1" label="Where.exeのように環境変数のPATHを検索してフルパス名を取得します。" />
          </box>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>
このページの上

Module1
Option Explicit

Private Const MAX_PATH = 260& ' パスの最大文字数

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

#If Win64 Then
  ' https://docs.microsoft.com/ja-jp/windows/win32/api/processenv/nf-processenv-searchpathw
  Private Declare PtrSafe Function SearchPath Lib "kernel32" Alias "SearchPathW" (ByVal lpPath As LongPtr, ByVal lpFileName As LongPtr, ByVal lpExtension As LongPtr, _
                                                                                  ByVal nBufferLength As Long, ByVal lpBuffer As LongPtr, ByVal lpFilePart As LongPtr) As Long
#Else
  Private Declare Function SearchPath Lib "kernel32" Alias "SearchPathW" (ByVal lpPath As Long, ByVal lpFileName As Long, ByVal lpExtension As Long, _
                                                                          ByVal nBufferLength As Long, ByVal lpBuffer As Long, ByVal lpFilePart As Long) As Long
#End If

' Where.exeのようにシステム、Winows、カレントディレクトリ、環境変数のPATHを検索してフルパス名を取得します。
Sub Show_SearchPath(FileName As String)
' HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Session Manager\
' SafeProcessSearchMode (REG_DWORD)
  Dim lpPath As String      ' 検索パス(ヌルを指定すると、レジストリの値により検索する順番が異なる)
  Dim lpFileName As String  ' 検索するファイル名
  Dim lpExtension As String ' 検索するファイルの拡張子(上の変数で拡張子を指定した場合はヌルで良い)
  Dim nBufferLength As Long ' 取得するフルパス名の文字数
  Dim lpBuffer As String    ' 一致したフルパス名
  Dim lpFilePart As Long    ' パス内の最後のバックスラッシュの後の文字のポインター(ファイル名のみを取得するため)
  Dim ret As Long

  lpPath = vbNullString ' 既定のパス順で検索する
  lpFileName = FileName & vbNullChar
  lpExtension = vbNullString
  
  lpBuffer = String$(MAX_PATH, vbNullChar)
  nBufferLength = Len(lpBuffer)
  ret = SearchPath(StrPtr(lpPath), StrPtr(lpFileName), StrPtr(lpExtension), nBufferLength, StrPtr(lpBuffer), lpFilePart)
  If ret < 1 Then
    MsgBox Prompt:="ファイルが見つかりませんでした。", Buttons:=vbExclamation + vbSystemModal, Title:="警告"
  Else
    lpBuffer = Left$(lpBuffer, InStr(lpBuffer, vbNullChar) - 1)
    MsgBox Prompt:=lpBuffer, Buttons:=vbInformation, Title:="情報"
  End If
End Sub

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

Sub onAction(control As IRibbonControl) ' 各メニューの処理
  On Error GoTo ErrorHandler ' エラー処理ルーチン
  
  Select Case control.ID
    Case "SearchPathButton"
      If Len(rbText) < 1 Then
        MsgBox Prompt:="ファイル名を入力してください!", Buttons:=vbCritical + vbSystemModal, Title:="エラー"
        Exit Sub
      End If
      
      Show_SearchPath rbText
    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に文字列を代入する
  returnedVal = rbText
End Sub

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