VBA to replace ms word text boxes with their contents.

rberke
rberke used Ask the Experts™
on
I often copy a web page to the clipboard, then paste it into ms word for further processing.
One particular website often contains many empty text boxes as seen here ee-ms-word-text-box-deletion.docx.

MS Word treats the boxes as Fields, so I wrote the following code to delete these boxes.
Sub DeleteFields()
    ' REPLACES ALL TEXTBOXES WITH VALUE
    Dim rng As Range, sText As String

    For Each rng In ActiveDocument.StoryRanges
        With rng.Fields
            While .Count > 0
                .Item(1).Select
                
                ' sText = .text  ' tried a few variations like .code.text etc but could not find the magic properties to use.
                
                .Item(1).Delete
                
                ' Selection.TypeText sText
            Wend
        End With
    Next
End Sub

Open in new window


I would like to modify the code so that it deletes the empty text boxes and replaces  them with the inner text.





i use the following code that deletes all of these delete
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
GrahamSkanRetired
Top Expert 2012

Commented:
It isn't clear what you mean by the inner text. Do you mean the HTML inner text? This is only available on the web page, not the Word document Do you mean the text that ends up in the boxes? Then what is the point of asking for the text from empty boxes?
rberkeConsultant

Author

Commented:
Yes "the text that ends up in the boxes".

Only 95% of the boxes are empty. The other 5 % should be changed from a text box, into a simple string.  I really thought my example Docx made it very clear. Did you look at it?
GrahamSkanRetired
Top Expert 2012

Commented:
Sorry for the delay. Your question asked for the inner text from the empty boxes, so I got confused. I will have a go.
Retired
Top Expert 2012
Commented:
This works with your sample document:
Sub DeleteBoxes()
    Dim doc As Document
    Dim ilsh As InlineShape
    Dim tbl As Table
    Dim cl As Cell
    Dim strText As String
    
    Set doc = ActiveDocument
    Set tbl = doc.Tables(1)
    
    For Each ilsh In doc.InlineShapes
        If ilsh.Type = wdInlineShapeOLEControlObject Then
            If ilsh.OLEFormat.ClassType = "Forms.HTML:Text.1" Then
                strText = ilsh.OLEFormat.Object.Value
                If ilsh.Range.Cells.Count = 1 Then
                    Set cl = ilsh.Range.Cells(1)
                    cl.Range.Text = strText
                End If
            End If
        End If
    Next ilsh
End Sub

Open in new window

rberkeConsultant

Author

Commented:
Thanks a bunch, that is perfect !

Here is my final code. It has been tailored to my needs, but someone else may find it useful.

Sub DeleteBoxes()
    ' Call this after copying web pages to MS Word.
    ' It will autofit all tables
    ' and convert CheckBox and TextBoxes to be more like plain text.
    '
   
    Dim tbl As Table
    For Each tbl In ActiveDocument.Tables
        tbl.AutoFitBehavior wdAutoFitWindow
    Next tbl
   
    Dim ix As Long, sFrom As String, sTo As String
   
    ' fix a few quirks caused by pasting into MS Word.

    For Each var In Array("YesYes|Yes", "NoNo|No", "--Yes / No----Yes / No|--Yes / No--")
        ix = InStr(var, "|")
        sFrom = Left(var, ix - 1)
        sTo = Mid(var, ix + 1)
       
        Selection.Find.ClearFormatting
        Selection.Find.Replacement.ClearFormatting
        With Selection.Find
            .Text = sFrom
            .Replacement.Text = sTo
            .Forward = True
            .Wrap = wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        Selection.Find.Execute Replace:=wdReplaceAll
        Selection.Find.Execute
    Next

    Dim doc As Document
    Dim ilsh As InlineShape

    Dim cl As Cell
    Dim strText As String
   
    Set doc = ActiveDocument
   
    ' convert Text boxes into normal text.
   
    For Each ilsh In doc.InlineShapes
        If ilsh.Type = wdInlineShapeOLEControlObject Then
            Debug.Print ilsh.OLEFormat.ProgID & " " & ilsh.OLEFormat.ClassType & " " & ilsh.OLEFormat.Object.Value


            If ilsh.OLEFormat.ClassType = "Forms.HTML:Checkbox.1" Then
                Select Case True
                Case var1 Is Nothing:  Set var1 = ilsh.OLEFormat.Object
                Case var2 Is Nothing:  Set var2 = ilsh.OLEFormat.Object: Stop
                Case var3 Is Nothing:  Set var3 = ilsh.OLEFormat.Object: Stop
                End Select
                strText = qTrim(ilsh.OLEFormat.Object)
                If ilsh.Range.Cells.Count = 1 Then
                    Set cl = ilsh.Range.Cells(1)
                    cl.Range.Text = "CheckBox=" & qTrim(strText & " " & qTrim(cl.Range.Text))
'                 Stop
                End If

            ElseIf ilsh.OLEFormat.ClassType = "Forms.HTML:Text.1" Then
                strText = qTrim(ilsh.OLEFormat.Object.Value)
                If ilsh.Range.Cells.Count = 1 Then
                    Set cl = ilsh.Range.Cells(1)
                    cl.Range.Text = qTrim(strText & " " & qTrim(cl.Range.Text))
                    If qTrim(cl.Range.Text) = "" Then
                        cl.Range.Text = "!X" ' put an !X to remind me that the text box was once there.
                    End If
                   
                End If
            End If


        End If
    Next ilsh

End Sub
Function qTrim(str As String) As String

' trim control characters from front of string
qTrim = str
Do
    If Len(qTrim) = 0 Then Exit Function
    If Asc(qTrim) > 20 Then Exit Do
    qTrim = Mid(qTrim, 2)
Loop
' trim control characters from back of string
Do
    If Len(qTrim) = 0 Then Exit Function
    If Asc(Right(qTrim, 1)) > 20 Then Exit Do
    qTrim = Left(qTrim, Len(qTrim) - 1)
Loop
qTrim = Trim(qTrim)

End Function

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial