Paste screenshots to predefined part of Word Document

[mikerek]

Hello,
I am a little bit confused and I need some help. Using excel macro, I need to paste screens to given part of Word Doc, it's structure is like this:

Heading1
...
Heading2
..
Heading3
..

The Word file has no bookmarks and I am not able to edit it.

Going further, my code is:

[/B]Private Function OpenDocs() As Object

    Dim oApp As Word.Application
    Dim intCount As Integer
    Set oApp = GetApplication("Word.Application")
    
    intCount = 3
    
    If oApp Is Nothing Then
        Exit Function
    End If
    
    With oApp
        For intCount = 1 To .Documents.Count
            If .Documents(intCount).Name Like "*trx*" Then
                userform2.ComboBox1.AddItem .Documents(intCount).Name
            End If
        Next intCount
    End With
    
    If userform2.ComboBox1.ListCount > 1 Then
        userform2.Show
        Set wdSuppDoc = oApp.Documents(strWordDocName)
    End If
    
    userform2.ComboBox1.Clear
    ThisWorkbook.Sheets(1).Range("c15") = wdSuppDoc.Name
    
'the part I'm talking about:
[B]    wdSuppDoc.Goto What:=wdGoToHeading, Which:=wdGoToFirst, Count:=3, Name:=""[/B]
[B]    'wdSuppDoc.Range.Paste[/B]
    
End Function


Private Function GetApplication(ByVal AppClass As String) As Object
    Const vbErr_AppNotRun = 429
    On Error Resume Next
    Set GetApplication = GetObject(Class:=AppClass)
    If Err.Number = vbErr_AppNotRun Then
        MsgBox "Please open Supporting Doc file first"
    End If
    On Error GoTo 0

End Function[B]

But it does nothing except of deleting entire file's content and paste screen at the button of the file.

Surprisingly this code works

[/B]    Dim wdApp As Word.Application    Dim wdActiveDoc As Word.Document


    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    On Error GoTo 0




    'Check to see if we found an instance.  If not you can create one if you desire
    If wdApp Is Nothing Then
        MsgBox "Please open Supporting Documentation File First"
        Exit Sub
    End If
    


    If wdApp.Selection.Type = wdSelectionIP Then
        wdApp.Selection.MoveRight Unit:=wdWord, Count:=1
    End If
  
    'Check if there are documents in the found instance of Word
    wdSuppDoc.Range.Goto What:=wdGoToHeading, Which:=wdGoToFirst, Count:=intCtrl, Name:=""
    wdApp.Selection.MoveUp Unit:=wdLine, Count:=1
wdApp.Selection.paste
[B]

but I cannot use it as I need to choose file where screens will be placed.

Any ideas how to fix it?

 

[Coding4Fun]

This might be a tweak to allow you to select the file to open. See the comment in red in the code though.

    Dim wdApp As Word.Application    Dim wdActiveDoc As Word.Document
    
    Set wordapp = CreateObject("word.Application")

    Dim pName As String
    Dim bDoc As Document
    Dim AppPath As String
    With Dialogs(wdDialogFileOpen)
        If .Show Then
            If .Name <> "" Then
                Set bDoc = Documents.Open(.Name)
                AppPath = bDoc.Path
            End If
        Else
            MsgBox "No file selected"
        End If
    End With

    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    On Error GoTo 0

    'Check to see if we found an instance.  If not you can create one if you desire
    If wdApp Is Nothing Then
        MsgBox "Please open Supporting Documentation File First"
        Exit Sub
    End If

    If wdApp.Selection.Type = wdSelectionIP Then
        wdApp.Selection.MoveRight Unit:=wdWord, Count:=1
    End If
  
    'Check if there are documents in the found instance of Word
[COLOR=#ff0000]    ' NOTE: The code breaks here, i think you left out code that refers to wd.SuppDoc but this should[/COLOR]
[COLOR=#ff0000]    ' point you in the right direction.[/COLOR]
    wdSuppDoc.Range.Goto What:=wdGoToHeading, Which:=wdGoToFirst, Count:=intCtrl, Name:=""
    wdApp.Selection.MoveUp Unit:=wdLine, Count:=1
wdApp.Selection.Paste

 

[mikerek]

Thanks for response, but selecting proper file works fine. The problem is to paste image to proper section of word document e.g. below heading1.

 

[Macropod]

Try:

Private Function OpenDocs() As Object
    Dim oApp As Word.Application
    Dim wdRng As Word.Range
    Dim intCount As Integer
    On Error Resume Next
    Set oApp = GetApplication("Word.Application")
    On Error GoTo 0
    If oApp Is Nothing Then
        MsgBox "Please open Supporting Doc file first"
        Exit Function
    End If
    With oApp
        For intCount = 1 To .Documents.Count
            If .Documents(intCount).Name Like "*trx*" Then
                userform2.ComboBox1.AddItem .Documents(intCount).Name
            End If
        Next intCount
    End With
    
    If userform2.ComboBox1.ListCount > 1 Then
        userform2.Show
        Set wdSuppDoc = oApp.Documents(strWordDocName)
        Set wdRng = wdSuppDoc.Goto(What:=wdGoToHeading, Which:=wdGoToFirst, Count:=3, Name:="")
        wdRng.collapse wdcollapseend
        wdRng.Paste
    End If
    
    userform2.ComboBox1.Clear
    ThisWorkbook.Sheets(1).Range("C15") = wdSuppDoc.Name
End Function