comdlg32.bas

电话本信息 基本上实现电话功能 自己下载侃侃吧

Function StripPath(T$) As String
  Dim x%, ct%
  StripPath$ = T$
  x% = InStr(T$, "\")
  Do While x%
    ct% = x%
    x% = InStr(ct% + 1, T$, "\")
  Loop
  If ct% > 0 Then StripPath$ = Mid$(T$, ct% + 1)
End Function
''注释： 例子:
''注释： File = StripPath("c:\windows\hello.txt")

'283、如何翻转一个字符串？

'翻转一个字符串
'下面的函数利用递归原理获得字符串的翻转字符串
Function reversestring(revstr As String) As String
''注释：  revstr: 要翻转的字符串
''注释：  返回值: 翻转后的字符串
Dim doreverse As Long
  reversestring = ""
  For doreverse = Len(revstr) To 1 Step -1
    reversestring = reversestring & Mid$(revstr, doreverse, 1)
  Next
End Function

'284、如何分离出路径和文件名？

Public Function GetPathSTR(ByVal PATHANDNAME As String, Optional fileName As String) As String
Dim I As Long, slash As String
'注释：把带有含有文件和路径的字符串分为路径和文件两个字符串输出.GETPATH 返回路径,filename 返回文件名.
'注释：get path and filename separated. no "\" at the end of path after.
'注释：author NorthWest Donkey [e-mail]
  For I = Len(PATHANDNAME) To 1 Step -1
    slash = Mid(PATHANDNAME, I, 1)
    If slash = "\" Then Exit For
  Next I
  If I <> 0 Then
    fileName = Mid(PATHANDNAME, I + 1, Len(PATHANDNAME) - I)
    GetPathSTR = Left(PATHANDNAME, I - 1)
  End If
End Function

'285、如何将长的目录名缩短？

Public Function Path2Long(ByVal LongPath As String, ByVal reduce2 As Integer) As String
'注释： 将长的目录名缩短
''注释：如：由 "C:\Program Files\Vb5\我的最新程序库\temp" 变成 "...\Vb5\我的最新程序库\temp"
Dim I As Integer
Dim slash As String
  If reduce2 < Len(LongPath) Then
    Path2Long = Right(LongPath, reduce2 - 3) ''注释：get rid of extensions
    For I = 1 To Len(Path2Long)
      slash = Mid(Path2Long, I, 1)
      If slash = "\" Then Exit For
    Next I
    If I <> 0 Then
      Path2Long = "..." & Right(Path2Long, Len(Path2Long) - I + 1)
    End If
   Else
     Path2Long = LongPath
  End If
End Function

Public Function MDir(ByVal PathString As String, Optional ByVal HasTS As Boolean = False) As Boolean
  Dim I As Long, F As Boolean, sPath As String, DPath As String, TS As SECURITY_ATTRIBUTES
  
  On Error GoTo MDirError
  
  If Right(PathString, 1) <> "\" Then sPath = PathString & "\" Else sPath = PathString
  I = InStr(sPath, "\")
  F = True
  Do While I > 0
    DPath = Left(sPath, I)
    If Dir(DPath, vbDirectory) = "" Then
      If F And HasTS Then
        If MsgBox("目录不存在，是否创建一个新的目录？", vbQuestion Or vbYesNo) = vbNo Then
          MDir = False
          Exit Function
        End If
      End If
      If CreateDirectory(DPath, TS) = 0 Then
        MDir = False
        Exit Function
      End If
      F = False
    End If
    I = InStr(I + 1, sPath, "\")
  Loop
  MDir = True
  Exit Function
MDirError:
  MDir = False
End Function

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 Function GetADir(ByVal hwnd As Long, ByVal lpszTitleSTR As String, _
  Optional ByVal nFolderID As SHSpecialFolderIDs = &HFF, _
  Optional ByVal ulFlagsID As UlFlagtype = &H1 _
  ) As String
  
    Dim BI As BROWSEINFO
    Dim Idl As ITEMIDLIST
    Dim pIdl As Long
    Dim sPath As String
    Dim SHFI As SHFILEINFO
    Dim m As Integer
  
  With BI
    .hOwner = hwnd
    'nFolderID = GetFolderValue(M)
    If nFolderID <> CSIDL_DEFAULT Then
      If SHGetSpecialFolderLocation(ByVal hwnd, ByVal nFolderID, Idl) = NOERROR Then .pidlRoot = Idl.mkid.cb
    End If
    .pszDisplayName = String$(MAX_PATH, 0)
    .lpszTitle = lpszTitleSTR
    .ulFlags = ulFlagsID
  End With
  
  pIdl = SHBrowseForFolder(BI)
  GetADir = vbNullString
  If pIdl = 0 Then Exit Function
  sPath = String$(MAX_PATH, 0)
  If SHGetPathFromIDList(ByVal pIdl, ByVal sPath) Then
    m = InStr(sPath, Chr(0)) - 1
    If m < 1 Then Exit Function
    GetADir = Left(sPath, m)
  End If
End Function

Public Function GetOpenFileName(ByVal hwnd As Long, ByVal hInstance As Long, _
  Optional ByVal lpstrInitialDir As String, _
  Optional ByVal lpstrFilter As String = "All file|*.*", _
  Optional ByVal lpszTitleSTR As String = "请选择要打开的文件：", _
  Optional ByVal OnlyOneFile As Boolean = True, _
  Optional ByVal uFlags As OFNConst = 0) As Variant
  
  Dim OPN As tOPENFILENAME, uFlag As Long, FileNames() As String, I As Long
  Dim BI As BROWSEINFO, Idl As ITEMIDLIST
  lpstrFilter = Replace(lpstrFilter, "|", Chr$(0))
  With OPN
    .lStructSize = Len(OPN)
    .lpstrTitle = lpszTitleSTR
    .hInstance = hInstance
    .hwndOwner = hwnd
    If InStr(lpstrInitialDir, "<") > 0 And InStr(lpstrInitialDir, ">") > 0 Then
      .lpstrInitialDir = vbNullString
      Select Case lpstrInitialDir
        Case "<桌面>":     I = 0
        Case "<我的电脑>": I = 17
        Case "<我的文档>": I = 5
        Case "<开始菜单>": I = 11
        Case "<程序>":     I = 2
        Case "<启动>":     I = 7
        Case "<字体>":     I = 20
        Case "<回收站>":   I = 10
        Case "<历史记录>": I = 8
        Case "<收藏夹>":   I = 6
        Case "<发送到>":   I = 9
        Case "<网上邻居>": I = 18
        Case "<NetHood>": I = 19
        Case Else: I = 255
      End Select
      If I < 250 Then
         I = SHGetSpecialFolderLocation(hwnd, I, Idl)
         If I = NOERROR Then
           lpstrInitialDir = String(512, Chr(0))
           I = SHGetPathFromIDList(ByVal Idl.mkid.cb, ByVal lpstrInitialDir)
           .lpstrInitialDir = IIf(I <> 0, Trim(lpstrInitialDir), vbNullString)
         End If
      End If
      .lpstrInitialDir = vbNullString
    Else
      .lpstrInitialDir = lpstrInitialDir
    End If
    .lpstrFilter = lpstrFilter
    .lpstrFileTitle = Space(fMaxLong - 1)
    .lpstrFile = Space(fMaxLong - 1)
    .nMaxFile = fMaxLong
    .nMaxFileTitle = fMaxLong
    If uFlags = 0 Then
      .flags = IIf(OnlyOneFile, OFN_EXPLORER Or OFN_FILEMUSTEXIST Or uFlags, OFN_ALLOWMULTISELECT Or OFN_EXPLORER Or OFN_FILEMUSTEXIST Or uFlags)
    Else
      .flags = IIf(OnlyOneFile, uFlags, OFN_ALLOWMULTISELECT Or uFlags)
    End If
  End With
  
  I = GetOpenFileNameD(OPN)
  
  ReDim OpenFileNAMEList(0)
  If I > 0 Then
    FileNames() = Split(OPN.lpstrFile, vbNullChar)
    If UBound(FileNames()) < 3 Then
      ReDim OpenFileNAMEList(1)
      OpenFileNAMEList(0) = "1"
      OpenFileNAMEList(1) = FileNames(0)
    Else
      I = UBound(FileNames) - 3
      OpenFileNAMEList(0) = CStr(I)
      ReDim Preserve OpenFileNAMEList(I + 1)
      For I = 1 To UBound(OpenFileNAMEList)
        OpenFileNAMEList(I) = IIf(Right(FileNames(0), 1) = "\", FileNames(0) & FileNames(I), FileNames(0) & "\" & FileNames(I))
      Next
    End If
  Else
    OpenFileNAMEList(0) = "0"
  End If
  GetOpenFileName = OpenFileNAMEList
End Function