'这是一个关于目录、文件等一些常用函数的模块
Option Explicit

'南宫飘雪
'Joforn@sohu.com
'QQ:42978116

Private Declare Function GetSaveFileNameD Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As tOPENFILENAME) As Long
Private Declare Function GetOpenFileNameD Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As tOPENFILENAME) As Long
Private Declare Function CreateDirectory Lib "kernel32" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pIdl As ITEMIDLIST) As Long
Private Declare Function SHGetFileInfo Lib "Shell32" Alias "SHGetFileInfoA" (ByVal pszPath As Any, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Declare Function ShellAbout Lib "shell32.dll" Alias "ShellAboutA" (ByVal hwnd As Long, ByVal szApp As String, ByVal szOtherStuff As String, ByVal hIcon As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pIdl As Long, ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

Public Enum SHSpecialFolderIDs '注释：列出所有Windows下特殊文件夹的ID
CSIDL_DEFAULT = &HFF
CSIDL_DESKTOP = &H0
CSIDL_INTERNET = &H1
CSIDL_PROGRAMS = &H2
CSIDL_CONTROLS = &H3
CSIDL_PRINTERS = &H4
CSIDL_PERSONAL = &H5
CSIDL_FAVORITES = &H6
CSIDL_STARTUP = &H7
CSIDL_RECENT = &H8
CSIDL_SENDTO = &H9
CSIDL_BITBUCKET = &HA
CSIDL_STARTMENU = &HB
CSIDL_DESKTOPDIRECTORY = &H10
CSIDL_DRIVES = &H11
CSIDL_NETWORK = &H12
CSIDL_NETHOOD = &H13
CSIDL_FONTS = &H14
CSIDL_TEMPLATES = &H15
CSIDL_COMMON_STARTMENU = &H16
CSIDL_COMMON_PROGRAMS = &H17
CSIDL_COMMON_STARTUP = &H18
CSIDL_COMMON_DESKTOPDIRECTORY = &H19
CSIDL_APPDATA = &H1A
CSIDL_PRINTHOOD = &H1B
CSIDL_ALTSTARTUP = &H1D
CSIDL_COMMON_ALTSTARTUP = &H1E
CSIDL_COMMON_FAVORITES = &H1F
CSIDL_INTERNET_CACHE = &H20
CSIDL_COOKIES = &H21
CSIDL_HISTORY = &H22
End Enum

Public Enum SHGFI_flags
SHGFI_LARGEICON = &H0
SHGFI_SMALLICON = &H1
SHGFI_OPENICON = &H2
SHGFI_SHELLICONSIZE = &H4
SHGFI_PIDL = &H8
SHGFI_USEFILEATTRIBUTES = &H10
SHGFI_ICON = &H100
SHGFI_DISPLAYNAME = &H200
SHGFI_TYPENAME = &H400
SHGFI_ATTRIBUTES = &H800
SHGFI_ICONLOCATION = &H1000
SHGFI_EXETYPE = &H2000
SHGFI_SYSICONINDEX = &H4000
SHGFI_LINKOVERLAY = &H8000
SHGFI_SELECTED = &H10000
End Enum

Public Enum UlFlagtype
ULF_RETURNONLYFSDIRS = &H1
ULF_DONTGOBELOWDOMAIN = &H2
ULF_STATUSTEXT = &H4
ULF_RETURNFSANCESTORS = &H8
ULF_BROWSEFORCOMPUTER = &H1000
ULF_BROWSEFORPRINTER = &H2000
End Enum

Public Enum OFNConst
OFN_READONLY = &H1 '“以只读方式”为选中
OFN_OVERWRITEPROMPT = &H2 '隐藏“以只读方式”
OFN_HIDEREADONLY = &H4 '出现“是否覆盖”对话框
OFN_NOCHANGEDIR = &H8 '不能改变目录
OFN_SHOWHELP = &H10 '显示“帮助”
OFN_ENABLEHOOK = &H20 '使对话框钩子函数生效
OFN_ENABLETEMPLATE = &H40 '模板生效
OFN_ENABLETEMPLATEHANDLE = &H80 '模板句柄生效？？
OFN_NOVALIDATE = &H100 '允许非法字符
OFN_ALLOWMULTISELECT = &H200 '允许选择多个文件
OFN_EXTENSIONDIFFERENT = &H400
OFN_PATHMUSTEXIST = &H800 '路径必须存在
OFN_FILEMUSTEXIST = &H1000 '文件必须存在
OFN_CREATEPROMPT = &H2000 '出现“是否建立文件”对话框
OFN_SHAREAWARE = &H4000 '忽略共享冲突
OFN_NOREADONLYRETURN = &H8000
OFN_NOTESTFILECREATE = &H10000 '不进行文件创建测试
OFN_NONETWORKBUTTON = &H20000 '没有网络按键（旧风格专用）
OFN_NOLONGNAMES = &H40000 '不使用长文件名（旧风格专用）
OFN_EXPLORER = &H80000 '资源管理器风格（新风格）
OFN_NODEREFERENCELINKS = &H100000 '使*.lnk可以选中
OFN_LONGNAMES = &H200000 '使用长文件名（旧风格专用）
OFN_ENABLEINCLUDENOTIFY = &H400000 '准许包括通知？？
OFN_ENABLESIZING = &H800000 '可改变大小
OFN_USEMONIKERS = &H1000000
OFN_DONTADDTORECENT = &H2000000
OFN_FORCESHOWHIDDEN = &H10000000

OFN_SHAREWARN = 0
OFN_SHARENOWARN = 1
OFN_SHAREFALLTHROUGH = 2

OFN_EX_NOPLACESBAR = &H1
End Enum

Private Const MAX_PATH = 260
Private Const NOERROR = 0
Private Const fMaxLong = 255

Private Type tOPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type

Private Type SHITEMID
cb As Long
abID() As Byte
End Type

Private Type ITEMIDLIST
mkid As SHITEMID
End Type

Private 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

Private Type SHFILEINFO
hIcon As Long
iIcon As Long
dwAttributes As Long
szDisplayName As String * MAX_PATH
szTypeName As String * 80
End Type

Private OpenFileNAMEList() As String

Public Function GetExtension(fileName As String)
Dim I, j, PthPos, ExtPos As Integer

For I = Len(fileName) To 1 Step -1 '注释： Go from the Length of the filename, to the first character by 1.
If Mid(fileName, I, 1) = "." Then '注释： If the current position is '注释：.'注释： then...
ExtPos = I '注释： ...Change the ExtPos to the number.
For j = Len(fileName) To 1 Step -1 '注释： Do the Same...
If Mid(fileName, j, 1) = "\" Then '注释： ...but for '注释：\'注释：.
PthPos = j '注释： Change the PthPos to the number.
Exit For '注释： Since we found it, don'注释：t search any more.
End If
Next j
Exit For '注释： Since we found it, don'注释：t search any more.
End If
Next I
If PthPos > ExtPos Then
Exit Function ''注释： No extension.
Else
If ExtPos = 0 Then Exit Function ''注释： If there is not extension, then exit sub.
GetExtension = Mid(fileName, ExtPos + 1, Len(fileName) - ExtPos) ''注释：Messagebox the Extension
End If
End Function
'注释： 使用:
'注释： FileExt = GetExtension("c:\windows\vb\vb.exe")

'从全路径名中提取文件名(从前向后)

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")

'翻转一个字符串
'下面的函数利用递归原理获得字符串的翻转字符串
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

'分离出路径和文件名

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 nwdonkey@371.net
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

'将长的目录名缩短

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 = "*.*", _
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

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
If Len(.lpstrInitialDir) = 0 Then .lpstrInitialDir = "C:\"
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

Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Const BIF_RETURNONLYFSDIRS = 1
Const MAX_PATH = 260
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
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 Sub Form_Load()
Dim iNull As Integer, lpIDList As Long, lResult As Long
Dim sPath As String, udtBI As BrowseInfo

With udtBI
.hWndOwner = Me.hWnd
.lpszTitle = lstrcat("请选择文件夹", "") '标题
.ulFlags = BIF_RETURNONLYFSDIRS
End With
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
SHGetPathFromIDList lpIDList, sPath
CoTaskMemFree lpIDList
iNull = InStr(sPath, vbNullChar)
If iNull Then
sPath = Left$(sPath, iNull - 1)
End If
End If
MsgBox sPath
End Sub

[此贴子已经被作者于2007-4-16 22:06:19编辑过]