1 Sub ChangeFileFormat(xltxFolder, xlsxFolder)
 2
 3     Dim strCurrentFileExt   As String
 4     Dim strNewFileExt       As String
 5     Dim objFSO              As Object
 6     Dim objFolder           As Object
 7     Dim objFile             As Object
 8     Dim xlFile              As Workbook
 9     Dim strNewName          As String
10     Dim strXltxFolderPath       As String
11     Dim strXlsxFolderPath       As String
12
13     Set objFSO = CreateObject("Scripting.FileSystemObject")
14
15     strCurrentFileExt = ".xltx"
16     strNewFileExt = ".xlsx"
17
18     strXltxFolderPath = ThisWorkbook.Path & "\" & xltxFolder & "\"
19     strXlsxFolderPath = ThisWorkbook.Path & "\" & xlsxFolder & "\"
20
21     If Not objFSO.FolderExists(strXltxFolderPath) Then   '判断指定文件夹是否存在
22         MsgBox "【模板文件】文件夹不存在"
23         Exit Sub
24     End If
25
26     If Not objFSO.FolderExists(strXlsxFolderPath) Then   '判断指定文件夹是否存在
27         fs.CreateFolder strXlsxFolderPath
28     End If
29
30     Set objFolder = objFSO.getfolder(strXltxFolderPath)
31     For Each objFile In objFolder.Files '循环所有的模板文件
32         strNewName = objFile.Name
33         If Right(strNewName, Len(strCurrentFileExt)) = strCurrentFileExt Then
34             Application.AskToUpdateLinks = False     '关闭程序询问更新链接提示
35             Application.DisplayAlerts = False
36             ThisWorkbook.UpdateLinks = xlUpdateLinksAlways  '更新链接
37
38             Set xlFile = Workbooks.Open(objFile.Path, , True) '读取模板文件
39             For Each sh In xlFile.Sheets  '替换文件中的公式
40                sh.UsedRange.Value = sh.UsedRange.Value
41             Next
42
43             strNewName = Replace(strNewName, strCurrentFileExt, strNewFileExt) '替换文件名为新的文件名
44             Select Case strNewFileExt
45             Case ".xlsx"
46                 xlFile.SaveAs strXlsxFolderPath & strNewName, XlFileFormat.xlOpenXMLWorkbook '保存为不带宏的excel
47             Case ".xlsm"
48                 xlFile.SaveAs strXlsxFolderPath & strNewName, XlFileFormat.xlOpenXMLWorkbookMacroEnabled '保存为带宏的excel
49             End Select
50             xlFile.Close
51             Application.AskToUpdateLinks = True
52             Application.DisplayAlerts = True
53         End If
54     Next objFile
55
56 ClearMemory:
57     strCurrentFileExt = vbNullString
58     strNewFileExt = vbNullString
59     Set objFSO = Nothing
60     Set objFolder = Nothing
61     Set objFile = Nothing
62     Set xlFile = Nothing
63     strNewName = vbNullString
64     strFolderPath = vbNullString
65 End Sub