[问题求助] VBS脚本怎样提取123图片文件名到WORD？

qd2024

以下代码是将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
复制代码

czjt1234

111行也不是什么要紧的，改成注释好了

qd2024

回复 2# czjt1234


    好的 谢谢

jyswjjgdwtdtj

不同word之间略有区别 还会有进程无法关闭等问题 不如输入到txt再手动复制到word