网站 › 『编程语言区』 › vba，word根据图片及图片名,生成表单

etkane 发表于 2024-4-2 22:41

vba，word根据图片及图片名,生成表单

为了工作方便，写了一个根据相片名称，自动生成表单的工具。

工具是office word 里面自带的vba。wps应该也正常使用。

原理是，很多相片，需要生成一张张表单，看相片改名字比较方便，于是借鉴网络代码加自己改造出来下列代码。

需要在word里，打开开发工具，然后用宏或者virtual basic里插入模块，复制下列代码，然后F5或者点运行，根据提示操作即可。

图片名称以 - 分割，代码会逐行填入内容。需要改的地方都有注释了，自己尝试，不明白可以跟帖问一下。

生成表格效果，行列均可改，列数对话框输入即可。

图片原文件文件名实例（也可以随便改）





Sub imgTbl()
      currentDate = Date
   
    ' 将当前日期作为文本插入到光标位置
    'Selection.TypeText Text:=currentDate & " "
   
    Selection.TypeText Text:="问题整改通知与记录，编制日期：" & currentDate
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    Dim nrr
    If ActiveDocument.Tables.Count = 1 Then '删除上次数据
      ActiveDocument.Tables(1).Delete
    End If
    '//获取文件夹，存入数组
    Dim kr()
    Set fso = CreateObject("scripting.filesystemobject")
    With Application.FileDialog(msoFileDialogFolderPicker)
      If .Show Then PathSht = .SelectedItems(1) Else Exit Sub
    End With
   
    Dim imgPaths()'图片路径数组
    picname = Dir(PathSht & "\*.*")
    Do While picname <> "" 'Do While循环
      i = i + 1
      imgpath = PathSht + "\" + picname
      picname = Dir    ' 查找下一个图片
      ReDim Preserve imgPaths(1 To i)
      imgPaths(i) = imgpath
      'Debug.Print (imgpath)
      
    Loop
   
    imgnum = UBound(imgPaths) + 1
   
    Dim value '弹出输入框，输入列数，默认10，会自动计算行数
    value = InputBox("请输入表格列数", "表格列数", "10")
    'Debug.Print value
   
    tbl_columnNum = value
    tbl_rowNum = (Int(imgnum / tbl_columnNum)) * 8
   
    '//开始新建表格
    Dim tbl As Table
    Set tbl = ActiveDocument.Tables.Add(Range:=Selection.Range, NumRows:=tbl_rowNum, NumColumns:=tbl_columnNum)
    '新建表格
    tbl.Style = "网格型"
    Set tbl = ActiveDocument.Tables(1)
    tbl.Rows.Height = 20
    'tbl.Columns(1).Width = 1.27 * 28.35 '设置表格各列的列宽
    'tbl.Columns(2).Width = 2.13 * 28.35
    'tbl.Columns(3).Width = 3.3 * 28.35
    'tbl.Rows(1).Height = 2.13 * 28.35 '设置表格各列的列宽
    tbl.Rows.Alignment = wdAlignRowCenter '居中对齐
    tbl.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter '文字垂直居中
    'tbl.Range.HorizontalInVertical = xlHAlignCenter '文字水平居中
    'tbl.Range.Rows.Alignment = wdAlignRowCenter
    tbl.Range.ParagraphFormat.Alignment = wdAlignParagraphLeft '文字水平居中
    tbl.Range.Font.Size = 10

   
      
    '//开始插入图片
    For i = 1 To tbl_rowNum
    '对Word中的表格中的行进行循环。
      For j = 1 To tbl_columnNum
      '对Word中的表格中的列进行循环。
            fod_index = fod_index + 1
            If fod_index >= imgnum Then ' 超过图片数量，退出循环
                Exit For
            End If
            imgpath = imgPaths(fod_index) '图片路径
            srr = Split(imgpath, "\")
            FullName = srr(UBound(srr))
            nrr = Split(FullName, ".")
            picname = nrr(0)
             nrr = Split(nrr(0), "-")
            
            ReDim Preserve nrr(0 To 6)
            'tbl.Cell(i, j).Range.Text = nrr(0) '单元格文字图片名称不带后缀
            'tbl.Cell(i, j).Range.Text = "OK"
            nrr(3) = picname
             nrr(4) = " "
            nrr(5) = " "
               nrr(6) = " "

            
            
            
            tbl.Cell(i * 8 - 7, j).Range.Select '选择当前单元格
            Dim shp As InlineShape
            Set shp = Selection.Range.InlineShapes.AddPicture(FileName:=imgpath) '插入图片
            Selection.EndKey wdLine
            'tbl.Cell(i * 5, j).Range.Select '选择当前单元格 '选中该单元格，为了下一步光标定位到单元格内部
            bt = Array("问题描述：", "责任单位：", "需整改完成时间：", "图片名称:", "实际完成时间：", "整改自检人及时间：", "验证人及验证时间：")
            For m = 0 To 6
         
            tbl.Cell((i - 1) * 8 + m + 2, j).Range.Select
            Selection.EndKey wdLine
            Selection.TypeText bt(m) & nrr(m)
            
            Next m
            
            
            
'            tbl.Cell(i * 5 - 3, j).Range.Select
'            Selection.EndKey wdLine
'            Selection.TypeText "问题描述：" & nrr(0)    '单元格文字图片名称不带后缀
'            tbl.Cell(i * 5 - 2, j).Range.Select
'            Selection.EndKey wdLine
'            Selection.TypeText "责任单位：" & nrr(1)    '单元格文字图片名称不带后缀
'            tbl.Cell(i * 5 - 1, j).Range.Select
'            Selection.EndKey wdLine
'            Selection.TypeText "整改时间：" & nrr(2)    '单元格文字图片名称不带后缀
'            tbl.Cell(i * 5, j).Range.Select
'            Selection.EndKey wdLine
            'Selection.TypeText "整改完成时间及验证人签字：" & nrr(4)   '单元格文字图片名称不带后缀
      Next
    Next
   

    For t = 1 To Int(imgnum / 2) - 1
   
    Set tbl = ActiveDocument.Tables(t) '将第一个表格赋值给变量tbl
   
    If Not IsNull(tbl) Then '如果存在表格
      tbl.Rows(9).Select '选择第二行（索引从1开始）
      
   
    Selection.SplitTable
    Selection.InsertBreak Type:=wdPageBreak
   Selection.TypeText Text:="问题整改通知与记录，编制日期：" & currentDate
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    'Selection.MoveDown Unit:=wdLine, Count:=1
    Else
      MsgBox "当前文档没有任何表格。"
    End If
   
    Next t
   

   Selection.HomeKey Unit:=wdStory
    MsgBox "完成！"
End Sub


Function getfol()
'该函数的作用：弹出对话框提示用户选择文件夹，并且返回该文件夹路径。
'如果用户选择了取消，则返回空值
    Dim PathSht As String
    With Application.FileDialog(msoFileDialogFolderPicker)
      If .Show Then
            PathSht = .SelectedItems(1)
      Else
            PathSht = ""
            Exit Function
      End With
      getfol = PathSht & IIf(Right(PathSht, 1) = "\", "", "\")
End Function

zhaoxuanjun 发表于 2024-4-3 08:55

我自己建了一个文件夹 里面有图片2张，在一个空白word中把代码复制后按F5，出错 end with 没有with

cxx0515 发表于 2024-4-2 22:52

感谢分享，办公用的到

jgn3odl2 发表于 2024-4-2 22:54

&#128002;&#127866;

雾都孤尔 发表于 2024-4-2 23:00

能派上用场，支持原创。感谢分享。

soulpqpq 发表于 2024-4-2 23:12

太酷了！谢谢

yingqiangpai 发表于 2024-4-2 23:28

能派上用场的好内容，支持原创，感谢你的无私分享。

sxzswx 发表于 2024-4-3 05:13

nect 发表于 2024-4-3 07:43

很棒的，正好项目中有此需求，借鉴一下

Lty20000423 发表于 2024-4-3 07:46

非常支持，赞一个

tyq2003 发表于 2024-4-3 08:12

不说不知道，学习了。谢谢

查看完整版本: vba，word根据图片及图片名,生成表单