передавать данные из Word в Excel через vba

У меня есть форма в ms word, в которой некоторые поля являются элементами управления содержимым, а некоторые (которые являются переключателями) являются элементами управления ActiveX. Я хочу автоматически переносить сто словоформ в файл Excel. Я использую следующий код vba:

Sub getWordFormData()
Dim wdApp As New Word.Application
Dim myDoc As Word.Document
Dim CCtl As Word.ContentControl
Dim myFolder As String, strFile As String
Dim myWkSht As Worksheet, i As Long, j As Long

myFolder = "C:\Users\alarfajal\Desktop\myform"
Application.ScreenUpdating = False

If myFolder = "" Then Exit Sub
Set myWkSht = ActiveSheet
ActiveSheet.Cells.Clear
Range("A1") = "name"
Range("a1").Font.Bold = True
Range("B1") = "age"
Range("B1").Font.Bold = True
Range("C1") = "gender"
Range("C1").Font.Bold = True
Range("D1") = "checkbox1"
Range("D1").Font.Bold = True
Range("E1") = "checkbox2"
Range("E1").Font.Bold = True
Range("F1") = "singlechoice1"
Range("F1").Font.Bold = True
Range("G1") = "singlechoice2"
Range("G1").Font.Bold = True



i = myWkSht.Cells(myWkSht.Rows.Count, 1).End(xlUp).Row
strFile = Dir(myFolder & "\*.docx", vbNormal)

While strFile <> ""
    i = i + 1

    Set myDoc = wdApp.Documents.Open(Filename:=myFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)

    With myDoc
        j = 0
        For Each CCtl In .ContentControls
            j = j + 1
            myWkSht.Cells(i, j) = CCtl.Range.Text
        Next
        myWkSht.Columns.AutoFit
    End With
    myDoc.Close SaveChanges:=False
    strFile = Dir()
Wend
wdApp.Quit
Set myDoc = Nothing: Set wdApp = Nothing: Set myWkSht = Nothing
Application.ScreenUpdating = True

End Sub

все данные (текстовые поля, флажок) передаются успешно, но переключатель (который является ActiveX) не передается.

Это слово "документ":

введите описание изображения здесь

Это превосходный результат:

введите описание изображения здесь

Как я могу решить эту проблему?


excel vba ms-word activexobject
person Reem    schedule 07.12.2016    source источник
comment
Ваша проблема только в том, что кнопки выбора не читаются или флажки установлены в неправильном порядке?   -  person arcadeprecinct    schedule 07.12.2016
comment
@arcadeprecinct кнопки выбора не читаются   -  person Reem    schedule 07.12.2016

Ответы (2)


arrow_upward
1
arrow_downward

Вы можете ссылаться на элемент ActiveX в документе Word по его имени

myDoc.singlechoice1.Value

Лучше ссылаться на ContentControls по их именам тегов.

myDoc.SelectContentControlsByTag ("имя"). Item (1) .Range.Text

Отредактированный код

Sub getWordFormData()
    Dim wdApp As Object, myDoc As Object

    Dim myFolder As String, strFile As String
    Dim i As Long, j As Long

    myFolder = "C:\Users\alarfajal\Desktop\myform"

    If Len(Dir(myFolder)) = 0 Then
        MsgBox myFolder & vbCrLf & "Not Found", vbInformation, "Cancelled - getWordFormData"
        Exit Sub
    End If

    Application.ScreenUpdating = False
    Set wdApp = CreateObject("Word.Application")

    With ActiveSheet
        .Cells.Clear
        With .Range("A1:G1")
            .Value = Array("name", "age", "gender", "checkbox1", "checkbox2", "singlechoice1", "singlechoice2")
            .Font.Bold = True
        End With

        strFile = Dir(myFolder & "\*.docx", vbNormal)

        i = 1
        While strFile <> ""
            i = i + 1

            Set myDoc = wdApp.Documents.Open(Filename:=myFolder & "\" & strFile, ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)

            .Cells(i, 1).Value = myDoc.SelectContentControlsByTag("name").Item(1).Range.Text
            .Cells(i, 2).Value = myDoc.SelectContentControlsByTag("age").Item(1).Range.Text
            .Cells(i, 3).Value = myDoc.SelectContentControlsByTag("gender").Item(1).Range.Text
            .Cells(i, 4).Value = myDoc.SelectContentControlsByTag("checkbox1").Item(1).Checked
            .Cells(i, 5).Value = myDoc.SelectContentControlsByTag("checkbox2").Item(1).Checked
            .Cells(i, 6).Value = myDoc.singlechoice1.Value
            .Cells(i, 7).Value = myDoc.singlechoice2.Value

            myDoc.Close SaveChanges:=False
            strFile = Dir()
        Wend
        wdApp.Quit

        Application.ScreenUpdating = True
    End With

End Sub
person Community    schedule 07.12.2016

arrow_upward
1
arrow_downward

Ваши радиокнопки имеют встроенную форму, поэтому для них нужен отдельный цикл.

чтобы соответствовать вашему текущему коду, это будет что-то вроде

Dim shp As InlineShape
For Each shp In .InlineShapes
    j = j + 1
    myWkSht.Cells(i, j) = shp.OLEFormat.Object.Value
Next shp

Однако я не хотел бы полагаться на то, что Word всегда дает мне правильный порядок, и могут быть другие встроенные формы, поэтому, возможно, лучше сначала проверить элементы управления:

With myDoc
    'content controls
    For Each CCtl In .ContentControls
        Select Case CCtl.Title
            Case "name"
                myWkSht.Cells(i, 1) = CCtl.Range.Text
            'similar for age and gender
            Case "checkbox1"
                myWkSht.Cells(i, 4) = CCtl.Checked  'true and false are easier to evaluate in Excel than the checkmark symbols
            'same for checkbox 2
        End Select
    Next CCtl

    'option buttons
    For Each shp In .InlineShapes
        If shp.Type = wdInlineShapeOLEControlObject Then 'skip other inlineshapes
            Select Case shp.OLEFormat.Object.Name
                Case "singleSelectQuestionOption1" 'name it something unique
                    myWkSht.Cells(i, 6) = shp.OLEFormat.Object.Value
                'similar for option button 2
            End Select
        End If
    Next shp
End With
person arcadeprecinct    schedule 07.12.2016