basselectlocaldir.bas

Shape 坐标转换程序 Shape 坐标转换程序

Attribute VB_Name = "basSelectLocalDir"
Option Explicit

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 Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Public Const MAX_PATH = 260
Public Const WM_USER = &H400
Public Const BFFM_INITIALIZED = 1
'Constants ending in 'A' are for Win95 ANSI
'calls; those ending in 'W' are the wide Unicode
'calls for NT.
'Sets the status text to the null-terminated
'string specified by the lParam parameter.
'wParam is ignored and should be set to 0.
'wParam is ignored and should be set to 0.
Public Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Public Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)
'If the lParam  parameter is non-zero, enables the
'OK button, or disables it if lParam is zero.
'(docs erroneously said wParam!)
'wParam is ignored and should be set to 0.
Public Const BFFM_ENABLEOK As Long = (WM_USER + 101)
'Selects the specified folder. If the wParam
'parameter is FALSE, the lParam parameter is the
'PIDL of the folder to select , or it is the path
'of the folder if wParam is the C value TRUE (or 1).
'Note that after this message is sent, the browse
'dialog receives a subsequent BFFM_SELECTIONCHANGED
'message.
Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
'specific to the PIDL method
'Undocumented call for the example. IShellFolder's
'ParseDisplayName member function should be used instead.
Public Declare Function SHSimpleIDListFromPath Lib "shell32" Alias "#162" (ByVal szPath As String) As Long

'specific to the STRING method
Public Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Public Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function lstrcpyA Lib "kernel32" (lpString1 As Any, lpString2 As Any) As Long
Public Declare Function lstrlenA Lib "kernel32" (lpString As Any) As Long
Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)
Public Function BrowseCallbackProcStr(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
  'Callback for the Browse STRING method.
  'On initialization, set the dialog's
  'pre-selected folder from the pointer
  'to the path allocated as bi.lParam,
  'passed back to the callback as lpData param.
  'passed back to the callback as lpData param.
   Select Case uMsg
      Case BFFM_INITIALIZED
         Call SendMessage(hWnd, BFFM_SETSELECTIONA, True, ByVal StrFromPtrA(lpData))
         Case Else:
   End Select
End Function
Public Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
  'Callback for the Browse PIDL method.
  'On initialization, set the dialog's
  'pre-selected folder using the pidl
  'set as the bi.lParam, and passed back
  'to the callback as lpData param.
   Select Case uMsg
      Case BFFM_INITIALIZED
         Call SendMessage(hWnd, BFFM_SETSELECTIONA, _
                          False, ByVal lpData)
         Case Else:
   End Select
End Function
Public Function FARPROC(pfn As Long) As Long
  'A dummy procedure that receives and returns
  'the value of the AddressOf operator.
  'Obtain and set the address of the callback
  'This workaround is needed as you can't assign
  'AddressOf directly to a member of a user-
  'defined type, but you can assign it to another
  'long and use that (as returned here)
  FARPROC = pfn
End Function
Public Function StrFromPtrA(lpszA As Long) As String
  'Returns an ANSII string from a pointer to an ANSII string.
   Dim sRtn As String
   sRtn = String$(lstrlenA(ByVal lpszA), 0)
   Call lstrcpyA(ByVal sRtn, ByVal lpszA)
   StrFromPtrA = sRtn
End Function
'--end block--'
' Form Code
'Add the following code to the form:
'----------------------------------------------------------------------------
'
'----
'Option Explicit
'Private Sub cmdString_Click()
'   Text2 = ""
'   Text2 = BrowseForFolderByPath((Text1))
'End Sub
'Private Sub cmdPIDL_Click()
'   Text2 = ""
'   Text2 = BrowseForFolderByPIDL((Text1))
'End Sub
'Private Sub cmdEnd_Click()
'   Unload Me
'End Sub
Public Function BrowseForFolderByPath(sSelPath As String) As String
  Dim BI As BROWSEINFO
  Dim pidl As Long
  Dim lpSelPath As Long
  Dim sPath As String * MAX_PATH
  With BI
    .hOwner = 0 'Me.hWnd
    .pidlRoot = 0
    .lpszTitle = "Pre-selecting the folder using the folder's string."
    .lpfn = FARPROC(AddressOf BrowseCallbackProcStr)
    lpSelPath = LocalAlloc(LPTR, Len(sSelPath))
    MoveMemory ByVal lpSelPath, ByVal sSelPath, Len(sSelPath)
    .lParam = lpSelPath
    End With
   pidl = SHBrowseForFolder(BI)
   If pidl Then
      If SHGetPathFromIDList(pidl, sPath) Then
         BrowseForFolderByPath = Left$(sPath, InStr(sPath, vbNullChar) - 1)
      End If
      Call CoTaskMemFree(pidl)
   End If
  Call LocalFree(lpSelPath)
End Function
Public Function BrowseForFolderByPIDL(sSelPath As String) As String
   Dim BI As BROWSEINFO
   Dim pidl As Long
   Dim sPath As String * MAX_PATH
   With BI
      .hOwner = 0 'Me.hWnd
      .pidlRoot = 0
      .lpszTitle = "Pre-selecting a folder using the folder's pidl."

      .lpfn = FARPROC(AddressOf BrowseCallbackProc)
      .lParam = SHSimpleIDListFromPath(sSelPath)
   End With
   pidl = SHBrowseForFolder(BI)
   If pidl Then
      If SHGetPathFromIDList(pidl, sPath) Then
         BrowseForFolderByPIDL = Left$(sPath, InStr(sPath, vbNullChar) - 1)
      End If
      Call CoTaskMemFree(pidl)
  End If
  Call CoTaskMemFree(BI.lParam)
End Function
'--end block--'
' Comments
'Save then run the project. Change the path in Text1 to a suitable path on yo
'ur system, and press either of the two Browse command buttons. The Browse di
'alog should appear with the path you indicated selected.
'For an explanation of the members and calls made in the two functions above,
' the following is the original commented code.
'----------------------------------------------------------------------------
'----
'Public Function BrowseForFolderByPIDL(sSelPath As String) As String
'   Dim BI As BROWSEINFO
'   Dim pidl As Long
'   Dim sPath As String * MAX_PATH
'   With BI
'      'ownner of the dialog. Pass 0 for the desktop.
'      .hOwner = Me.hWnd
'      'The desktop folder will be the dialog's
'      'root folder. SHSimpleIDListFromPath return
'      'values can also be used to set this. This
'      'member determines the 'root' point of the
'      'Browse display.
'      .pidlRoot = 0
'      'Set the dialog's prompt string, if desired
'      .lpszTitle = "Pre-selecting a folder using the folder's pidl."
'      'Obtain and set the address of the callback
'      'function. We need this workaround as you can't
'      'assign the AddressOf directly to a member of
'      'a user-defined type, but you can set assign it
'      'to another long and use that (as returned in
'      'the FARPROC call!!)
'      .lpfn = FARPROC(AddressOf BrowseCallbackProc)
'      'Obtain and set the pidl of the pre-selected folder
'
'      .lParam = SHSimpleIDListFromPath(sSelPath)
'   End With
'  'Shows the browse dialog and doesn't return until the
'  'dialog is closed. The BrowseCallbackProc below will
'  'receive all browse dialog specific messages while
'  'the dialog is open. pidl will contain the pidl of
'  'the selected folder if the dialog is not cancelled.
'   pidl = SHBrowseForFolder(BI)
'  If pidl Then
'     'Get the path from the selected folder's pidl returned
'     'from the SHBrowseForFolder call. Returns True on success.
'     'Note: sPath must be pre-allocated!)
'      If SHGetPathFromIDList(pidl, sPath) Then
'        'Return the path
'         BrowseForFolderByPIDL = Left$(sPath, InStr(sPath, vbNullChar) - 1)
'      End If
'     'Free the memory the shell allocated for the pidl.
'      Call CoTaskMemFree(pidl)
'  End If
' 'Free the memory the shell allocated for
' 'the pre-selected folder.
'  Call CoTaskMemFree(BI.lParam)
'  Call CoTaskMemFree(BI.lParam)
'End Function
Public Function BrowseForFolder(hWndOwner As Long, sPrompt As String, sSelPath As String) As String
  Dim BI As BROWSEINFO
  Dim pidl As Long
  Dim lpSelPath As Long
  Dim sPath As String * MAX_PATH
  With BI
   'ownner of the dialog. Pass 0 for the desktop.
      .hOwner = hWndOwner
      .lpszTitle = sPrompt 'lstrcat(sPrompt, "")
   'The desktop folder will be the dialog's root folder.
   'SHSimpleIDListFromPath can also be used to set this value.
    .pidlRoot = 0
   'Set the dialog's prompt string
   'Obtain and set the address of the callback function
    .lpfn = FARPROC(AddressOf BrowseCallbackProcStr)
   'Now the fun part. Allocate some memory for the dialog's
   'selected folder path (sSelPath), blast the string into
   'the allocated memory, and set the value of the returned
   'pointer to lParam (checking LocalAlloc's success is
   'omitted for brevity). Note: VB's StrPtr function won't
   'work here because a variable's memory address goes out

   'of scope when passed to SHBrowseForFolder.
    lpSelPath = LocalAlloc(LPTR, LenB(sSelPath))
    MoveMemory ByVal lpSelPath, ByVal sSelPath, LenB(sSelPath)
    .lParam = lpSelPath
    End With
  'Shows the browse dialog and doesn't return until the
  'dialog is closed. The BrowseCallbackProcStr will
  'receive all browse dialog specific messages while
  'the dialog is open. pidl will contain the pidl of the
  'selected folder if the dialog is not canceled.
   pidl = SHBrowseForFolder(BI)
   If pidl Then
     'Get the path from the selected folder's pidl returned
     'from the SHBrowseForFolder call (rtns True on success,
     'sPath must be pre-allocated!)
      If SHGetPathFromIDList(pidl, sPath) Then
        'Return the path
         BrowseForFolder = Left$(sPath, InStr(sPath, vbNullChar) - 1)
      End If
     'Free the memory the shell allocated for the pidl.
      Call CoTaskMemFree(pidl)
   End If
  'Free our allocated string pointer
   Call LocalFree(lpSelPath)
End Function