Как вставить картинку в word vba

Option Explicit

Public sInitialPath As String

Private Declare Function PathRelativePathToW _
    Lib «shlwapi.dll» (ByVal pszPath As Long, _
    ByVal pszFrom As Long, ByVal dwAttrFrom As Long, _
    ByVal pszTo As Long, ByVal dwAttrTo As Long) _
    As Boolean

     
Private Function GetRelativePath _
  (ByVal sPathFrom As String, _
   ByVal sPathTo As String) As String
   ‘ Определение относительного адреса
   ‘ каталога или файла
   Dim sRelativePath As String
   sRelativePath = Space(260) ‘ резервируем буфер
   ‘
   If PathRelativePathToW(StrPtr(sRelativePath), _
             StrPtr(sPathFrom), vbDirectory, _
             StrPtr(sPathTo), 0) Then  ‘ определили адрес
             ‘MsgBox sRelativePath
     GetRelativePath = Left(sRelativePath, _
        InStr(sRelativePath, vbNullChar) — 1)
   Else  ‘
     GetRelativePath = «*»
   End If
End Function

Public Sub InsertLinkToPicture()
Dim sFileName As String
Dim oField As Field
    With Application.FileDialog(msoFileDialogOpen)
      .Title = «Укажите рисунок»
      .AllowMultiSelect = False
      .ButtonName = «Select»
      .Filters.Clear
      .Filters.Add «Картинки», «*.jpg; *.tiff; *.tif; *.png»
      If sInitialPath = «» Then sInitialPath = Application.ActiveDocument.Path
      .InitialView = msoFileDialogViewList
      If .Show Then sFileName = .SelectedItems(1) Else Exit Sub
    End With
    If Left(Selection.Text, 1) <> Chr(13) Then
      Selection.TypeText Text:=vbCr
    End If
    sFileName = GetRelativePath(Application.ActiveDocument.FullName, sFileName)
    Select Case True
      Case Left(sFileName, 2) = «..»
        sFileName = Right(sFileName, Len(sFileName) — 2)
      Case Left(sFileName, 1) = «.»
        sFileName = Right(sFileName, Len(sFileName) — 1)
    End Select
    If Left(sFileName, 1) = «/» Or Left(sFileName, 1) = «» Then
      sFileName = Right(sFileName, Len(sFileName) — 1)
    End If
    Set oField = Selection.Fields.Add(Range:=Selection.Range, Type:=wdFieldEmpty, _
      Text:=«INCLUDEPICTURE  « + Chr(34) + _
      Replace(sFileName, «», «/») + _
      Chr(34) + » d « _
      , PreserveFormatting:=True)

     
    If InStr(sFileName, «_35%») Then
      ActiveDocument.Hyperlinks.Add Anchor:=oField.Result, Address:=Replace(sFileName, «_35%», «»), SubAddress:=«»
    End If

   
    Selection.TypeText Text:=vbCrLf + Replace(sFileName, «_35%», «») ‘Right(sFileName, Len(sFileName) — Len(Application.ActiveDocument.Path))
    Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
    Selection.Font.Italic = True
    Selection.Font.Bold = True
    Selection.Font.Color = wdColorRed
    ‘ Selection.Range.HighlightColorIndex = wdGreen
    Selection.EndKey
End Sub

Option Explicit

Public sInitialPath As String

Public Function GetRelativePath(ByVal sFrom As String, ByVal sTo As String) As String
  GetRelativePath = «»
  Dim sFromTmp As String, sToTmp As String, sTmp As String, bFirst As Boolean
  sFromTmp = «»
  sToTmp = «»
  sTmp = «»
  bFirst = True
  Do While Len(sFrom) > Len(sFromTmp) Or Len(sTo) > Len(sToTmp)
    If Len(sFrom) > Len(sFromTmp) Then
      If Not bFirst Then sFrom = Right(sFrom, Len(sFrom) — Len(sFromTmp) — 1)
        sFromTmp = GetLeftPart(sFrom)
      Else
        sFrom = «»
        sFromTmp = «»
      End If

     
      If Len(sTo) > Len(sToTmp) Then
        If Not bFirst Then sTo = Right(sTo, Len(sTo) — Len(sToTmp) — 1)
          sToTmp = GetLeftPart(sTo)
        Else
          sTo = «»
          sToTmp = «»
        End If

       
        If bFirst And sFromTmp <> sToTmp Then
          Exit Function ‘ Нет общего корня
        Else
          bFirst = False
        End If

       
        If Len(GetRelativePath) > 0 Or sFromTmp <> sToTmp Then
          If Len(sFromTmp) > 0 Then
            If Len(GetRelativePath) > 0 Then
              GetRelativePath = GetRelativePath & «..»
            Else
              GetRelativePath = GetRelativePath & «..»
            End If
          End If
          If Len(sToTmp) > 0 Then
            If Len(sTmp) > 0 Then
              sTmp = sTmp & «» & sToTmp
            Else
              sTmp = sTmp & sToTmp
            End If
          End If
        End If
  Loop
  If Len(sTmp) > 0 Then GetRelativePath = GetRelativePath & «» & sTmp
  If 0 = Len(GetRelativePath) Then GetRelativePath = «.»
End Function

 
Function GetLeftPart(sPath)
Dim i As Integer
  For i = 1 To Len(sPath)
    If «» = Mid(sPath, i, 1) Then
      GetLeftPart = Left(sPath, i — 1)
      Exit Function
    End If
  Next
  GetLeftPart = sPath
End Function

Public Sub InsertLinkToPicture()
Dim sFileName As String
Dim oField As Field
  Application.UndoRecord.StartCustomRecord

 
  With Application.FileDialog(msoFileDialogOpen)
    .Title = «Укажите рисунок»
    .AllowMultiSelect = False
    .ButtonName = «Select»
    .Filters.Clear
    .Filters.Add «Картинки», «*.jpg; *.tiff; *.tif; *.png»
    If sInitialPath = «» Then sInitialPath = Application.ActiveDocument.Path
    .InitialView = msoFileDialogViewList
    If .Show Then sFileName = .SelectedItems(1) Else Exit Sub
  End With

 
  If Left(Selection.Text, 1) <> Chr(13) Then
    Selection.TypeText Text:=vbCr
  End If
  sFileName = GetRelativePath(Application.ActiveDocument.FullName, sFileName)

 
  Select Case True
    Case Left(sFileName, 2) = «..»
      sFileName = Right(sFileName, Len(sFileName) — 2)
    Case Left(sFileName, 1) = «.»
      sFileName = Right(sFileName, Len(sFileName) — 1)
  End Select

 
  If Left(sFileName, 1) = «/» Or Left(sFileName, 1) = «» Then
    sFileName = Right(sFileName, Len(sFileName) — 1)
  End If

 
  Set oField = Selection.Fields.Add(Range:=Selection.Range, Type:=wdFieldEmpty, _
  Text:=«INCLUDEPICTURE  « + Chr(34) + _
        Replace(sFileName, «», «/») + _
        Chr(34) + » d « _
        , PreserveFormatting:=True)

       
  If InStr(sFileName, «_35%») Then
    ActiveDocument.Hyperlinks.Add Anchor:=oField.Result, Address:=Replace(sFileName, «_35%», «»), SubAddress:=«»
  End If

 
  Selection.TypeText Text:=vbCrLf + Replace(sFileName, «_35%», «»)
  Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
  Selection.Font.Italic = True
  Selection.Font.Bold = True
  Selection.Font.Color = wdColorRed
  Selection.EndKey
  Selection.Collapse
  Selection.TypeParagraph
  Selection.Range.Style = ActiveDocument.Styles(wdStyleNormal)
  Application.UndoRecord.EndCustomRecord
End Sub