使用vb调用vba在word中插入图片的代码

过程名：wdout

作用：使用定义好的模板，自动将其中的形如｛????｝的字符以字段中的内容替换，并将｛照片｝替换成照片。如果没有照片，则删除相应的替换字符。

参数：photofile——照片文件的路径字符串，为完整绝对路径。不判断文件是否存在，如果不存在将出错。

插入图片其实只有一句
wdApp.Selection.InlineShapes.AddPicture FileName:= _
PhotoFile, LinkToFile:=False, SaveWithDocument:= _
True
可以用word的宏记录取得相应的代码。

Private Function WdOut(ByVal PhotoFile As String)
''{单位}{费用名称}{费用名细}{大写金额}{金额}{鉴定单位}{经办人}{日期}

Dim wdApp As Object, wdDoc As Object
Dim i As Integer

If CheckWord = False Then
MsgBox "没有安装Word软件或软件安装错误！", vbExclamation
Exit Function
End If

If DotName = "" Or Not FileExist(DotName) Then
MsgBox "没有找到打印模板，无法打印！！", vbExclamation
Exit Function
End If

MsgWinShow "正在从模板生成文档..."

''If Not wdDoc Is Nothing Then
''    On Error Resume Next
''    wdDoc.Close wdDoNotSaveChanges
''    Set wdDoc = Nothing
''    wdApp.Quit
''    Set wdApp = Nothing
''    On Error GoTo 0
''End If
''

Set wdApp = CreateObject("Word.Application")
With wdApp
' .Visible = True
Set wdDoc = .Documents.Add(DotName, False, 0, True) ''wdNewBlankDocument=0
End With

For i = 0 To adoRS.Fields.Count - 1
    'With .Content.Find

    Select Case adoRS.Fields(i).Name
    Case "照片"
        wdApp.Selection.Find.ClearFormatting
        With wdApp.Selection.Find
            .Text = "{照片}"
            .Replacement.Text = "A"
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchByte = True
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With

        wdApp.Selection.Find.Execute
        wdApp.Selection.Delete Unit:=1, Count:=1            ''删除        1=wdCharacter

    If PhotoFile > "" Then
        wdApp.Selection.InlineShapes.AddPicture FileName:= _
            PhotoFile, LinkToFile:=False, SaveWithDocument:= _
            True
        wdApp.Selection.MoveLeft Unit:=wdCharacter, Count:=1
        wdApp.Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
        wdApp.Selection.InlineShapes(1).Fill.Visible = 0        ''0= msoFalse
        wdApp.Selection.InlineShapes(1).LockAspectRatio = -1    ''-1= msoTrue
        wdApp.Selection.InlineShapes(1).Height = 28 * 4.1
        wdApp.Selection.InlineShapes(1).Width = 28 * 2.8
    End If
    Case Else

    With wdApp.Selection.Find
        .ClearFormatting
        .Replacement.ClearFormatting

        .Text = "{" & adoRS.Fields(i).Name & "}"
        .Replacement.Text = adoRS.Fields(i).Value & ""
        .Forward = True
        .Wrap = 1       ''1=wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
        .Execute Replace:=2     ''2=wdReplaceAll
    End With

    End Select
Next
    wdApp.Visible = True

Set wdDoc = Nothing
Set wdApp = Nothing

MsgWinHide

End Function

本文来自CSDN博客，转载请标明出处：http://blog.csdn.net/lanman/archive/2008/04/09/2265650.aspx