chatgpt
Function GetAllDocFiles(folderPath As String) As String()
' 搜尋指定目錄及其子目錄下所有 .doc 檔案的路徑
Dim fileNames() As String
ReDim fileNames(0)
Dim fileName As String
fileName = Dir(folderPath & "\*.doc", vbNormal)
While fileName <> ""
If fileName <> "." And fileName <> ".." Then
' 將找到的 .doc 檔案加入陣列中
fileNames(UBound(fileNames)) = folderPath & "\" & fileName
ReDim Preserve fileNames(UBound(fileNames) + 1)
End If
fileName = Dir()
Wend
Dim subFolderPath As String
subFolderPath = Dir(folderPath & "\*", vbDirectory)
While subFolderPath <> ""
If subFolderPath <> "." And subFolderPath <> ".." Then
' 如果是目錄，就遞迴呼叫本身搜尋該目錄
If (GetAttr(folderPath & "\" & subFolderPath) And vbDirectory) = vbDirectory Then
Dim subFolderFiles() As String
subFolderFiles = GetAllDocFiles(folderPath & "\" & subFolderPath)
If UBound(subFolderFiles) > -1 Then
' 將子目錄中找到的 .doc 檔案加入陣列中
Dim i As Integer
For i = 0 To UBound(subFolderFiles)
fileNames(UBound(fileNames)) = subFolderFiles(i)
ReDim Preserve fileNames(UBound(fileNames) + 1)
Next i
End If
End If
End If
subFolderPath = Dir()
Wend
If UBound(fileNames) > 0 Then
ReDim Preserve fileNames(UBound(fileNames) - 1)
Else
ReDim fileNames(-1)
End If
GetAllDocFiles = fileNames
End Function
Sub ConvertDocToDocx()
' 將所有 .doc 檔案轉換為 .docx 檔案
Dim fileNames() As String
fileNames = GetAllDocFiles("C:\My Documents") ' 指定搜尋目錄
Dim fileName As String
For Each fileName In fileNames
Dim doc As Document
Set doc = Documents.Open(fileName)
doc.SaveAs2 FileName:=Replace(fileName, ".doc", ".docx"), FileFormat:=wdFormatXMLDocument
doc.Close
Next fileName
End Sub
這個程式會搜尋指定的目錄及其子目錄下所有 .doc 檔案，並將其轉換為 .docx 格式。如果您希望搜尋的目錄不同，請將 GetAllDocFiles 函數中的 folderPath 變數設定為該目錄的路徑。注意，這個程式會將找到的所有 .doc 檔案都轉換為 .docx 格式，請務必備份原始檔案。
[acrd 在 2023-3-5 12:44 AM 作了最後編輯]
|
