既存のコントロールでは実現できない機能を盛り込む

●文字列関連API宣言の注意点

Declare Function GetPrivateProfileString _
         Lib "Kernel32" Alias "GetPrivateProfileStringA" _
         (ByVal lpApplicationName As String, _
          ByVal lpKeyName As Any, _
          ByVal lpDefault As String, _
          ByVal lpReturnedString As String, _
          ByVal lSize As Long, _
          ByVal lpFileName As String) As Long

●パラメータ宣言時の基本的注意点

●文字列を扱う時の注意点

Dim strFixBuf As String * 256

strBuf = String$(256,vbNullChar)

●構造体を扱う時の注意点

Private Type typPIP_OPT_INFO
  TTL As Byte               ' 生存時間
  TOS As Byte               ' ICMPタイプ
  Flags As Byte             ' フラグ
  Optsize As Byte           ' オプション長
  Options As String         ' オプション
End Type
Private Type typICMPEchoReply
  Address(1 To 4) As Byte   ' IPアドレス
  Status As Long            ' コード
  TripTime As Long          ' 応答時間（ms）
  DataSize As Integer       ' バッファサイズ
  Reserved As Integer       ' 予備
  ReplyData As String       ' レスポンス領域
  IPOptions As typPIP_OPT_INFO
End Type
Private Declare Function IcmpCreateFile _
                         Lib "ICMP.DLL" () As Long
Private Declare Function IcmpCloseHandle _
                         Lib "ICMP.DLL" _
                        (ByVal ICMPHandle As Long) As Integer
Private Declare Function IcmpSendEcho _
                         Lib "ICMP.DLL" _
                        (ByVal ICMPHandle As Long, _         ----《1》
                         ByVal DestinationAddress As Long, _ ----《2》
                         RequestData As String, _            ----《3》
                         ByVal RequestSize As Integer, _     ----《4》
                         RequestOption As typPIP_OPT_INFO, _ ----《5》
                         ReplyBuffer As Byte, _              ----《6》
                         ByVal ReplySize As Long, _          ----《7》
                         ByVal Timeout As Long) As Long      ----《8》
Private Declare Function IcmpGetLastError _
                         Lib "wsock32.dll" Alias "WSAGetLastError" _
                        () As Long
Private Const ICMP_FLAG_NO_FRAGMENT = 2 ' フラグメントなし
Private Const ICMP_ECHO_REQUEST = 8     ' エコー要求

Private Const WSAEINTR = 10004
Private Const WSAEACCES = 10013
Private Const WSAEFAULT = 10014
Private Const WSAEINVAL = 10022
Private Const WSAEMFILE = 10024
Private Const WSAEWOULDBLOCK = 10035
Private Const WSAEINPROGRESS = 10036
Private Const WSAEALREADY = 10037
Private Const WSAENOTSOCK = 10038
Private Const WSAEDESTADDRREQ = 10039
Private Const WSAEMSGSIZE = 10040
Private Const WSAEPROTOTYPE = 10041
Private Const WSAENOPROTOOPT = 10042
Private Const WSAEPROTONOSUPPORT = 10043
Private Const WSAESOCKTNOSUPPORT = 10044
Private Const WSAEOPNOTSUPP = 10045
Private Const WSAEPFNOSUPPORT = 10046
Private Const WSAEAFNOSUPPORT = 10047
Private Const WSAEADDRINUSE = 10048
Private Const WSAEADDRNOTAVAIL = 10049
Private Const WSAENETDOWN = 10050
Private Const WSAENETUNREACH = 10051
Private Const WSAENETRESET = 10052
Private Const WSAECONNABORTED = 10053
Private Const WSAECONNRESET = 10054
Private Const WSAENOBUFS = 10055
Private Const WSAEISCONN = 10056
Private Const WSAENOTCONN = 10057
Private Const WSAESHUTDOWN = 10058
Private Const WSAETOOMANYREFS = 10059
Private Const WSAETIMEDOUT = 10060
Private Const WSAECONNREFUSED = 10061
Private Const WSAEHOSTDOWN = 10064
Private Const WSAEHOSTUNREACH = 10065
Private Const WSAEPROCLIM = 10067

' Extended Windows Sockets error constant definitions
Private Const WSASYSNOTREADY = 10091
Private Const WSAVERNOTSUPPORTED = 10092
Private Const WSANOTINITIALISED = 10093
Private Const WSAHOST_NOT_FOUND = 11001
Private Const WSATRY_AGAIN = 11002
Private Const WSANO_RECOVERY = 11003
Private Const WSANO_DATA = 11004

Type typHostEnt
    h_name          As Long
    h_aliases       As Long
    h_addrtype      As Integer
    h_length        As Integer
    h_addr_list     As Long
End Type

Public Const INADDR_NONE = &HFFFF
Public Const INADDR_ANY = &H0

Public Const INVALID_SOCKET = -1
Public Const SOCKET_ERROR = -1
Public Const SOCK_STREAM = 1
Public Const SOCK_DGRAM = 2
Public Const AF_INET = 2
Public Const PF_INET = 2

Public Const WSA_DESCRIPTIONLEN = 256
Public Const WSA_DescriptionSize = WSA_DESCRIPTIONLEN + 1
Public Const WSA_SYS_STATUS_LEN = 128
Public Const WSA_SysStatusSize = WSA_SYS_STATUS_LEN + 1
Type typWSADataType
    wVersion       As Integer
    wHighVersion   As Integer
    szDescription  As String * WSA_DescriptionSize
    szSystemStatus As String * WSA_SysStatusSize
    iMaxSockets    As Integer
    iMaxUdpDg      As Integer
    lpVendorInfo   As Long
End Type
' アドレス変換
Public Declare Function inet_addr _
                        Lib "wsock32.dll" _
                       (ByVal cp As String) As Long
Public Declare Function inet_ntoa _
                        Lib "wsock32.dll" _
                       (ByVal lngIn As Long) As Long
' データベース関数
Public Declare Function gethostbyaddr _
                        Lib "wsock32.dll" _
                       (addr As Long, _
                        ByVal lngLen As Long, _
                        ByVal lngType As Long) As Long
Public Declare Function gethostbyname _
                        Lib "wsock32.dll" _
                       (ByVal strName As String) As Long
Public Declare Function gethostname _
                        Lib "wsock32.dll" _
                       (ByVal strName As String, _
                        ByVal namelen As Long) As Long
Public Declare Function getprotobyname _
                        Lib "wsock32.dll" _
                       (ByVal strName As String) As Long
Public Declare Function getprotobynumber _
                        Lib "wsock32.dll" _
                       (ByVal lngNumber As Long) As Long
Public Declare Function getservbyname _
                        Lib "wsock32.dll" _
                       (ByVal strName As String, _
                        ByVal proto As String) As Long
Public Declare Function getservbyport _
                        Lib "wsock32.dll" _
                       (ByVal Port As Long, _
                        ByVal proto As String) As Long
Public Declare Function getsockopt _
                        Lib "wsock32.dll" _
                       (ByVal s As Long, _
                        ByVal level As Long, _
                        ByVal optname As Long, _
                        optval As Any, _
                        optlen As Long) As Long
' 拡張機能
Public Declare Function WSAStartup _
                        Lib "wsock32.dll" _
                       (ByVal wVersionRequested As Long, _
                        lpWSAData As typWSADataType) As Long
Public Declare Function WSACleanup _
                        Lib "wsock32.dll" () As Long
Public Declare Function WSAGetLastError _
                        Lib "wsock32.dll" () As Long

Public Declare Sub MemCopy _
                   Lib "Kernel32" Alias "RtlMoveMemory" _
                  (hpvDest As Any, _
                   hpvSource As Any, _
                   ByVal cbCopy As Long)
Public Declare Function lstrlen _
                        Lib "Kernel32" Alias "lstrlenA" _
                       (lpString As Any) As Long

Public Function plngGetHostByNameAlias( _
       ByVal strHostName As String) As Long
  Dim lngRet      As Long
  Dim heDestHost  As typHostEnt
  Dim lngAddr     As Long
  Dim lngIP       As Long

  lngIP = inet_addr(strHostName)
  If lngIP = INADDR_NONE Then
    lngRet = gethostbyname(strHostName)
    If lngRet <> 0 Then
      MemCopy heDestHost, ByVal lngRet, Len(heDestHost)
      MemCopy lngAddr, ByVal heDestHost.h_addr_list, 4
      MemCopy lngIP, ByVal lngAddr, heDestHost.h_length
    Else
      lngIP = INADDR_NONE
    End If
  End If
  plngGetHostByNameAlias = lngIP
End Function

Private Sub cmdPing_Click()
  Dim lngAddr            As Long             ' Internetアドレス
  Dim usrICMP            As typPIP_OPT_INFO  ' ICMP情報領域
  Dim usrICMPER          As typICMPEchoReply ' ICMP返却領域
  Dim bytRes(1 To 4096)  As Byte             ' ICMPレスポンス領域
  Dim strName            As String           ' ターゲット名
  Dim lngRet             As Long             ' 戻り値
  Dim iintLoop           As Integer          ' PINGカウンタ
  Dim strErrText         As String           ' エラーテキスト

  On Error GoTo errClick:

  Me.MousePointer = vbHourglass
  Me.Refresh

  strName = txtIP.Text
  lngAddr = plngGetHostByNameAlias(strName)       ----《1》

  lstResult.Clear

  For iintLoop = 1 To 4
    usrICMP.TTL = CByte("128")                    ----《2》-1
    usrICMP.TOS = ICMP_ECHO_REQUEST               ----《2》-2
    usrICMP.Options = ""                          ----《2》-3
    usrICMP.Optsize = Len(usrICMP.Options)        ----《2》-4
    usrICMP.Flags = ICMP_FLAG_NO_FRAGMENT         ----《2》-5

    lngRet = IcmpSendEcho(mlngICMP, _             ----《3》
                          lngAddr, _
                          Space$(32), _
                          32, _
                          usrICMP, _
                          bytRes(1), _
                          UBound(bytRes), _
                          10&)
      If lngRet = 0 Then
        lstResult.AddItem "ICMP_Error" & ":" & CStr(WSAGetLastError())
      Else
        MemCopy usrICMPER.Address(1), bytRes(1), LenB(usrICMPER)　　…《4》
        lstResult.AddItem "Reply From " & _                         …《5》
                           CStr(usrICMPER.Address(1)) & "." & _
                           CStr(usrICMPER.Address(2)) & "." & _
                           CStr(usrICMPER.Address(3)) & "." & _
                           CStr(usrICMPER.Address(4)) & _
                          ": bytes=32 " & _
                          "time=" & CStr(usrICMPER.TripTime) & "ms " & _
                          "TTL=" & usrICMP.TTL
      End If
  Next

exitClick:
  On Error Resume Next
  Me.MousePointer = vbDefault
  Me.Refresh
  Exit Sub

errClick:
  strErrText = pstrWSAErrorGet(WSAGetLastError())
  If strErrText <> "" Then
    strErrText = Error$
  End If
  MsgBox strErrText, vbOKOnly + vbExclamation, App.Title
  Resume exitClick:
End Sub

《1》：IPアドレスやホスト名をInternetアドレスに変換
《2》：オプションを指定
《2》-1：TTLとして128を指定（設定画面を作って任意の値を指定できるようにしてもよいだろう）
《2》-2：ICMPエコー要求の送信を指定
《2》-3：オプションなしを指定
《2》-4：オプションのサイズを指定
《2》-5：フラグメントなしを指定
《3》：IcmpSendEcho APIを呼び出す
《4》：ICMPエコー応答からInternetアドレスを取得
《5》：InternetアドレスをIPアドレスに変換しながら結果を表示

If lngAddr <> INADDR_NONE Then
  For iintLoop = 1 To 255
    ' TTLを1づつ増加させてルートを特定する
    usrICMP.TTL = CByte(iintLoop)
    usrICMP.TOS = ICMP_ECHO_REQUEST
    usrICMP.Options = ""
    usrICMP.Optsize = Len(usrICMP.Options)
    usrICMP.Flags = ICMP_FLAG_NO_FRAGMENT

                 :
         (リスト4と同等なので省略)
                 :

    If iintCnt > 4 Then
      lstResult.AddItem txtIP.Text & " Time out"
      Exit For
    Else
      If lngAddr = plngGetHostByNameAlias(strName) Then
        ' ターゲットに到達
        lstResult.AddItem txtIP.Text & _
               " [" & strName & "] " & _
               "Trace Complete."
        Exit For
      End If
    End If
  Next
Else
        lstResult.AddItem "Unable to resolve target system name " & txtIP.Text
    End If

Private Declare Function GetUserName _
        Lib "advapi32" Alias "GetUserNameA" _
       (ByVal lpBuffer As String, _
        nSize As Long) As Long

                :

  Dim strUsrId  As String * 1024  ' ユーザーIDの取得バッファ
  Dim lngRet    As Long           ' APIの戻り値

                :

  lngRet = GetUserName(strUsrId, Len(strUsrId))
  txtGetUserName.Text = Left$(strUsrId, _
                        InStr(strUsrId, vbNullChar) - 1)

Private Declare Function WNetGetUser _
        Lib "mpr" Alias "WNetGetUserA" _
       (ByVal lpName As String, _
        ByVal lpUserName As String, _
        lpnLength As Long) As Long
               ：
            （中略）
               ：
  Dim strUsrId   As String * 1024  ' ユーザーIDの取得バッファ
  Dim lngRet     As Long           ' APIの戻り値
  Dim strNetWork As String
               ：
            （中略）
               ：
  strNetWork = vbNullChar
  lngRet = WNetGetUser(strNetWork, _
                       strUsrId, Len(strUsrId))
  txtWNetGetUser.Text = Left$(strUsrId, _
                        InStr(strUsrId, vbNullChar) - 1)

Private Declare Function WNetConnectionDialog _
        Lib "mpr" _
       (ByVal hWnd As Long, _
        ByVal dwType As Long) As Long
Private Const RESURCETYPE_DISK = &H1
               ：
            （中略）
               ：
Private Sub cmdNetDrv_Click()
  Dim lngRet  As Long

  lngRet = WNetConnectionDialog(Me.hWnd, _
                                RESURCETYPE_DISK)
  If lngRet = 0 Then
  ' 正常終了
    drvList.Refresh
  End If
End Sub

Private Declare Function WNetDisconnectDialog _
        Lib "mpr" _
       (ByVal hWnd As Long, _
        ByVal dwType As Long) As Long
Private Const RESURCETYPE_DISK = &H1
              ：
           （中略）
              ：
Private Sub cmdDisc_Click()
  Dim lngRet  As Long

  lngRet = WNetDisconnectDialog(Me.hWnd, _
                                RESURCETYPE_DISK)
  If lngRet = 0 Then
  ' 正常終了
    drvList.Refresh
  End If
End Sub

Private Declare Function WNetAddConnection _
        Lib "mpr" Alias "WNetAddConnectionA" _
       (ByVal lpRemoteName As String, _
        ByVal lpPassword As String, _
        ByVal lpLocalName As String) As Long
                ：
             （中略）
                ：
Private Sub cmdAdd_Click()
  Dim strShare        As String   ' 共有フォルダ名
  Dim strPass         As String   ' パスワード
  Dim strDrive        As String   ' ドライブ名
  Dim lngRet          As Long

  On Error GoTo errClick:

  strShare = Trim$(txtUNC.Text) & vbNullChar
  strPass = "" & vbNullChar
  strDrive = UCase(Trim$(txtDrive.Text)) & ":" & vbNullChar
  lngRet = WNetAddConnection(strShare, strPass, strDrive)
  If lngRet = 0 Then
  ' 正常終了
    drvList.Refresh
  Else
    MsgBox pstrLastDllErrorText(Err.LastDllError), _
     vbOKOnly + vbExclamation, App.Title
  End If

exitClick:
  On Error Resume Next
  Exit Sub

errClick:
  MsgBox Error$, vbOKOnly + vbExclamation, App.Title
  Resume exitClick:
End Sub

Private Declare Function WNetCancelConnection _
        Lib "mpr" Alias "WNetCancelConnectionA" _
       (ByVal lpName As String, _
        ByVal fForce As Long) As Long
               ：
            （中略）
               ：
Private Sub cmdCancel_Click()
  Dim strDrive   As String   ' ドライブ名
  Dim lngRet     As Long

  On Error GoTo errClick:

  strDrive = UCase(Trim$(txtDrive.Text)) & ":" & vbNullChar
  lngRet = WNetCancelConnection(strDrive, 0)
  If lngRet = 0 Then
  ' 正常終了
    drvList.Refresh
  End If

exitClick:
  On Error Resume Next
  Exit Sub

errClick:
  MsgBox Error$, vbOKOnly + vbExclamation, App.Title
  Resume exitClick:
End Sub

Private Type typNETRESOURCE
  dwScope         As Long
  dwType          As Long     ' 共有資源のタイプ
  dwDisplayName   As Long
  dwUsage         As Long
  lpLocalName     As String   ' ドライブ名
  lpRemoteName    As String   ' UNC名
  lpComment       As String
  lpProvider      As String
End Type
Private Declare Function WNetAddConnection3 _
        Lib "mpr" Alias "WNetAddConnection3A" _
       (ByVal hWnd As Long, _
        lpNetResource As typNETRESOURCE, _
        ByVal lpPassword As String, _
        ByVal lpUserName As String, _
        ByVal dwFlags As Long) As Long
' dwTypeの設定値
Private Const RESURCETYPE_ANY = &H0
Private Const RESURCETYPE_DISK = &H1
Private Const RESURCETYPE_PRINT = &H2
             ：
          （中略）
             ：
Private Sub cmdAdd_Click()
  Dim lngRet          As Long
  Dim strUser         As String
  Dim strPass         As String
  Dim usrNetResource  As typNETRESOURCE

  On Error GoTo errClick:
  usrNetResource.dwType = RESURCETYPE_DISK
  usrNetResource.lpLocalName = UCase(Trim$(txtDrive.Text)) & _
                              ":" & vbNullChar
  usrNetResource.lpRemoteName = Trim$(txtUNC.Text) & vbNullChar
  usrNetResource.lpProvider = vbNullString
  strUser = Trim$(txtUser.Text) & vbNullChar
  strPass = Trim$(txtPass.Text) & vbNullChar
  lngRet = WNetAddConnection3(Me.hWnd, _
                              usrNetResource, _
                              strPass, _
                              strUser, _
                              0)
  If lngRet = 0 Then
  ' 正常終了
    drvList.Refresh
  End If

exitClick:
  On Error Resume Next
  Exit Sub

errClick:
  MsgBox Error$, vbOKOnly + vbExclamation, App.Title
  Resume exitClick:
End Sub

Private Declare Function SHBrowseForFolder _
        Lib "shell32.dll" Alias "SHBrowseForFolderA" _
       (lpbi As typBROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList _
        Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
       (ByVal pidl As Long, _
        ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)

' フォルダ参照のダイアログ用構造体
Private Type typBROWSEINFO
  hWndOwner As Long         ' Handle
  pidlRoot As Long          ' Address
  pszDisplayName As String  ' Address
  lpszTitle As String       ' null-terminated string
  ulFlag As Long
  lpfn As Long              ' デフォルトフォルダ指定用CallBack関数のAddress
  lParam As Long            ' オプション
  iImage As Long
End Type

' BROWSEINFO.pidlRoot定数
' Locating the Standard Folders Where Data Belongs (MSDN)

' スタートアップ（All Users）
Private Const CSIDL_COMMON_ALTSTARTUP = &H1E
               ：
            （中略）
               ：
Private Const CSIDL_TEMPLATES = &H15  ' テンプレート

' BROWSEINFO.ulFlag定数
' ネットワークコンピュータの一覧選択
Private Const BIF_BROWSEFORCOMPUTER = &H1000  
' ネットワークプリンタの一覧選択
Private Const BIF_BROWSEFORPRINTER = &H2000   
' ネットワーク共有リソースの一覧選択
Private Const BIF_BROWSEINCLUDEFILES = &H4000 
' ネットワーク関連を除いて表示
Private Const BIF_DONTGOBELOWDOMAIN = &H2     
' 共有フォルダ表示とネットワークコンピュータの選択
Private Const BIF_RETURNFSANCESTORS = &H8     
' 共有フォルダ一覧選択
Private Const BIF_RETURNONLYFSDIRS = &H1      
Private Sub cmdFolder_Click()

  Dim usrBROWSEINFO As typBROWSEINFO
  Dim lngFolder As Long
  Dim strPath As String

  With usrBROWSEINFO
  ' 親ウィンドウを指定
    .hWndOwner = Me.hWnd
  ' ルートを指定
    strPath = cboRoot.Text
    strPath = Left$(strPath, InStr(strPath, ":") - 1)
    .pidlRoot = CLng(strPath)
  ' タイトル設定
    .lpszTitle = "フォルダを指定してください。"
  ' オプションを表示する
    .ulFlag = 0
    If chkOPt(0).Value = "1" Then
      .ulFlag = .ulFlag Or BIF_BROWSEFORCOMPUTER
    End If
    If chkOPt(1).Value = "1" Then
      .ulFlag = .ulFlag Or BIF_BROWSEFORPRINTER
    End If
    If chkOPt(2).Value = "1" Then
      .ulFlag = .ulFlag Or BIF_BROWSEINCLUDEFILES
    End If
    If chkOPt(3).Value = "1" Then
      .ulFlag = .ulFlag Or BIF_DONTGOBELOWDOMAIN
    End If
    If chkOPt(4).Value = "1" Then
      .ulFlag = .ulFlag Or BIF_RETURNFSANCESTORS
    End If
    If chkOPt(5).Value = "1" Then
      .ulFlag = .ulFlag Or BIF_RETURNONLYFSDIRS
    End If

      strPath = String$(256, vbNullChar)
      .pszDisplayName = strPath
  End With

' 「フォルダの参照」ダイアログを呼び出す
  lngFolder = SHBrowseForFolder(usrBROWSEINFO)

' ダイアログで得られた値からフォルダのパスを取得
  Call SHGetPathFromIDList(lngFolder, strPath)

' 割り当てられたメモリを解放
  CoTaskMemFree lngFolder

' 選択した情報を取得する
  If Left$(strPath, 1) = vbNullChar Then
  ' 表示名
    strPath = Left$(usrBROWSEINFO.pszDisplayName, _
              InStr(usrBROWSEINFO.pszDisplayName, _
                    vbNullChar) - 1)
  End If
  txtFolder.Text = strPath
End Sub
Private Sub Form_Load()
  cboRoot.AddItem "&H00:デスクトップ"
               ：
            （中略）
               ：
  cboRoot.AddItem "&H15:テンプレート"

  cboRoot.ListIndex = 0
End Sub

  .lpfn = lngAddr(AddressOf plngCallback)
  abytPath() = StrConv(strInitPath & vbNullChar, _
                       vbFromUnicode)
  .lParam = VarPtr(abytPath(0))
                ：
             （中略）
                ：
Private Function lngAddr(ByRef rlngAddr) As Long
  lngAddr = rlngAddr
End Function

Private Declare Function SendMessage _
        Lib "user32" Alias "SendMessageA" _
       (ByVal hWnd As Long, _
        ByVal wMsg As Long, _
        ByVal wParam As Long, _
        lParam As Any) As Long
Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SETSELECTION = (WM_USER + 102)
Public Function plngCallback(ByVal hWnd As Long, _
                             ByVal uMsg As Long, _
                             ByVal wParam As Long, _
                             ByVal lParam As Long) As Long
  Dim lngRet      As Long
    
  Debug.Print Hex(uMsg), Hex(wParam), Hex(lParam)
  If uMsg = BFFM_INITIALIZED Then
    lngRet = SendMessage(hWnd, _
                         BFFM_SETSELECTION, _
                         -1&, _
                         ByVal lParam)
  End If
End Function

Private Declare Function ModifyMenu _
        Lib "user32" Alias "ModifyMenuA" _
       (ByVal hMenu As Long, _
        ByVal nPosition As Long, _
        ByVal wFlags As Long, _
        wlDNewItem As Long, _
        ByVal lpString As String) As Long
Private Declare Function GetMenu _
        Lib "user32" _
       (ByVal hWnd As Long) As Long
Private Declare Function GetSubMenu _
        Lib "user32" _
       (ByVal hMenu As Long, _
        ByVal nPos As Long) As Long
Private Const MF_MENUBARBREAK = &H20&
Private Const MF_BYPOSITION = &H400&
                ：
             （中略）
                ：
' 折り返しのAPI
  For ilngLoop = 27 To 100 Step 28
    lngRet = ModifyMenu(GetSubMenu(GetMenu(Me.hWnd), 1), _
                        ilngLoop, _
                        MF_MENUBARBREAK Or MF_BYPOSITION, _
                        ilngLoop, _
                        mnuAPILst(ilngLoop).Caption)
  Next

Private Declare Function FormatMessage _
        Lib "kernel32" Alias "FormatMessageA" _
       (ByVal dwFlags As Long, _
        lpSource As Any, _
        ByVal dwMessageId As Long, _
        ByVal dwLanguageId As Long, _
        ByVal lpBuffer As String, _
        ByVal nSize As Long, _
        ByVal Argument As Long) As Long

' Argumentを使わないことを指定
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
' GetLastErrorに対応するメッセージを取得
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
' デフォルト言語を指定
Private Const PROCESS_DEFAULT_LANGUAGE = &H400

Public Function pstrLastDllErrorText( _
       ByVal vlngDllError As Long) As String
  Dim strBuffer  As String * 1024
  Dim lngRet     As Long
  Dim lngFlg     As Long

  lngFlg = FORMAT_MESSAGE_FROM_SYSTEM Or _
           FORMAT_MESSAGE_IGNORE_INSERTS
  lngRet = FormatMessage(lngFlg, _
                         ByVal vbNullString, _
                         vlngDllError, _
                         PROCESS_DEFAULT_LANGUAGE, _
                         strBuffer, _
                         Len(strBuffer), _
                         0)
  pstrLastDllErrorText = Left$(strBuffer, _
                         InStr(strBuffer, _
                         vbNullChar) - 1)
End Function