正在讀取[1]:->D:\1\Resume.doc
正在生成:->d:\2\Resume
正在讀取[2]:->D:\1\簡歷(簡).doc
正在生成:->d:\2\簡歷(簡)
正在讀取[3]:->D:\1\計數器說明.doc
正在生成:->d:\2\計數器說明
***耗時0分41秒
Option Explicit
Dim docpath As String, xlspath As String
'ResultFlag=0 獲取路徑
'ResultFlag=1 獲取文件名
'ResultFlag=2 獲取擴展名
Public Function SplitPath(FullPath As String, ResultFlag As Integer) As String
Dim SplitPos As Integer, DotPos As Integer
SplitPos = InStrRev(FullPath, "\")
DotPos = InStrRev(FullPath, ".")
Select Case ResultFlag
Case 0
SplitPath = Left(FullPath, SplitPos - 1)
Case 1
If DotPos = 0 Then DotPos = Len(FullPath) + 1
SplitPath = Mid(FullPath, SplitPos + 1, DotPos - SplitPos - 1)
Case 2
If DotPos = 0 Then DotPos = Len(FullPath)
SplitPath = Mid(FullPath, DotPos + 1)
Case Else
Err.Raise vbObjectError + 1, "SplitPath Function", "Invalid Parameter!"
End Select
End Function
Public Function FileFolderExists(ByVal strFullPath As String) As Boolean
On Error GoTo EarlyExit
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
EarlyExit:
On Error GoTo 0
End Function
Sub Test() '使用雙字典，旨在提高速度
Dim MyName, Dic, Did, I, T, F, TT, MyFileName, Doc, Ke
Dim count As Integer
count = 0
T = Time
docpath = "D:\1\"
xlspath = "d:\2\"
Set Dic = CreateObject("Scripting.Dictionary") '創建壹個字典對象
Set Did = CreateObject("Scripting.Dictionary")
Dic.Add (docpath), ""
I = 0
Do While I < Dic.count
Ke = Dic.keys '開始遍歷字典
MyName = Dir(Ke(I), vbDirectory) '查找目錄
Do While MyName <> ""
If MyName <> "." And MyName <> ".." Then
If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then '如果是次級目錄
Dic.Add (Ke(I) & MyName & "\"), "" '就往字典中添加這個次級目錄名作為壹個條目
End If
End If
MyName = Dir '繼續遍歷尋找
Loop
I = I + 1
Loop
'Did.Add ("文件清單"), "" '以查找D盤下所有EXCEL文件為例
For Each Ke In Dic.keys
MyFileName = Dir(Ke & "*.doc")
Do While MyFileName <> ""
Doc = Ke & MyFileName
Did.Add (Doc), ""
count = count + 1
Debug.Print "正在讀取[" & count & "]:->" & Doc
doc2xls (Doc)
MyFileName = Dir
Loop
Next
' For Each Sh In ThisWorkbook.Worksheets
' If Sh.Name = "XLS文件清單" Then
' Sheets("XLS文件清單").Cells.Delete
' F = True
' Exit For
' Else
' F = False
' End If
' Next
'If Not F Then
' Sheets.Add.Name = "XLS文件清單"
'End If
'Sheets("XLS文件清單").[A1].Resize(Did.Count, 1) = WorksheetFunction.Transpose(Did.keys)
TT = Time - T
Debug.Print "***耗時" & Minute(TT) & "分" & Second(TT) & "秒"
End Sub
Sub doc2xls(filename As String)
Dim xlApp As Object, xlSheet As Object, outfile As String, c As Object
Set xlApp = CreateObject("Excel.Application")
Set xlSheet = xlApp.Workbooks.Add.Sheets(1)
Dim Wapp As Object, Doc As Object, GetDocText As Object 'Word Application 對象、Document 對象
Set Wapp = CreateObject("Word.Application") '創建Word Application 對象
Set Doc = Wapp.Documents.Open(filename, ReadOnly:=True) '打開文檔,返回壹個文檔對象
'xlSheet.Range("A1") = Doc.Content.Text
Doc.Application.Selection.WholeStory ''''全選
Doc.Application.Selection.Copy ''''''''''復制
xlSheet.Range("A1").Select
xlSheet.Paste
outfile = xlspath + Replace(SplitPath(filename, 1), ".doc", ".xls")
Debug.Print "正在生成:->" & outfile
xlSheet.Parent.SaveAs outfile
xlApp.Quit
Set xlSheet = Nothing
Set xlApp = Nothing
Wapp.Quit
Set Doc = Nothing
Set Wapp = Nothing
End Sub