以下代码是将D:\123文件夹里的图片文件，文件名提取到WORD文件中，并自动进行一些设置，之前都好用，近期重装了系统，但office版本没变，执行是总报错，如下图，求修改，谢谢。
 - Option Explicit
- Dim objShell, objFSO, objFolder, objFile, objWord, objDoc, strFolderPath, strFileName, strInitialPath, strDocName
- Dim objSelection, objRange, objColumns, objPageSetup, objHeaderFooter
- Dim objDate, strDate, strTime, strDateTime, objCurrentFolder, objCurrentFile, strInputNumber, strHistoryFolderPath
- ' 创建Shell对象
- Set objShell = CreateObject("Shell.Application")
- ' 创建文件系统对象
- Set objFSO = CreateObject("Scripting.FileSystemObject")
- ' 获取脚本所在目录路径
- strInitialPath = objFSO.GetParentFolderName(WScript.ScriptFullName)
- ' 创建历史采集文件夹
- strHistoryFolderPath = strInitialPath & "\历史采集"
- If Not objFSO.FolderExists(strHistoryFolderPath) Then
- objFSO.CreateFolder(strHistoryFolderPath)
- End If
- ' 移动当前目录下文件名中包含“错题采集”的Word文件到历史采集文件夹
- Set objCurrentFolder = objFSO.GetFolder(strInitialPath)
- For Each objCurrentFile In objCurrentFolder.Files
- If InStr(objCurrentFile.Name, "错题采集") > 0 And (LCase(objFSO.GetExtensionName(objCurrentFile.Name)) = "doc" Or LCase(objFSO.GetExtensionName(objCurrentFile.Name)) = "docx") Then
- objCurrentFile.Move strHistoryFolderPath & "" & objCurrentFile.Name
- End If
- Next
- ' 指定目录为 D:\123 文件夹
- strFolderPath = "D:\123"
- ' 检查目录是否存在
- If Not objFSO.FolderExists(strFolderPath) Then
- MsgBox "目录不存在！", vbExclamation, "错误"
- WScript.Quit
- End If
- ' 获取当前日期和时间
- objDate = Now
- strDate = Year(objDate) & Right("0" & Month(objDate), 2) & Right("0" & Day(objDate), 2)
- strTime = Right("0" & Hour(objDate), 2) & Right("0" & Minute(objDate), 2) & Right("0" & Second(objDate), 2)
- strDateTime = strDate & strTime
- ' 提示用户输入数值
- strInputNumber = InputBox("请输入当前试卷播种号：", "输入数值")
- ' 生成文档名称，固定追加 "错题采集_播种" 和用户输入的数值
- strDocName = strInitialPath & "" & strDateTime & "错题采集_播种" & strInputNumber & ".docx"
- ' 获取目录对象
- Set objFolder = objFSO.GetFolder(strFolderPath)
- ' 创建Word应用对象
- Set objWord = CreateObject("Word.Application")
- objWord.Visible = False ' 隐藏Word应用程序
- ' 创建一个新的Word文档
- Set objDoc = objWord.Documents.Add
- ' 设置文档格式
- Set objPageSetup = objDoc.PageSetup
- objPageSetup.Orientation = 0 ' 1横向,0纵向
- objPageSetup.TopMargin = objWord.CentimetersToPoints(2)
- objPageSetup.BottomMargin = objWord.CentimetersToPoints(1)
- objPageSetup.LeftMargin = objWord.CentimetersToPoints(1)
- objPageSetup.RightMargin = objWord.CentimetersToPoints(1)
- objPageSetup.HeaderDistance = objWord.CentimetersToPoints(1)
- objPageSetup.FooterDistance = objWord.CentimetersToPoints(0.5)
- ' 设置纸张大小
- ' 9=A5，8=A4
- objPageSetup.PaperSize = 8
- ' 设置分栏
- Set objColumns = objDoc.Sections(1).PageSetup.TextColumns
- objColumns.SetCount(2)
- objColumns.LineBetween = True ' 添加分栏线
- ' 设置页眉内容
- With objDoc.Sections(1).Headers(1).Range
- .ParagraphFormat.Alignment = 2 ' 右对齐
- .Font.Name = "宋体"
- .Font.Size = 10.5 ' 小四号字
- .Text = ""
- End With
- ' 遍历目录中的文件
- For Each objFile In objFolder.Files
- ' 获取文件名
- strFileName = objFile.Name
-
- ' 检查文件扩展名是否为JPG
- If LCase(objFSO.GetExtensionName(strFileName)) = "jpg" Then
- ' 将文件名（不包含扩展名）写入Word文档
- objDoc.Content.InsertAfter objFSO.GetBaseName(strFileName) & vbCrLf
- End If
- Next
- ' 添加页码到页脚
- ' With objDoc.Sections(1).Footers(1).Range
- ' .ParagraphFormat.Alignment = 1 ' 居中
- ' .InsertAfter "第 "
- ' .Fields.Add .Characters.Last, -1, "PAGE", False
- ' .InsertAfter " 页，共 "
- ' .Fields.Add .Characters.Last, -1, "NUMPAGES", False
- ' .InsertAfter " 页"
- ' End With
- ' 关闭左侧导航窗格
- objWord.CommandBars("Navigation").Visible = False
- ' 保存Word文档
- objDoc.SaveAs strDocName
- ' 关闭Word文档
- objDoc.Close
- ' 退出Word应用
- objWord.Quit
- ' 清理对象
- Set objDoc = Nothing
- Set objWord = Nothing
- Set objFolder = Nothing
- Set objFSO = Nothing
- Set objShell = Nothing
- ' 打开最新生成的Word文件
- Set objWord = CreateObject("Word.Application")
- objWord.Visible = True
- objWord.Documents.Open strDocName
- Set objWord = Nothing
|
发表于 2025-3-18 13:19:03