Создание пользовательских свойств Word из книги Excel

@Sta1917 · Регистрация: 08.11.2012

Author24 — интернет-сервис помощи студентам

Доброго времени суток, замучался набивать однотипные свойства в word'e. Помогите макросом для word 2010, создающим пользовательские свойства документа word из книги info.xls, которая лежит в одной папке с word'овским документом. Свойств может быть штук 15-20. Пример прилагаю.

@KoGG · 16.01.2014, 17:58

Запускать из Excel при открытом файле с данными полей.

Visual Basic

Sub Ex_Word_Обновить_своиства_doc_и_поля()
    Dim MyPath$, MyFile$, i&
    Dim wdApp As Object, wdDoc As Object
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = True
    MyPath = ActiveWorkbook.path & "\"
    MyFile = Dir(MyPath & "*.doc*")
    If MyFile = "" Then
         MsgBox "Рядом с данным файлом не найден файл doc"
         Exit Sub
    End If
    MyFile = MyPath & MyFile
    Set wdDoc = wdApp.Documents.Open(MyFile)
    With ActiveWorkbook.Sheets("Штамп")
        For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).row
            wdDoc.CustomDocumentProperties(.Cells(i, 1).Value).Value = .Cells(i, 2).Value
        Next i
    End With
    For i = 1 To wdDoc.Fields.Count
        With wdDoc.Fields(i)
            If .Type = 85 Then  'wdFieldDocProperty=85
                .Update
            End If
        End With
    Next i
    wdApp.Activate
End Sub

@Sta1917 · 16.01.2014, 23:08 **[ТС]**

При запуске открывает первый попавшийся *.doc и пишет "Invalid procedure call or argument", если можно, сделать запуск из word, т.к. info.xls в папке один, а *.doc и *.docx несколько, с различными названиями.

Добавлено через 36 минут
При подключенной "Microsoft Excel Object Library" в word выдает тоже самое

@KoGG · 17.01.2014, 10:47

Visual Basic

Sub Word_from_Excel_Обновить_свойства_doc_и_поля()
    Dim MyPath$, MyFile$, i&
    Dim xlApp As Object, xlBook As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    MyPath = ActiveDocument.Path & "\"
    MyFile = Dir(MyPath & "*.xls*")
    If MyFile = "" Then
         MsgBox "Рядом с данным файлом не найден файл xls"
         Exit Sub
    End If
    MyFile = MyPath & MyFile
    Set xlBook = xlApp.Workbooks.Open(MyFile)
    With xlBook.Sheets("Штамп")
        For i = 2 To .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp= -4162
            ActiveDocument.CustomDocumentProperties(.Cells(i, 1).Value).Value = .Cells(i, 2).Value
        Next i
    End With
    For i = 1 To ActiveDocument.Fields.Count
        With ActiveDocument.Fields(i)
            If .Type = wdFieldDocProperty Then
               .Update
            End If
        End With
    Next i
    xlBook.Close 0
    xlApp.Quit
    Set xlBook = Nothing
    Set xlApp = Nothing
End Sub

@Sta1917 · 17.01.2014, 12:57 **[ТС]**

При запуске из Word:
открывает файл *.xls, выдает run-time error "5" invalid procedure call or argument
ругается на строку:

Visual Basic

1	ActiveDocument.CustomDocumentProperties(.Cells(i, 1).Value).Value = .Cells(i, 2).Value

не добавляет поля, а только меняет значения, если они прописаны в *.doc

@KoGG · 17.01.2014, 16:20

Visual Basic

Sub Word_from_Excel_Обновить_свойства_doc_и_поля()
    Dim MyPath$, MyFile$, i&, Str1$, Str2$
    Dim xlApp As Object, xlBook As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    MyPath = ActiveDocument.Path & "\"
    MyFile = Dir(MyPath & "*.xls*")
    If MyFile = "" Then
         MsgBox "Рядом с данным файлом не найден файл xls"
         Exit Sub
    End If
    MyFile = MyPath & MyFile
    Set xlBook = xlApp.Workbooks.Open(MyFile)
    With xlBook.Sheets("Штамп")
        For i = 2 To .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp= -4162
            Str1 = .Cells(i, 1).Value: Str2 = .Cells(i, 2).Value
            ActiveDocument.CustomDocumentProperties(Str1).Value = Str2
        Next i
    End With
    For i = 1 To ActiveDocument.Fields.Count
        With ActiveDocument.Fields(i)
            If .Type = wdFieldDocProperty Then
               .Update
            End If
        End With
    Next i
    xlBook.Close 0
    xlApp.Quit
    Set xlBook = Nothing
    Set xlApp = Nothing
End Sub

Причина может быть в том, что количество и названия полей пользовательских свойств в книге Excel не совпадает с количеством и названиями пользовательских полей в активном документе Word. За этим надо следить.

Добавлено через 7 минут
Этот макрос создает пользовательские свойства и обновляет все поля, которые ссылаются на пользовательские свойства.

Visual Basic

Sub Word_from_Excel_добавить_свойства_doc()
    Dim MyPath$, MyFile$, i&, Str1$, Str2$
    Dim xlApp As Object, xlBook As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    MyPath = ActiveDocument.Path & "\"
    MyFile = Dir(MyPath & "*.xls*")
    If MyFile = "" Then
         MsgBox "Рядом с данным файлом не найден файл xls"
         Exit Sub
    End If
    MyFile = MyPath & MyFile
    Set xlBook = xlApp.Workbooks.Open(MyFile)
    With xlBook.Sheets("Штамп")
        For i = 2 To .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp= -4162
            Str1 = .Cells(i, 1).Value: Str2 = .Cells(i, 2).Value
            ActiveDocument.CustomDocumentProperties.Add Name:=Str1, LinkToContent:=False, Value:=Str2, Type:=msoPropertyTypeString
        Next i
    End With
    For i = 1 To ActiveDocument.Fields.Count
        With ActiveDocument.Fields(i)
            If .Type = wdFieldDocProperty Then
               .Update
            End If
        End With
    Next i
    xlBook.Close 0
    xlApp.Quit
    Set xlBook = Nothing
    Set xlApp = Nothing
End Sub

Однако если поле уже существовало ранее, то это вызовет ошибку.

Добавлено через 5 минут
И обновляет свойства, и добавляет, если они не существовали:

Visual Basic

Sub Word_from_Excel_Обновить_либо_добавить_свойства_doc()
    Dim MyPath$, MyFile$, i&, Str1$, Str2$
    Dim xlApp As Object, xlBook As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    MyPath = ActiveDocument.Path & "\"
    MyFile = Dir(MyPath & "*.xls*")
    If MyFile = "" Then
         MsgBox "Рядом с данным файлом не найден файл xls"
         Exit Sub
    End If
    MyFile = MyPath & MyFile
    Set xlBook = xlApp.Workbooks.Open(MyFile)
    On Error Resume Next
    With xlBook.Sheets("Штамп")
        For i = 2 To .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp= -4162
            Str1 = .Cells(i, 1).Value: Str2 = .Cells(i, 2).Value
            ActiveDocument.CustomDocumentProperties(Str1).Value = Str2
            ActiveDocument.CustomDocumentProperties.Add Name:=Str1, LinkToContent:=False, Value:=Str2, Type:=msoPropertyTypeString
        Next i
    End With
    On Error GoTo 0
    For i = 1 To ActiveDocument.Fields.Count
        With ActiveDocument.Fields(i)
            If .Type = wdFieldDocProperty Then
               .Update
            End If
        End With
    Next i
    xlBook.Close 0
    xlApp.Quit
    Set xlBook = Nothing
    Set xlApp = Nothing
End Sub

@Sta1917 · 17.01.2014, 16:48 **[ТС]**

Последний самое то, спасибо. Если не сложно можно дописать вариант удаления существующих свойств перед добавлением новых?

@KoGG · 20.01.2014, 10:30

Удаляет все старые пользовательские свойства и создает новые из файла Excel:

Visual Basic

Sub Word_from_Excel_удалить_старые_и_добавить_новые_свойства_doc()
    Dim MyPath$, MyFile$, i&, Str1$, Str2$, El
    Dim xlApp As Object, xlBook As Object
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    MyPath = ActiveDocument.Path & "\"
    MyFile = Dir(MyPath & "*.xls*")
    If MyFile = "" Then
         MsgBox "Рядом с данным файлом не найден файл xls"
         Exit Sub
    End If
    MyFile = MyPath & MyFile
    Set xlBook = xlApp.Workbooks.Open(MyFile)
    For Each El In ActiveDocument.CustomDocumentProperties
        El.Delete
    Next
    With xlBook.Sheets("Штамп")
        For i = 2 To .Cells(.Rows.Count, 1).End(-4162).Row 'xlUp= -4162
            Str1 = .Cells(i, 1).Value: Str2 = .Cells(i, 2).Value
            ActiveDocument.CustomDocumentProperties.Add Name:=Str1, LinkToContent:=False, Value:=Str2, Type:=msoPropertyTypeString
        Next i
    End With
    For i = 1 To ActiveDocument.Fields.Count
        With ActiveDocument.Fields(i)
            If .Type = wdFieldDocProperty Then
               .Update
            End If
        End With
    Next i
    xlBook.Close 0
    xlApp.Quit
    Set xlBook = Nothing
    Set xlApp = Nothing
End Sub

@Sta1917 1 / 1 / 0 Регистрация: 08.11.2012 Сообщений: 40
	16.01.2014, 23:08 [ТС]	3
	При запуске открывает первый попавшийся .doc и пишет "Invalid procedure call or argument", если можно, сделать запуск из word, т.к. info.xls в папке один, а .doc и .docx несколько, с различными названиями. Добавлено через 36 минут* При подключенной "Microsoft Excel Object Library" в word выдает тоже самое 0

@Sta1917 1 / 1 / 0 Регистрация: 08.11.2012 Сообщений: 40
	17.01.2014, 16:48 [ТС]	7
	Последний самое то, спасибо. Если не сложно можно дописать вариант удаления существующих свойств перед добавлением новых? 0

	20.01.2014, 10:30