clsbrowsing.cls

来自「教学资源管理系统」· CLS 代码 · 共 72 行

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsBrowsing"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Public txtPath As String
Public OK As Boolean

Private Function GetFolderValue(wIdx As Integer) As Long
    If wIdx < 2 Then
        GetFolderValue = 0
    ElseIf wIdx < 12 Then
        GetFolderValue = wIdx
    Else
        GetFolderValue = wIdx + 4
    End If
End Function

Public Sub MyShow(ByVal txtTitle As String)
  Dim BI As BROWSEINFO
  Dim nFolder As Long
  Dim IDL As ITEMIDLIST
  Dim pIdl As Long
  Dim sPath As String
  Dim SHFI As SHFILEINFO
  Dim m_wCurOptIdx As Integer
  Dim txtDisplayName As String
  
  With BI
    .hOwner = fMainForm.hwnd
    nFolder = GetFolderValue(m_wCurOptIdx)
    
    If SHGetSpecialFolderLocation(ByVal fMainForm.hwnd, ByVal nFolder, IDL) = NOERROR Then
      .pidlRoot = IDL.mkid.cb
    End If
    
    .pszDisplayName = String$(MAX_PATH, 0)
    .lpszTitle = txtTitle
    .ulFlags = 0
  End With
  
  txtPath = ""
  txtDisplayName = ""
  
  pIdl = SHBrowseForFolder(BI)
  
  If pIdl = 0 Then Exit Sub
  sPath = String$(MAX_PATH, 0)
  SHGetPathFromIDList ByVal pIdl, ByVal sPath

  txtPath = Left(sPath, InStr(sPath, vbNullChar) - 1)
  txtDisplayName = Left$(BI.pszDisplayName, InStr(BI.pszDisplayName, vbNullChar) - 1)
  
  SHGetFileInfo ByVal pIdl, 0&, SHFI, Len(SHFI), SHGFI_PIDL Or SHGFI_ICON Or SHGFI_SMALLICON
  
  SHGetFileInfo ByVal pIdl, 0&, SHFI, Len(SHFI), SHGFI_PIDL Or SHGFI_ICON
  CoTaskMemFree pIdl
  If Right(txtPath, 1) = "\" Then txtPath = Left(txtPath, Len(txtPath) - 1)
  OK = True
End Sub