Код VBA для MS Word – вставка картинок в текст

Автор: | Дата: 18 Март 2014 · 1 комментарий 

Понадобилось мне тут в свое время писать много текста в MS Word, вставляя туда картинки. Понимая, что картинки рано или поздно понадобится переделывать, я пришел к необходимости вставки не картинок, а ссылок на них. Но вставить поле мало - крайне желательно еще и подписывать имя вставленной картинки.

При этом файл doc / docx может перемещаться между компьютерами (да, я пользуюсь и DropBox, и Yandex.Drive, и OneDrive). Соответственно надо вставлять относительные пути и подписывать их же. Не очень продолжительный поиск по сети и немного фантазии дали такой вариант:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
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

Но, как выяснилось, в MS Office 2013 x64 решение работать не будет (даже если попытаться корректно объявить импорт PathRelativePathToW, VBA отказывается обрабатывать указатели на строки). Поэтому было найдено другое решение:(исходник здесь):

Функция получения относительного пути
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
    Function GetRelativePath(sFrom, sTo)
     
    GetRelativePath = ""
    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)
     
    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

Для дополнительного комфорта я "обрамил" код строками

1
2
Application.UndoRecord.StartCustomRecord
Application.UndoRecord.EndCustomRecord

Тогда по Ctrl+Z будет отменяться все целиком, а не по шагам. Нередко рядом с оригинальным файлом я кладу его "уменьшенную" копию (уменьшение выполняется с FastStone Image Viewer, картинка уменьшается до 35%, имя файла оканчивается на "_35%"). Если рядом с оригиналом есть уменьшенный вариант, в поле вставляется "уменьшенная" копия, а подпись идет на нормальный вариант. В результате получилось такое чудо:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
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

Размещено в VBA, Новости, Прочее ПО, Разное · Метки: , ,



Комментарии

Есть 1 комментарий к “Код VBA для MS Word – вставка картинок в текст”
  1. Кулик Алексей aka kpblc пишет:
    17 Декабрь 2015 в 10:05

    На днях продолжил ковыряться с этим кодом (да, старенький, но рабочий ;)) Обнаружил, что код можно и нужно дополнить.
    Изначально при вставке "поля-картинки" она масштабируется так, чтобы "влезьть" в отведенную область. Но я обнаружил, что часто выполняю масштабирование рисунка уже внутри документа Word, а новый файл, с "_35%" в конце имени, не делаю. Ну и бог с ним - перед строкой

    1
      Selection.TypeText Text:=vbCrLf + Replace(sFileName, "_35%", "")

    добавлю

    1
    2
      oField.InlineShape.ScaleHeight = 35
      oField.InlineShape.ScaleWidth = 35

    И картинка будет сразу масштабироваться до 35%.
    Вообще говоря, InlineShape обладает весьма забавными методами и свойствами, надо будет потом поковыряться...

    P.S. Код работает только в MS Word 2010 и более поздних. LibreOffice 5.0 вообще открывает такой документ, не понимая, что такое "поле-картинка" - а это уже печально :(

Поделитесь своим мнением


Я не робот.