VB6弹出目录选择对话框代码,VB.Net代码库,德仔网

代码语言
代码分类
【VB.Net】 VB6弹出目录选择对话框
作者:DDT / 发布于2012/10/22/ 1092
VB6弹出目录选择对话框
<div>'=====================================================================================</div>
<div>' Browse for a Folder using SHBrowseForFolder API function with a callback</div>
<div>' function BrowseCallbackProc.</div>
<div>'</div>
<div>' This Extends the functionality that was given in the</div>
<div>' MSDN Knowledge Base article Q179497 "HOWTO: Select a Directory</div>
<div>' Without the Common Dialog Control".</div>
<div>'</div>
<div>' After reading the MSDN knowledge base article Q179378 "HOWTO: Browse for</div>
<div>' Folders from the Current Directory", I was able to figure out how to add</div>
<div>' a callback function that sets the starting directory and displays the</div>
<div>' currently selected path in the "Browse For Folder" dialog.</div>
<div>'</div>
<div>' I used VB 6.0 (SP3) to compile this code. Should work in VB 5.0.</div>
<div>' However, because it uses the AddressOf operator this code will not</div>
<div>' work with versions below 5.0.</div>
<div>'</div>
<div>' This code works in Window 95a so I assume it will work with later versions.</div>
<div>'</div>
<div>' Stephen Fonnesbeck</div>
<div>' steev@xmission.com</div>
<div>' http://www.xmission.com/~steev</div>
<div>' Feb 20, 2000</div>
<div>'</div>
<div>'=====================================================================================</div>
<div>' Usage:</div>
<div>'</div>
<div>'  Dim folder As String</div>
<div>'  folder = BrowseForFolder(Me, "Select A Directory", "C:\startdir\anywhere")</div>
<div>'  If Len(folder) = 0 Then Exit Sub 'User Selected Cancel</div>
<div>'</div>
<div>'=====================================================================================</div>
<div></div>
<div>Option Explicit</div>
<div>Dim getdir As String</div>
<div></div>
<div>Private Const BIF_STATUSTEXT = &H4&</div>
<div>Private Const BIF_RETURNONLYFSDIRS = 1</div>
<div>Private Const BIF_DONTGOBELOWDOMAIN = 2</div>
<div>Private Const MAX_PATH = 260</div>
<div></div>
<div>Private Const WM_USER = &H400</div>
<div>Private Const BFFM_INITIALIZED = 1</div>
<div>Private Const BFFM_SELCHANGED = 2</div>
<div>Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)</div>
<div>Private Const BFFM_SETSELECTION = (WM_USER + 102)</div>
<div></div>
<div>Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long</div>
<div>Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long</div>
<div>Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long</div>
<div>Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long</div>
<div></div>
<div>Private Type BrowseInfo</div>
<div> hWndOwner   As Long</div>
<div> pIDLRoot    As Long</div>
<div> pszDisplayName As Long</div>
<div> lpszTitle   As Long</div>
<div> ulFlags    As Long</div>
<div> lpfnCallback  As Long</div>
<div> lParam     As Long</div>
<div> iImage     As Long</div>
<div>End Type</div>
<div></div>
<div>Private m_CurrentDirectory As String  'The current directory</div>
<div>'</div>
<div></div>
<div>Public Function BrowseForFolder(owner As Form, Title As String, StartDir As String) As String</div>
<div> 'Opens a Treeview control that displays the directories in a computer</div>
<div></div>
<div> Dim lpIDList As Long</div>
<div> Dim szTitle As String</div>
<div> Dim sBuffer As String</div>
<div> Dim tBrowseInfo As BrowseInfo</div>
<div> m_CurrentDirectory = StartDir & vbNullChar</div>
<div></div>
<div> szTitle = Title</div>
<div> With tBrowseInfo</div>
<div>  .hWndOwner = owner.hWnd</div>
<div>  .lpszTitle = lstrcat(szTitle, "")</div>
<div>  .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN + BIF_STATUSTEXT</div>
<div>  .lpfnCallback = GetAddressofFunction(AddressOf BrowseCallbackProc) 'get address of function.</div>
<div> End With</div>
<div></div>
<div> lpIDList = SHBrowseForFolder(tBrowseInfo)</div>
<div> If (lpIDList) Then</div>
<div>  sBuffer = Space(MAX_PATH)</div>
<div>  SHGetPathFromIDList lpIDList, sBuffer</div>
<div>  sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)</div>
<div>  BrowseForFolder = sBuffer</div>
<div> Else</div>
<div>  BrowseForFolder = ""</div>
<div> End If</div>
<div></div>
<div>End Function</div>
<div></div>
<div>Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long</div>
<div></div>
<div> Dim lpIDList As Long</div>
<div> Dim ret As Long</div>
<div> Dim sBuffer As String</div>
<div></div>
<div> On Error Resume Next 'Sugested by MS to prevent an error from</div>
<div>            'propagating back into the calling process.</div>
<div>  </div>
<div> Select Case uMsg</div>
<div></div>
<div>  Case BFFM_INITIALIZED</div>
<div>   Call SendMessage(hWnd, BFFM_SETSELECTION, 1, m_CurrentDirectory)</div>
<div>  </div>
<div>  Case BFFM_SELCHANGED</div>
<div>   sBuffer = Space(MAX_PATH)</div>
<div>  </div>
<div>   ret = SHGetPathFromIDList(lp, sBuffer)</div>
<div>   If ret = 1 Then</div>
<div>    Call SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, sBuffer)</div>
<div>   End If</div>
<div>  </div>
<div> End Select</div>
<div></div>
<div> BrowseCallbackProc = 0</div>
<div></div>
<div>End Function</div>
<div></div>
<div>' This function allows you to assign a function pointer to a vaiable.</div>
<div>Private Function GetAddressofFunction(add As Long) As Long</div>
<div> GetAddressofFunction = add</div>
<div>End Function</div>
<div></div>
<div>  getdir = BrowseForFolder(Me, "Select A Directory", Text1.Text)</div>
<div>  If Len(getdir) = 0 Then Exit Sub 'user selected cancel</div>
<div>  Text1.Text = getdir</div>
<div></div>
试试其它关键字
　选择对话框　
同语言下
可能有用的
DDT贡献的其它代码(160)