VB中一些API的使用

Public Declare Sub Sleep()Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Declare Function GetTickCount()Function GetTickCount Lib "kernel32" () As Long

Private Declare Function OpenProcess()Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function WaitForSingleObject()Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function CloseHandle()Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetExitCodeProcess()Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function TerminateProcess()Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function GetForegroundWindow()Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function IsWindow()Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long

Public Sub Waitms()Sub Waitms(ms As Long)
    Dim t1 As Long
    Dim t2 As Long
    
    
    t1 = GetTickCount
    Do
        DoEvents
        Sleep 200
        t2 = GetTickCount
    Loop While t2 - t1 < ms
End Sub

Public Function ShellWait()Function ShellWait(cmd As String) As Long
    Const PROCESS_QUERY_INFORMATION = &H400
    Const STILL_ALIVE = &H103
    Const INFINITE = &HFFFF
    
    Dim ExitCode As Long
    Dim hProcess As Long
    Dim pid As Long
    
    pid = Shell(cmd, vbHide)
    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, 0, pid)
    
    Do
        Call GetExitCodeProcess(hProcess, ExitCode)
        DoEvents
        Loop While ExitCode = STILL_ALIVE
    Call CloseHandle(hProcess)
    
    ShellWait = ExitCode
End Function
 

 

 

'フォルダ設定用構造体
Public Type BROWSEINFO
    hOwner   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
'ファイルシステム利用できる
Public Const BIF_RETURNONLYFSDIRS = &H1
'Api関数
Public Declare Function SHGetPathFromIDList()Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Function SHBrowseForFolder()Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Dim bi     As BROWSEINFO
    bi.hOwner = Me.hWnd
    bi.pidlRoot = 0&
    bi.lpszTitle = "VHDLフォルダご指定ください"
    bi.ulFlags = BIF_RETURNONLYFSDIRS
    
    pidl = SHBrowseForFolder(bi)
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal pidl&, ByVal path)
    
    If r Then
        pos = InStr(path, Chr$(0))
        txtPath1.Text = Left(path, pos - 1)
    Else
        txtPath1.Text = ""
    End If