求助如何根据姓名提取文件夹内相同名字的相片到WORD文档指定位置。谢谢

qinhuan66

求助如何根据姓名提取文件夹内相同名字的相片到WORD文档指定位置。谢谢
求助.rar (140.71 KB, 下载次数: 51)

2013-7-23 19:50 上传

点击文件名下载附件

qinhuan66

有什么好的方法，麻烦各位老师帮指点一下。不胜感谢。

dajiahaoxinku12

建议使用邮件合并功能      

qinhuan66

dajiahaoxinku12 发表于 2013-7-23 20:29
建议使用邮件合并功能

可是我已以生成全部（差不多1000人）的准考到到一个WORD文档了，能否用宏来解决呢？谢谢

qinhuan66

忘记说明一下了，我的准考证信息（姓名、身份证号码、报考岗位、考场地址等都是在EXCEL表格里用VBA写到WORD文档的，能否也一起把相片也到贴相片那里呢。谢谢

qinhuan66

代码好下：
Private Sub CommandButton4_Click()
Dim Word对象 As New Word.Application, 当前路径, 导出文件名, 导出路径文件名, 判断, i, j
   Dim Str1, Str2
   当前路径 = ThisWorkbook.Path & "\准考证发放包"
   最后行号 = Sheets("数据库").Range("B1002").End(xlUp).Row
      B = InputBox("请输入数据开始行,不能小于3行。", "提示")
  C = InputBox("请输入数据结束行，不能大于10000行。", "提示")


   判断 = 0
   导出文件名 = "准考证（参加本次考试全部人员）.doc"
   导出路径文件名 = 当前路径 & "\" & 导出文件名
   FileCopy 当前路径 & "\准考证打印模板.doc", 导出路径文件名
   With Word对象
      .Documents.Open 导出路径文件名
      .Visible = False


      .ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument '设置位置在正文
      .Selection.WholeStory '全选
      .Selection.Copy '复制
      If 最后行号 > 3 Then
         For i = 3 To C - 1 '复制页
            .Selection.EndKey Unit:=wdStory '光标置于文件尾
            .Selection.InsertBreak Type:=wdPageBreak '分页
            .Selection.PasteAndFormat (wdPasteDefault) '粘贴
         Next i
      End If
      For i = B To C
        For j = 1 To 10 '填写文字数据
           Str1 = "数据" & Format(j, "000")
           Str2 = Sheets("数据库").Cells(i, j)
           .Selection.HomeKey Unit:=wdStory '光标置于文件首
           If .Selection.Find.Execute(Str1) Then '查找到指定字符串
              .Selection.Font.Color = wdColorAutomatic '字符为自动颜色
              .Selection.Text = Str2 '替换字符串
           End If
        Next j

      Next i
   End With
   Word对象.Documents.Save
   Word对象.quit
   Set Word对象 = Nothing
   If 判断 = 0 Then
      i = MsgBox("朋友你需要的准考证已生成完毕，现已保存到“" & 导出路径文件名 & "”！如需要帮助请QQ联系695360052", 0 + 48 + 256 + 0, "提示："): Unload 登录操作界面
   End If
End Sub

qinhuan66

求助各位专家，是否有解决的方法。谢谢

wx486

qinhuan66 发表于 2013-7-24 09:44
求助各位专家，是否有解决的方法。谢谢

提供一个代码仅供参考（只对本文档），文档中有多少人，要在相片里放多少张照片。

1. Sub test()
   
2.     Dim s As Shape, a As Shape, myrange As Range, i%
   
3.     For Each s In ActiveDocument.Shapes
   
4.         If s.Type = msoTextBox Then
   
5.             i = i + 1
   
6.             If i = 1 Then
   
7.                 Set a = ActiveDocument.Shapes.AddPicture _
   
8.                         (FileName:=ActiveDocument.Path & "\相片\姓名" & i & ".jpg")
   
9.             Else
   
10.                 Set myrange = ActiveDocument.GoTo(wdGoToPage, wdGoToAbsolute, i)
    
11.                 Set a = ActiveDocument.Shapes.AddPicture _
    
12.                         (FileName:=ActiveDocument.Path & "\相片\姓名" & i & ".jpg", Anchor:=myrange)
    
13.             End If
    
14.             a.Top = s.Top + 50
    
15.             a.Left = s.Left + 2
    
16.             a.Height = s.Height
    
17.             a.Width = s.Width - 5
    
18.         End If
    
19.     Next
    
20. End Sub

复制代码

qinhuan66

wx486 发表于 2013-7-25 10:32
提供一个代码仅供参考（只对本文档），文档中有多少人，要在相片里放多少张照片。

如果相片的姓名1、姓名2换成真实姓名又如何呢。谢谢

wx486

qinhuan66 发表于 2013-7-25 11:45
如果相片的姓名1、姓名2换成真实姓名又如何呢。谢谢

看在送花的份儿上，{:soso_e113:}又写了个代码，请测试。耐心点儿，代码运行有点慢。

1. Sub test()
   
2.     Dim s As Shape, a As Shape, myrange As Range, i%, j%, arr()
   
3.     Dim reg As Object, matches, ma, subma
   
4.     For Each s In ActiveDocument.Shapes
   
5.         If s.Type = msoPicture Then s.Delete
   
6.     Next
   
7.     Set reg = CreateObject("vbscript.regexp")
   
8.     With reg
   
9.         .Global = True
   
10.         .Pattern = "(姓      名：)(\S+)(\r)"
    
11.         Set matches = .Execute(ActiveDocument.Content)
    
12.     End With
    
13.     ReDim arr(1 To matches.Count)
    
14.     For Each ma In matches
    
15.         i = i + 1
    
16.         subma = ma.submatches(1)
    
17.         arr(i) = subma
    
18.     Next
    
19.     For Each s In ActiveDocument.Shapes
    
20.         If s.Type = msoTextBox Then
    
21.             j = j + 1
    
22.             If j = 1 Then
    
23.                 Set a = ActiveDocument.Shapes.AddPicture _
    
24.                         (FileName:=ActiveDocument.Path & "\相片" & arr(j) & ".jpg")
    
25.             Else
    
26.                 Set myrange = ActiveDocument.GoTo(wdGoToPage, wdGoToAbsolute, j)
    
27.                 Set a = ActiveDocument.Shapes.AddPicture _
    
28.                         (FileName:=ActiveDocument.Path & "\相片" & arr(j) & ".jpg", Anchor:=myrange)
    
29.             End If
    
30.             a.Top = s.Top + 50
    
31.             a.Left = s.Left + 2
    
32.             a.Height = s.Height
    
33.             a.Width = s.Width - 5
    
34.         End If
    
35.     Next
    
36.     MsgBox "ok"
    
37. End Sub

复制代码