VBA works in 2007 but not 2010

[brenton]

this code always worked in 07 but now is crashing in 2010. It should take a range in excel and paste as an image in the corresponding bookmark in Word? It seems like it is running out of memory because it copies everything to the clipboard. Ive tried changing Data Type=:0 and DoEvents any ideas? Thanks!


Sub GenerateBusinessCase()

'
Application.ScreenUpdating = False

Dim pappWord As Object
Dim docWord As Object
Dim wb As Excel.Workbook
Dim xlName As Excel.Name
Dim Path As String
'Dim rangeData As Range

Const wdGoToAbsolute As Integer = 1
Const wdGoToLine As Integer = 3



Set wb = ActiveWorkbook
Path = wb.Path & Application.PathSeparator & "GE Lighting Business Case Template.docx"
On Error GoTo ErrorHandler

'Create a new Word Session
Set pappWord = CreateObject("Word.Application")
On Error GoTo ErrorHandler

'Open document in word
Set docWord = pappWord.Documents.Add(Path)

'Loop through names in the activeworkbook
For Each xlName In wb.Names
'if xlName's name is existing in document then put the value in place of the bookmark
If docWord.Bookmarks.Exists(xlName.Name) Then
docWord.Bookmarks(xlName.Name).Range.Text = Range(xlName.Value)
End If
Next xlName

'Run the table copy code. I am copying/pasting my Excel tables with this code.

docWord.Bookmarks("FirstPillar").Range.Select
Range("FirstPillar1").Copy
pappWord.Selection.PasteSpecial Link:=False, DataType:=3

docWord.Bookmarks("ThirdPillar").Range.Select
Range("ThirdPillar1").Copy
pappWord.Selection.PasteSpecial Link:=False, DataType:=3

docWord.Bookmarks("FourthPillar").Range.Select
Range("FourthPillar1").Copy
pappWord.Selection.PasteSpecial Link:=False, DataType:=3

docWord.Bookmarks("SecondPillar").Range.Select
Range("SecondPillar1").Copy
pappWord.Selection.PasteSpecial Link:=False, DataType:=3

docWord.Bookmarks("WaterfallControls").Range.Select
Range("WaterfallControls1").Copy
pappWord.Selection.PasteSpecial Link:=False, DataType:=3

docWord.Bookmarks("ModelAdjustment").Range.Select
Range("ModelAdjustment1").Copy
pappWord.Selection.PasteSpecial Link:=False, DataType:=3

docWord.Bookmarks("FinancialMetrics").Range.Select
Range("FinancialMetrics1").Copy
pappWord.Selection.PasteSpecial Link:=False, DataType:=3

docWord.Bookmarks("FinancialResults").Range.Select
Range("FinancialResults1").Copy
pappWord.Selection.PasteSpecial Link:=False, DataType:=3

docWord.Bookmarks("SolutionInvestment").Range.Select
Range("SolutionInvestment1").Copy
pappWord.Selection.PasteSpecial Link:=False, DataType:=3


'Turn off copy mode
Application.CutCopyMode = False

'Activate word document
With pappWord
.Visible = True
.ActiveWindow.WindowState = 1
.Activate
' Optional - Display document on page #1
.Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=1
End With

'Release the Word object to save memory and exit macro
ErrorExit:
Set pappWord = Nothing
Exit Sub

'Error Handling routine
ErrorHandler:
If Err Then
MsgBox "Error No: " & Err.Number & ";" & vbNewLine & " o Verify calculations on the financial results page do not return errors".
If Not pappWord Is Nothing Then
pappWord.Quit False
End If
Resume ErrorExit
End If
Application.ScreenUpdating = True

End Sub

 

[Case_Germany]

Hi,

is there any other code i can use to paste an image from excel to Word instead of this?

Yes - something like that:

Sheet1.Range("FirstPillar1").CopyPicture 1, 2

An example:

Option Explicit
Const strPath As String = "C:\Temp\Sample.docx"
Dim blnTMP As Boolean
Public Sub Main()
    Dim objRange As Object
    Dim objDoc As Object
    Dim objApp As Object
    On Error GoTo Fin
    Set objApp = OffApp("Word")
    'Set objApp = OffApp("Word", False)
    'Set objApp = OffApp("Outlook")
    'Set objApp = OffApp("Outlook", False)
    'Set objApp = OffApp("PowerPoint")
    'Set objApp = OffApp("PowerPoint, False")
    'Set objApp = OffApp("ACCESS")
    'Set objApp = OffApp("ACCESS", False)
    If Not objApp Is Nothing Then
        Set objDoc = objApp.Documents.Open(strPath)
        Sheet1.Range("FirstPillar1").CopyPicture 1, 2
        If Not objDoc.Bookmarks.Exists("FirstPillar") Then
            MsgBox "Bookmark not available!"
        Else
            Set objRange = objDoc.Bookmarks("FirstPillar").Range
            objRange.Paste
            Application.CutCopyMode = False
        End If
    Else
        MsgBox "Application not installed!"
    End If
Fin:
    If Not objApp Is Nothing Then
        If blnTMP = True Then
            objApp.Quit
            blnTMP = False
        End If
    End If
    Set objRange = Nothing
    Set objDoc = Nothing
    Set objApp = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, _
    Optional blnVisible As Boolean = True) As Object
    Dim objApp As Object
    On Error Resume Next
    Set objApp = GetObject(, strApp & ".Application")
    Select Case Err.Number
        Case 429
            Err.Clear
            Set objApp = CreateObject(strApp & ".Application")
            blnTMP = True
            If blnVisible = True Then
                On Error Resume Next
                objApp.Visible = True
                Err.Clear
            End If
    End Select
    On Error GoTo 0
    Set OffApp = objApp
    Set objApp = Nothing
End Function

I think the problem may be related to the "Select". Correct referencing the Word objects (application, document, bookmark) with "Set" instead of ".Selection.PasteSpecial" could be a help.

 

[brenton]

vielen dank! that is a way ton of code to replace what I had. I got it to run with your code, but I can't get the information you sent me connected back with what i originally had due to its complexity

I added what you suggested back into my code but there is still no image in the word document. Any ideas? it might be very simple. I am relatively new to VBA so i might not have changed all of your dim names correctly.

Option Explicit

Sub GenerateBusinessCase()

'
Application.ScreenUpdating = False

[COLOR="red"]Dim objRange As Object[/COLOR]
Dim pappWord As Object
Dim docWord As Object
Dim wb As Excel.Workbook
Dim xlname As Excel.Name
Dim Path As String
'Dim rangeData As Range

Const wdGoToAbsolute As Integer = 1
Const wdGoToLine As Integer = 3

'Set the values of your variables bookmark can't be the same name as range or you will get error


Set wb = ActiveWorkbook
  Path = wb.Path & Application.PathSeparator & "File Name"
  On Error GoTo ErrorHandler

'Create a new Word Session
  Set pappWord = CreateObject("Word.Application")
  On Error GoTo ErrorHandler

'Open document in word
  Set docWord = pappWord.Documents.Add(Path)

'Loop through names in the activeworkbook
  For Each xlname In wb.Names
    'if xlName's name is existing in document then put the value in place of the bookmark
    If docWord.Bookmarks.Exists(xlname.Name) Then
      docWord.Bookmarks(xlname.Name).Range.Text = Range(xlname.Value)
    End If
  Next xlname

'Run the table copy code.  I am copying/pasting my Excel tables with this code.
    
[COLOR="red"]Sheet1.Range("FirstPillar1").CopyPicture 1, 2
        If Not docWord.Bookmarks.Exists("FirstPillar") Then
            MsgBox "Bookmark not available!"
        Else
            Set objRange = docWord.Bookmarks("FirstPillar").Range
            objRange.Paste
            Application.CutCopyMode = False
            
        End If[/COLOR]


'Here is where I copy & Paste a sample Chart (as a picture)


docWord.Bookmarks("PaybackPeriod1").Range.Select
Worksheets("Payback Period").ChartObjects(1).Chart.CopyPicture _
    Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
    pappWord.Selection.Paste


'Turn off copy mode
Application.CutCopyMode = False

'Activate word document
  With pappWord
      .Visible = True
      .ActiveWindow.WindowState = 1
      .Activate
' Optional - Display document on page #1
      .Selection.GoTo What:=wdGoToLine, Which:=wdGoToAbsolute, Count:=1
  End With

'Release the Word object to save memory and exit macro
ErrorExit:
   Set pappWord = Nothing
   Exit Sub

'Error Handling routine
ErrorHandler:
   If Err Then
      MsgBox "Error No: " & Err.Number & ";" & vbNewLine & " o   Verify calculations on the financial results page do not return errors" 
      If Not pappWord Is Nothing Then
        pappWord.Quit False
      End If
      Resume ErrorExit
   End If
Application.ScreenUpdating = True

End Sub

 

[Case_Germany]

Hi,

here's an example. In the zip file is a Word and Excel file. Unzip both into the same directory and try.

A simple example.

 

[brenton]

thanks Case, you sure helped my understanding. Believe it or not after messing around with my original code all i needed to add was

placement:=0

and it was back working again. I don't know why you need it for 2010, but you do. I will be experimenting with the code you provided me because it seemed to run way faster than the copy paste. Thanks again!

docWord.Bookmarks("FirstPillar").Range.Select
Range("FirstPillar1").Copy
    pappWord.Selection.PasteSpecial Link:=False, DataType:=3, [COLOR="Red"]Placement:=0[/COLOR]

 

[Case_Germany]

Hi,

Believe it or not...

I believe... and thanks for your reply because this will also help many others.