Создание пользовательских свойств 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

Новые блоги и статьи
Книги и учебные ресурсы по C# InfoMaster 08.01.2025 Базовые учебники и руководства Одной из лучших книг для начинающих является "C# 10 и . NET 6 для начинающих" Эндрю Троелсена и Филиппа Джепикса . Книга последовательно раскрывает основные концепции. . .	Что такое NullReferenceException и как исправить? InfoMaster 08.01.2025 NullReferenceException - одно из самых распространенных исключений, с которым сталкиваются разработчики на C#. Это исключение возникает при попытке обратиться к членам объекта (методам, свойствам или. . .	Что такое Null Pointer Exception (NPE) и как это исправить? InfoMaster 08.01.2025 Null Pointer Exception (NPE) - это одно из самых распространенных исключений в Java, которое возникает при попытке использовать ссылку на объект, значение которой равно null. Это исключение относится. . .	Русский язык в консоли C++ InfoMaster 08.01.2025 При разработке программ на C++ одной из частых проблем, с которой сталкиваются русскоязычные программисты, является корректное отображение кириллицы в консольных приложениях. Эта проблема особенно. . .	Telegram бот на C# InfoMaster 08.01.2025 Разработка ботов для Telegram стала неотъемлемой частью современной экосистемы мессенджеров. C# предоставляет мощный и удобный инструментарий для создания разнообразных ботов, от простых. . .	Использование GraphQL в Go (Golang) InfoMaster 08.01.2025 Go (Golang) является одним из наиболее популярных языков программирования, используемых для создания высокопроизводительных серверных приложений. Его архитектурные особенности и встроенные. . .
Что лучше использовать при создании класса в Java: сеттеры или конструктор? Alexander-7 08.01.2025 Вопрос подробнее: На вопрос: «Когда одновременно создаются конструктор и сеттеры в классе – это нормально?» куратор уточнил: «Ваш класс может вообще не иметь сеттеров, а только конструктор и геттеры. . .	Как работать с GraphQL на TypeScript InfoMaster 08.01.2025 Введение в GraphQL и TypeScript В современной разработке веб-приложений GraphQL стал мощным инструментом для создания гибких и эффективных API. В сочетании с TypeScript, эта технология. . .	Счётчик на базе сумматоров + регистров и генератора сигналов согласования. Hrethgir 07.01.2025 Создан с целью проверки скорости асинхронной логики: ранее описанного сумматора и предополагаемых fast регистров. Регистры созданы на базе ранее описанного, предполагаемого fast триггера. То-есть. . .	Как перейти с Options API на Composition API в Vue.js BasicMan 06.01.2025 Почему переход на Composition API актуален В мире современной веб-разработки фреймворк Vue. js продолжает эволюционировать, предлагая разработчикам все более совершенные инструменты для создания. . .	Архитектура современных процессоров inter-admin 06.01.2025 Процессор (центральный процессор, ЦП) является основным вычислительным устройством компьютера, которое выполняет обработку данных и управляет работой всех остальных компонентов системы. Архитектура. . .	История создания реляционной модели баз данных, правила Кодда Programming 06.01.2025 Предпосылки создания реляционной модели В конце 1960-х годов компьютерная индустрия столкнулась с серьезными проблемами в области управления данными. Существовавшие на тот момент модели данных -. . .

@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