Наши проекты:
Журнал · Discuz!ML · Wiki · DRKB · Помощь проекту |
||
ПРАВИЛА | FAQ | Помощь | Поиск | Участники | Календарь | Избранное | RSS |
[18.118.184.237] |
|
Сообщ.
#1
,
|
|
|
Option Explicit Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BROWSEINFO) As Long Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long Private Declare Function SendMessageA Lib "user32.dll" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long Const WM_CREATE As Long = 1 Private Type BROWSEINFO hwndOwner As Long pIDLRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfnCallback As Long lParam As Long iImage As Long End Type Public Function GetFolder(ByVal hWnd As Long, ByVal sTitle As String, ByVal sCaption As String) As String Dim lpIDList As Long Dim sBuffer As String Dim szTitle As String Dim tBrowseInfo As BROWSEINFO With tBrowseInfo .hwndOwner = hWnd ' Parent window .lpszTitle = sTitle ' Title of folders list .pszDisplayName = App.Title .lpfnCallback = Val(AddressOf BrowseFolderCallback) ' Pointer to callback procedure sCaption = StrConv(sCaption, vbFromUnicode) ' Convert string .lParam = StrPtr(sCaption) ' Pass the caption through lParam End With lpIDList = SHBrowseForFolder(tBrowseInfo) If (lpIDList) Then sBuffer = String(260, 0) SHGetPathFromIDList lpIDList, sBuffer If InStr(sBuffer, vbNullChar) <> 0 Then sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1) GetFolder = sBuffer End If End Function Private Function BrowseFolderCallback(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Select Case uMsg Case WM_CREATE SendMessageA hWnd, 12, 0, lParam ' Sets our caption (pointer in lParam) to dialogbox End Select BrowseFolderCallback = 0 End Function |