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
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