Accessで使えるWindows API サンプル集1    (1999/09/25,2002/10/09 up)

Option Compare Database
Option Explicit

'Windowsディレクトリを取得
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

'WindowsTempPathを取得
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nSize As Long, ByVal lpBuffer As String) As Long

'WindowsSystemディレクトリを取得
Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

'解像度を取得
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Type RECT
    x1 As Long
    y1 As Long
    x2 As Long
    y2 As Long
End Type
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, Rectangle As RECT) As Long

'コンピュータ名取得
Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

'ユーザ名取得
Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

'音付きMsgBox
Declare Function MessageBeep Lib "user32" (ByVal wType As Integer) As Long
Private Const MB_ICONASTERISK = &H40& '情報
Private Const MB_ICONEXCLAMATION = &H30& '警告
Private Const MB_ICONHAND = &H10& 'システムエラー
Private Const MB_ICONQUESTION = &H20& '問い合わせ
Private Const MB_OK = &H0& '一般の警告

'WAVファイルを演奏
Public Declare Function apisndPlaySound Lib "WINMM" Alias "sndPlaySoundA" _
        (ByVal FileName As String, ByVal SND_ASYNC As Long) As Long

'ドライブタイプ取得
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long

'DiskSpaceとFreeSpaceを取得
Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" _
    (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, _
    lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long

'ネットワークドライブからリモートドライブパスを取得
Private Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" (ByVal lpszLocalName As String, ByVal lpszRemoteName As String, cbRemoteName As Long) As Long

'Windowsディレクトリを取得
Function LsGetWindowsDirectory() As String
    Dim Gwdvar As String, Gwdvar_Length As Long
    Gwdvar = Space(255)
    Gwdvar_Length = GetWindowsDirectory(lpBuffer:=Gwdvar, nSize:=255)
    '2002/10/09 Bug Fix
    'LsGetWindowsDirectory = Trim$(Left$(Gwdvar, Gwdvar_Length))
    LsGetWindowsDirectory = LsNullTrim(Gwdvar)
End Function

'WindowsTempPathを取得
Function LsGetTempPath() As String
    Dim Gwdvar As String, Gwdvar_Length As Long
    Gwdvar = Space(255)
    Gwdvar_Length = GetTempPath(nSize:=255, lpBuffer:=Gwdvar)
    '2002/10/09 Bug Fix
    'LsGetTempPath = Trim$(Left$(Gwdvar, Gwdvar_Length))
    LsGetTempPath = LsNullTrim(Gwdvar)
End Function

'WindowsSystemディレクトリを取得
Function LsGetSystemDirectory() As String
    Dim Gwdvar As String, Gwdvar_Length As Long
    Gwdvar = Space(255)
    Gwdvar_Length = GetSystemDirectory(lpBuffer:=Gwdvar, nSize:=255)
    '2002/10/09 Bug Fix
    'LsGetSystemDirectory = Trim$(Left$(Gwdvar, Gwdvar_Length))
    LsGetSystemDirectory = LsNullTrim(Gwdvar)
End Function

'解像度を取得
Function LsGetWindowRect() As String
    Dim R As RECT, hWnd As Long, RetVal As Long
    hWnd = GetDesktopWindow()
    RetVal = GetWindowRect(hWnd, R)
    LsGetWindowRect = (R.x2 - R.x1) & "x" & (R.y2 - R.y1)
End Function

'ドライブタイプ取得
Function LsGetDriveType(PathName As String) As String
    Dim w As String, m As String
    
    If PathName = "" Then Exit Function
    w = UCase(StrConv(Left$(PathName, 1), vbNarrow))
    If Len(w) > 1 Or Asc(w) < Asc("A") Or Asc("Z") < Asc(w) Then
        Exit Function
    Else
        Select Case GetDriveType(w & ":\")
        Case 2
            m = "フロッピー"
        Case 3
            m = "固定ディスク"
        Case 4
            m = "ネットワーク"
        Case 5
            m = "CD-ROM"
        Case 6
            m = "RAM Disk"
        Case Else
            Exit Function
        End Select
    End If
    LsGetDriveType = m
End Function

'音付きMsgBox
Function LsMsgBox(msg As String, buttons As Integer, Optional Title) As Integer
    Dim wType As Integer, dummy As Long
    
    Select Case (buttons Mod 256) - (buttons Mod 16)
    Case vbCritical
        wType = MB_ICONHAND
    Case vbQuestion
        wType = MB_ICONQUESTION
    Case vbExclamation
        wType = MB_ICONEXCLAMATION
    Case vbInformation
        wType = MB_ICONASTERISK
    Case Else
        wType = MB_OK
    End Select
    If wType > 0 Then dummy = MessageBeep(wType)
    If msg > "" Then
        If IsMissing(Title) Then
            If (buttons Mod 16) Then
                LsMsgBox = MsgBox(msg, buttons)
            Else
                MsgBox msg, buttons
            End If
        Else
            If (buttons Mod 16) Then
                LsMsgBox = MsgBox(msg, buttons, Title)
            Else
                MsgBox msg, buttons, Title
            End If
        End If
    End If
    Err.Clear
End Function

'コンピュータ名取得
Function LsGetComputerName() As String
    Dim lpBuffer As String, nSize As Long, rtn As Long
    nSize = 255
    lpBuffer = Space$(nSize)
    rtn = GetComputerName(lpBuffer, nSize)
    LsGetComputerName = LsNullTrim(lpBuffer)
End Function

'ユーザ名取得
Function LsGetUserName() As String
    Dim lpBuffer As String, nSize As Long, rtn As Long
    nSize = 255
    lpBuffer = Space$(nSize)
    rtn = GetUserName(lpBuffer, nSize)
    LsGetUserName = LsNullTrim(lpBuffer)
End Function

'Null文字以降を削除
Function LsNullTrim(strExp As String) As String
    Dim i As Integer
    i = InStr(strExp, vbNullChar)
    If i > 1 Then
        LsNullTrim = Left$(strExp, i - 1)
    Else
        LsNullTrim = strExp
    End If
End Function

'DiskSpaceとFreeSpaceを取得
Function LsGetDiskSpace(ByVal Drv As String, DiskFreeSpace As Double) As Double
    '２Gを以下のディスクに対応
    '２Gを超えるディスクの場合はサンプル集10を参照
    Dim SectorsPerCluster As Long, BytesPerSector As Long, NumberOfFreeClusters As Long
    Dim TtoalNumberOfClusters As Long, RtnCd As Long
    
    RtnCd = GetDiskFreeSpace(Drv & ":\", SectorsPerCluster, BytesPerSector, NumberOfFreeClusters, TtoalNumberOfClusters)
    If RtnCd = False Then Exit Function
    DiskFreeSpace = SectorsPerCluster * BytesPerSector * NumberOfFreeClusters
    LsGetDiskSpace = SectorsPerCluster * BytesPerSector * TtoalNumberOfClusters
End Function

'ネットワークドライブからリモートドライブパスを取得
'   ldrv ドライブ(x:)
'   ネットワークドライブの場合ネットワークドライブ名（\\xxxxx）をかえす。
Public Function Get_Remote_Path(ByVal ldrv As String) As String
    Dim stu As Long
    Dim rpath As String

    rpath = String$(5120, vbNullChar)
    ldrv = Left$(ldrv, 2)
    stu = WNetGetConnection(ldrv, rpath, 5120)
    Get_Remote_Path = LsNullTrim(rpath)
End Function

'-------------------------------------------------------
't_mizu@mail.goo.ne.jpさんからの投稿 1999/03/01
'-------------------------------------------------------
'=====================================================================
'   BrowseForFolder関連
'=====================================================================
Global Const CSIDL_DRIVES = 17
Type TBrowseInfo
    hwndOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type

Declare Function SHBrowseForFolder Lib "Shell32" (lpbi As TBrowseInfo) As Long
Declare Function SHGetPathFromIDList Lib "Shell32" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal spath As String) As Long

Public Function StrZToStr(s As String) As String
    StrZToStr = Left$(s, InStr(s, vbNullChar) - 1)
End Function

Public Function Browse_ForFolder(outSelectedFolder As String, _
                         Optional vRoot As Variant, _
                         Optional vOptions As Variant, _
                         Optional vTitle As Variant, _
                         Optional vDisplayName As Variant, _
                         Optional vOwner As Variant) As Long

    Dim bi As TBrowseInfo
    If Not IsMissing(vOwner) Then bi.hwndOwner = vOwner
    bi.pszDisplayName = String$(1024, 0)
    If IsMissing(vRoot) Then
        bi.pidlRoot = 0 'CSIDL_DRIVES
    Else
        bi.pidlRoot = vRoot
    End If
    If Not IsMissing(vTitle) Then bi.lpszTitle = vTitle
    If Not IsMissing(vOptions) Then bi.ulFlags = vOptions
    ' bi.lpfn = 0
    ' bi.lParam = 0
    ' bi.iImage
    Dim pidl As Long, spath As String
    pidl = SHBrowseForFolder(bi)
    'pidl = 0 の場合「キャンセル」が押された
    If Not IsMissing(vDisplayName) Then vDisplayName = StrZToStr(bi.pszDisplayName)
    spath = String$(5120, 0)
    SHGetPathFromIDList pidl, spath
    outSelectedFolder = StrZToStr(spath)
    Browse_ForFolder = pidl
End Function

'-------------------------------------------------------
't_mizu@mail.goo.ne.jpさんからの投稿 1999/03/01
'-------------------------------------------------------
Const OFN_READONLY = &H1
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_SHOWHELP = &H10
Const OFN_ENABLEHOOK = &H20
Const OFN_ENABLETEMPLATE = &H40
Const OFN_ENABLETEMPLATEHANDLE = &H80
Const OFN_NOVALIDATE = &H100
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_EXTENSIONDIFFERENT = &H400
Const OFN_PATHMUSTEXIST = &H800
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_CREATEPROMPT = &H2000
Const OFN_SHAREAWARE = &H4000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOTESTFILECREATE = &H10000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOLONGNAMES = &H40000                      '  force no long names for 4.x modules
Const OFN_EXPLORER = &H80000                         '  new look commdlg
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_LONGNAMES = &H200000                       '  force long names for 3.x modules

'「ファイルを開く」ダイアログ表示
Declare Function GetOpenFileName Lib "COMDLG32.DLL" Alias "GetOpenFileNameA" (pOpenfilename As OpenFileName) As Long
'「ファイルを開く」ダイアログ表示用構造体
Type OpenFileName
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        Flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
End Type

'「ファイルを開く」ダイアログを開いてファイル選択
'   引数
'       hWnd    : 表示元ウィンドウハンドル（指定なしの場合、0 を渡す）
'       Title   : ダイアログボックスのウィンドウタイトル
'       InitDir : 初期ディレクトリ
'   リターン値
'       =  "" : ファイル選択キャンセル
'       <> "" :選択されたファイル名（フルパス）
Public Function Select_OpenFileName(ByVal hWnd As Long, _
                                   Optional Title As Variant, _
                                   Optional InitDir As Variant, _
                                   Optional Exp As Variant) As String
    Dim OF As OpenFileName
    Dim tmp As String
    Dim stu As Long
    Dim filter As String

    tmp = String$(5120, vbNullChar)
    filter = "全て(*.*)" & vbNullChar & "*.*" & vbNullChar & vbNullChar
    If Not IsMissing(Exp) Then
        filter = Exp & filter
    End If
    With OF
        .lStructSize = Len(OF)                                                  '構造体長
        .hwndOwner = hWnd                                                       'Ownerハンドル
        .lpstrFile = tmp                                                        '戻り値バッファ
        .nMaxFile = 5120                                                        '戻り値バッファ長
        .lpstrFilter = filter
        .nFilterIndex = 1
        .Flags = OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY Or OFN_PATHMUSTEXIST
        If Not IsMissing(Title) Then .lpstrTitle = Title                        'ダイアログタイトル
        If Not IsMissing(InitDir) Then .lpstrInitialDir = InitDir               '初期ディレクトリ
    End With
    stu = GetOpenFileName(OF)
    If stu Then
        Select_OpenFileName = Left$(OF.lpstrFile, InStr(OF.lpstrFile, vbNullChar) - 1)
    End If
End Function


'----------------------------------
'WAVEサウンドを演奏する
'   正常終了=1
'   エラー  =0
'----------------------------------
Declare Function PlaySound Lib "WINMM" Alias "PlaySoundA" (ByVal pszSound As String, ByVal hmod As Long, ByVal fdwSound As Long) As Long

Public Const SND_ASYNC = &H1            '非同期で再生
Public Const SND_LOOP = &H8             '繰返し再生(中断する場合は、ﾌｧｲﾙ名に vbNullString を指定)
Public Const SND_NOSTOP = &H10          '他に再生中の場合は何もしない
Public Const SND_NOWAIT = &H2000        'サウンドドライバを使用中なら演奏しない
Public Const SND_SYNC = &H0             '演奏が終るまで戻らない

'----------------------------------------
'WAVEを再生できるサウンドカードのチェック
'   正常終了>0
'   エラー  =0
'----------------------------------------
Declare Function waveOutGetNumDevs Lib "WINMM" () As Long