Word中VBA在每个文件夹下生成一个同文件夹名称的Word文档、再导入指定图片并设置格式

yjwdjfqb

各位老师大家好！请老师们帮帮忙，谢谢老师们了，如下：
Word中VBA在每个文件夹下生成一个同文件夹名称的Word文档、再导入指定图片、并设置图片宽度和高度
如图：

附件.rar (31.99 KB, 下载次数: 5)

2022-4-16 15:57 上传

点击文件名下载附件

yjwdjfqb

老师们周末愉快，请老师们帮帮忙，谢谢老师们了！

aman1516

yjwdjfqb 发表于 2022-4-17 08:46
老师们周末愉快，请老师们帮帮忙，谢谢老师们了！

试试：

1. 
   
2. Sub GetPic()
   
3.     Dim fth, fld, drv As Object, pth
   
4.     On Error Resume Next
   
5.     Application.ScreenUpdating = False
   
6.     fth = ThisDocument.Path
   
7.     Set obMapp = CreateObject("Shell.Application").BrowseForFolder(0, stMedd, fth)    '&H1
   
8.     If Not obMapp Is Nothing Then
   
9.        fld = CreateObject("scripting.filesystemobject").GetFolder(fth).SubFolders
   
10.        For Each drv In CreateObject("scripting.filesystemobject").GetFolder(fth).SubFolders
    
11.            pth = fth & "" & drv.Name
    
12.            Call PictoWord(pth, ".jpg")
    
13.        Next
    
14.     End If
    
15.     MsgBox "ok!"
    
16.     Application.ScreenUpdating = True
    
17. End Sub
    
18. 
    
19. Function PictoWord(ByVal wpth As String, ByVal hj As String)
    
20. Dim wd, i As Long, n As Long, f
    
21. On Error Resume Next
    
22. Application.ScreenUpdating = False
    
23. Set wd = CreateObject("word.application")
    
24. Set wd = Documents.Add
    
25.     With Selection.PageSetup
    
26.         .LineNumbering.Active = False
    
27.         .Orientation = wdOrientPortrait
    
28.         .TopMargin = CentimetersToPoints(2.5)
    
29.         .BottomMargin = CentimetersToPoints(2.5)
    
30.         .LeftMargin = CentimetersToPoints(3)
    
31.         .RightMargin = CentimetersToPoints(3)
    
32.         .Gutter = CentimetersToPoints(0)
    
33.         .HeaderDistance = CentimetersToPoints(1.5)
    
34.         .FooterDistance = CentimetersToPoints(1.75)
    
35.         .PageWidth = CentimetersToPoints(21)
    
36.         .PageHeight = CentimetersToPoints(29.7)
    
37.         .FirstPageTray = wdPrinterDefaultBin
    
38.         .OtherPagesTray = wdPrinterDefaultBin
    
39.         .SectionStart = wdSectionNewPage
    
40.         .OddAndEvenPagesHeaderFooter = False
    
41.         .DifferentFirstPageHeaderFooter = False
    
42.         .VerticalAlignment = wdAlignVerticalTop
    
43.         .SuppressEndnotes = False
    
44.         .MirrorMargins = False
    
45.         .TwoPagesOnOne = False
    
46.         .BookFoldPrinting = False
    
47.         .BookFoldRevPrinting = False
    
48.         .BookFoldPrintingSheets = 1
    
49.         .GutterPos = wdGutterPosLeft
    
50.         .CharsLine = 45
    
51.         .LinesPage = 46
    
52.         .LayoutMode = wdLayoutModeLineGrid
    
53.     End With
    
54.     ActiveDocument.Paragraphs.Format.Alignment = wdAlignParagraphCenter
    
55.     Selection.TypeText Text:=Split(wpth, "")(UBound(Split(wpth, ""))) & " - 户口本" & vbLf
    
56.     Selection.TypeText Text:=Format(Now(), "yyyy-mm-dd") & vbLf & vbLf
    
57.    
    
58.     f = Dir(wpth & "\*" & hj)
    
59.     Do While f <> ""
    
60.         If InStr(f, hj) Then
    
61.            Set mypic = Selection.InlineShapes.AddPicture(FileName:=wpth & "" & f, SaveWithDocument:=True)
    
62.            mypic.Width = CentimetersToPoints(7.5)
    
63.            mypic.Height = CentimetersToPoints(5.5)
    
64.            Selection.Range.ParagraphFormat.Reset
    
65.            Selection.Range.Paragraphs.Alignment = wdAlignParagraphCenter
    
66.            Selection.InsertAfter vbLf
    
67.         End If
    
68.         f = Dir()
    
69.     Loop
    
70.     Selection.InsertAfter Text:="县教育局"    'ActiveDocument.Content.InsertAfter Text:="县教育局"
    
71.     wd.SaveAs FileName:=wpth & "" & Split(wpth, "")(UBound(Split(wpth, ""))) & ".doc"
    
72.     wd.Close
    
73.     wd.Quit
    
74.     'Dim sCmd As String
    
75.     'sCmd = "cmd /c Taskkill /im winword.exe /f /t"    '强制关闭word进程
    
76.     'Shell sCmd
    
77. Set wd = Nothing
    
78. Application.ScreenUpdating = True
    
79. End Function

复制代码

运行 GetPic

aman1516

代码审核中....
详见附件：

yjwdjfqb

aman1516 发表于 2022-5-10 11:10
代码审核中....
详见附件：

太厉害了，谢谢老师的帮助！！！