復制內(nèi)容到剪貼板
代碼:
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal strPath As String) As Long
'類設(shè)計：www.okexcel.com.cn
'2011.03.10
'Ver 1.0.0
Private PathName As String
Private FileName As String
Private FullName As String
Public fd As FileDialog
Public TempFileName As String
Public Ext_FileName As String
Public FixedLName As String, fixedRName As String
Public FileNameNum As Long
Public ErrNumber As Integer
Public ErrMsg As String
Public Function MakeMultiPath(Optional strNewDirectory As String = "") As Boolean
'創(chuàng)建多層文件夾
MakeMultiPath = False
If strNewDirectory <> "" Then PathName = strNewDirectory
If ErrorCheck(PathName = "", 1) Then Exit Function
PathName = PathName & IIf(Right(PathName, 1) = "\", "", "\")
ErrorCheck MakeSureDirectoryPathExists(PathName) <> 0, 2
MakeMultiPath = ErrNumber = 0
End Function
Private Function GetPathAndFile() As Boolean
'從全名中分離路徑名
Dim i As Integer
GetPath = False
If ErrorCheck(FullName = "", 3) Then Exit Function
i = InStrRev(FullName, "\", -1)
PathName = Left(FullName, i - 1)
FileName = Mid(FullName, i + 1)
GetPathAndFile = True
End Function
Public Function SelectFile() As Boolean
'選擇文件
SelectFile = False
If fd Is Nothing Then
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.AllowMultiSelect = False
fd.Filters.Clear
fd.Filters.Add "所有文件", "*.*"
End If
If fd.Show = -1 Then
SetFullName .SelectedItems(1)
SelectFile = True
End If
End Function
Public Function SelectFolder() As Boolean
'選擇文件夾
SelectFolder = False
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = -1 Then
PathName = .SelectedItems(1)
MakeFullName
SelectFolder = True
End If
End With
End Function
Public Function SelectFileSaveAs(Optional Initial As String = "所有文件 (*.*), *.*") As Boolean
'選擇另存文件
Dim FileSaveName As String
SelectFileSaveAs = False
FileSaveName = Application.GetSaveAsFilename(FileName, Initial)
If FileSaveName <> "False" Then
SetFullName FileSaveName
SelectFileSaveAs = True
End If
End Function
Public Sub SetFullName(strFullName As String)
'設(shè)置全路徑
FullName = strFullName
GetPathAndFile
End Sub
Public Sub SetPathName(strPathName As String)
'設(shè)置全路徑
PathName = strPathName
MakeFullName
End Sub
Public Sub SetFileName(strFileName As String)
'設(shè)置全路徑
FileName = strFileName
MakeFullName
End Sub
Private Sub MakeFullName()
FullName = ""
If PathName <> "" And FileName <> "" Then FullName = Replace(PathName & "\" & FileName, "\\", "\")
End Sub
Public Function GetFullName()
'讀全路徑
GetFullName = FullName
End Function
Public Function GetPathName()
'讀路徑名
GetPathName = PathName
End Function
Public Function GetFileName()
'讀文件名
GetFileName = FileName
End Function
Public Function FileExists() As Boolean
'檢查文件是否存在
FileExists = False
If ErrorCheck(FullName = "", 3) Then Exit Function
If Dir(FullName, 0) <> "" Then FileExists = True
End Function
Public Sub AutoReName()
Dim i As Integer
Dim f_name As String, e_name As String
i = InStrRev(FileName, ".")
f_name = Left(FileName, i) & "("
e_name = ")" & Mid(FileName, i)
i = 1
Do While True
FileName = f_name & i & e_name
i = i + 1
MakeFullName
If Not FileExists() Then Exit Do
Loop
End Sub
Public Sub NextFile()
Dim l As Integer
If FileNameNum = 0 Then FileNameNum = 1
If TempFileName = "" Then TempFileName = "00000"
l = Len(TempFileName)
SetFileName FixedLName & Right(TempFileName & i, l) & fixedRName & Ext_FileName
End Sub
Private Function ErrorCheck(tj As Boolean, n As Integer) As Boolean
ErrNumber = 0
If tj Then
ErrNumber = n
Select Case n
Case 1:
ErrMsg = "未給出路徑名！"
Case 2:
ErrMsg = "創(chuàng)建路徑失敗！"
Case 3:
ErrMsg = "未給出文件全路徑名！"
Case 4:
ErrMsg = "未給出文件名！"
End Select
End If
DownError = ErrNumber > 0
End Function
