【VBA】ネットワークドライブ割当てダイアログ表示

2020年10月20日

VBAで「ネットワークドライブ割り当て」ダイアログを表示する方法です
「Declare Function」で「Windows API」を定義します
「Windows API」は、WindowsのC言語関数をVBから呼び出すインターフェースです

Windows API 呼び出し定義

標準モジュールに下記のコードを記述します
「Windows API」の部分です
dllとリンクさせる記述です
マクロボタンクリックイベントと同じモジュールに記述する場合はPublicではなくPrivateで良いです

Option Explicit

'「ネットワークドライブの割り当て」ダイアログを表示
Public Declare Function WNetConnectionDialog1 Lib "mpr.dll" Alias "WNetConnectionDialog1A" (lpConnectDlgStruct As Any) As Long
   
'メモリを確保
Public Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal uFlags As Long, ByVal dwBytes As Long) As Long
   
'メモリを解放
Public Declare Function GlobalFree Lib "kernel32.dll" (ByVal hMem As Long) As Long
   
'メモリをコピー
Public Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destinatition As Any, Source As Any, ByVal Length As Long)
   
'リソースの詳細を示すデータ型
Public Type tagNETRESOURCE
    dwScope       As Long
    dwType        As Long
    dwDisplayType As Long
    dwUsage       As Long
    lpLocalName   As String
    lpRemoteName  As String
    lpComment     As String
    lpProvider    As String
End Type

'「ネットワークドライブの割り当て」ダイアログを示すデータ型
Public Type tagCONNECTDLGSTRUCT
    cbStructure As Long
    hwndOwner   As Long
    lpConnRes   As Long
    dwFlags     As Long
    dwDevNum    As Long
End Type

Public Const RESOURCETYPE_DISK = &H1
Public Const GMEM_FIXED = &H0
Public Const GMEM_ZEROINIT = &H40
Public Const CONNDLG_USE_MRU = &H4
Public Const CONNDLG_HIDE_BOX = &H8
Public Const CONNDLG_NOT_PERSIST = &H20
Public Const NO_ERROR = 0

ネットワークドライブ割当てダイアログの表示

標準モジュールに定義したものを使ってダイアログを表示します
シートにマクロのコマンドボタンを追加し呼び出しします
実際に使用する時は、エラートラップをし、メモリ解放をしっかりした方が良いと思います

Sub ボタン1_Click()
    Dim udtNetResource As tagNETRESOURCE
    Dim udtConnectDlg  As tagCONNECTDLGSTRUCT
    Dim lngReturn      As Long
    
    'リソースの詳細を設定
    With udtNetResource
        .dwType = RESOURCETYPE_DISK
    End With
    
    'ダイアログの詳細を設定
    With udtConnectDlg
        .cbStructure = LenB(udtConnectDlg)
        .hwndOwner = Application.Hwnd
        .lpConnRes = GlobalAlloc(GMEM_FIXED Or _
                                 GMEM_ZEROINIT, _
                                 LenB(udtNetResource))
                                 
        RtlMoveMemory ByVal .lpConnRes, _
                      udtNetResource, _
                      LenB(udtNetResource)
                      
        .dwFlags = CONNDLG_USE_MRU Or _
                   CONNDLG_HIDE_BOX Or _
                   CONNDLG_NOT_PERSIST
    End With
    
    'ダイアログ表示
    lngReturn = WNetConnectionDialog1(udtConnectDlg)
    Select Case lngReturn
        Case NO_ERROR
        
        Case &HFFFFFFFF
            MsgBox "[キャンセル]されました。"
        Case Else
            MsgBox "エラー(" & lngReturn & ")が発生しました。"
    End Select
    
    GlobalFree (udtConnectDlg.lpConnRes)
End Sub