PDA

View Full Version : Problem with code importing text from header textbox



ammarhm
07-18-2017, 06:50 AM
Hi everyone
I have the following code that would import text from a textbox in a header, a textbox in the document body, and a table in the body. The details of this code is present on another thread http://www.vbaexpress.com/forum/showthread.php?60012-import-contents-of-a-textbox-in-a-document-header-into-excel:








Option Explicit

Dim j As Long
Dim Wrd As Object

Sub Test()
Dim pth As Variant
Dim arr As Variant
Dim i As Integer
pth = """C:\Users\home\Desktop\Uploaded\*.doc*"""


Range("A:AZ").ClearContents


j = 1
arr = Filter(Split(CreateObject("wscript.shell").exec("cmd /c Dir " & pth & " /b /a-d /s").stdout.readall, vbCrLf), ".")

On Error Resume Next
Set Wrd = GetObject(, "Word.Application")
If Wrd Is Nothing Then Set Wrd = CreateObject("Word.Application")

Do
DoEvents
Loop Until Not Wrd Is Nothing

On Error GoTo 0
For i = LBound(arr) To UBound(arr)
Call ImportWordTable(arr(i))
Next i
Wrd.Quit
Set Wrd = Nothing
End Sub


Sub ImportWordTable(wdFileName As Variant)
Dim wdDoc As Object
Dim iRow As Long
Dim iCol As Integer
Dim x As Integer
Dim oheader As HeaderFooter
Dim oShp As Shape


Dim arr, i
On Error Resume Next
If wdFileName = False Then Exit Sub




Set wdDoc = Wrd.Documents.Open(wdFileName)



If wdDoc.tables.Count > 0 Then


With wdDoc



With .tables(1)

i = .Rows.Count * .Columns.Count
x = 1
ReDim arr(1 To i)
For iRow = 1 To .Rows.Count
For iCol = 1 To .Columns.Count
On Error Resume Next
arr(x) = WorksheetFunction.Clean(.cell(iRow, iCol).Range.Text)
On Error GoTo 0
x = x + 1
Next iCol
Next iRow

End With



With wdDoc.StoryRanges(5)
arr(2) = .Text
End With




For Each oheader In ActiveDocument.Sections(1).Headers
If oheader.Exists Then
For Each oShp In oheader.Range.ShapeRange
If oShp.Type = msoTextBox Then
arr(3) = oShp.TextFrame.TextRange.Text

End If
Next oShp
End If
Next oheader

End With


wdDoc.Close

Set wdDoc = Nothing
Set oheader = Nothing
Set oShp = Nothing

j = j + 1
Cells(j, 1).Resize(, i).Value = arr

End If
Set wdDoc = Nothing
End Sub





However the code is generating an error :
"Run time error "13", type mismatch"
on the following step:
For Each oheader In ActiveDocument.Sections(1).Headers


Could anyone help me out please with that error? I am a bit stuck here

Another question: Some documents dont contain a textbox in the body of the document, so i need something similar to "If oheader.Exists Then" for the following part of the code:




With wdDoc.StoryRanges(5)
arr(2) = .Text
End With


Kind regards