EXCEL VBA ERROR After (2003 -> 2010 Excel) Upgrd

aluislugo
NewLounger
Posts: 5
Joined: 04 Jan 2011, 19:39

EXCEL VBA ERROR After (2003 -> 2010 Excel) Upgrd

Post by aluislugo »

Hi my company recently upgraded us from 2003 to 2010 Excel. Now as a result none of our macros work. Below is the Error and the entire. If someone could please explain why this is happening and what the solution is would be greatly appreciated.



VBA CODE ERROR:
With PPPres.SlideMaster.Shapes("Rectangle 2").TextFrame.TextRange


ENTIRE CODE:

Code: Select all

Global oPPTApp As PowerPoint.application
Global PPPres As PowerPoint.Presentation
'Global slidedate As Integer

Sub ToPptWithDate()
Call ToPowerPoint(1)
End Sub

Sub ToPptWithoutDate()
Call ToPowerPoint(2)
End Sub


Sub ToPowerPoint(slidedate As Integer)
Dim mess As String
Dim rngNewRange As Excel.Range

' Catch application window title to later activate Excel again
apptitle = application.Caption

Call CreatePPPres(slidedate)

oPPTApp.Visible = msoTrue

'Close
'ThisWorkbook.Sheets("B2B_Restr").Outline.ShowLevels ColumnLevels:=1

'Walk through all pages
For Each sr In ThisWorkbook.Sheets
shname = sr.Name
sRange = Null
stitle = Null
ToPPT = 0
Select Case UCase(sr.Name)
Case UCase("Menu"), "VBA", UCase("Data"), UCase("DataTar"), UCase("Dataact")
ToPPT = 0
Case Else
sRange = "PPR"
stitle = "PPT"

'Test if the ranges are defined
On Error Resume Next
testrange = IsEmpty(ThisWorkbook.Sheets(shname).Range(stitle))
testrange = IsEmpty(ThisWorkbook.Sheets(shname).Range(sRange))
If Err.Number = 0 Then
ToPPT = 1
Else
ToPPT = 0
mess = mess + Chr(13) + " " + shname + " was skipped - missed range or title"
End If
On Error GoTo 0
End Select

If UCase(sr.Name) = "EQSUBS" Then
' Call createappdpage
End If

If sr.Visible = False Then
ToPPT = 0
End If


If ToPPT = 1 Then
' Set rngNewRange to the collection of cells in the active Excel
' workbook and active sheet.
ThisWorkbook.Sheets(shname).Activate
application.Goto Reference:=sRange
Set rngNewRange = ThisWorkbook.Sheets(shname).Range(sRange)

' Select the range then copy it.
rngNewRange.Select
'rngNewRange.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
rngNewRange.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ThisWorkbook.Sheets("VBA").Select
Range("B12").Select

ActiveSheet.PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False _
, DisplayAsIcon:=False
pictname = (Selection.Name)

'Fix size of object
y = 410 / Selection.ShapeRange.Height
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = y * Selection.ShapeRange.Height
Selection.ShapeRange.Width = y * Selection.ShapeRange.Width

If Selection.ShapeRange.Width > 690 Then
y = 690 / Selection.ShapeRange.Width
Selection.ShapeRange.Height = y * Selection.ShapeRange.Height
Selection.ShapeRange.Width = y * Selection.ShapeRange.Width
End If

ThisWorkbook.Sheets("VBA").Shapes(pictname).Copy

Set ppslide = PPPres.Slides.Add(PPPres.Slides.Count + 1, ppLayoutTitleOnly)

' Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
'Paste the range and align
With ppslide.Shapes.Paste
.Align msoAlignCenters, True
.Align msoAlignMiddles, True
End With
ppslide.Shapes("Picture 3").IncrementTop 32#

' Add title to slide
ppslide.Shapes("Rectangle 2").TextFrame.TextRange.Text = _
ThisWorkbook.Sheets(shname).Range(stitle).Value + _
Chr(13) + ThisWorkbook.Sheets("Menu").Range("arearegion").Value

'delete picture in excel
Sheets("VBA").Shapes(pictname).Delete

End If
Next
'oPPTApp.Activewindow.ViewType = ppViewSlide
' Clean up
'PPPres.SlideShowSettings.Run

Set PPPres = Nothing
Set ppslide = Nothing
Set oPPApp = Nothing
' Select range A1 in all sheets
application.ScreenUpdating = False
For Each sr In ThisWorkbook.Sheets
Sheet = sr.Name
If sr.Visible = False Then
Else
ThisWorkbook.Sheets(Sheet).Select
application.Goto Reference:=Range("A1")
End If

Next sr
application.ScreenUpdating = True

'Let user know results
'ThisWorkbook.Sheets("B2B_Restr").Outline.ShowLevels ColumnLevels:=2
'ThisWorkbook.Sheets("Menu").Select
AppActivate apptitle
If Len(mess) > 0 Then
MsgBox ("Ready " & mess)
Else
MsgBox Chr(13) + " Successfully copied to PowerPoint!" + Chr(13)
oPPTApp.Activewindow.View.GotoSlide Index:=1
'application.ActivateMicrosoftApp xlMicrosoftPowerPoint
End If
End Sub


Sub CreatePPPres(slidedate As Integer)

Set oPPTApp = CreateObject("PowerPoint.Application")
Set PPPres = oPPTApp.Presentations.Add

oPPTApp.Visible = msoTrue

oPPTApp.Activewindow.ViewType = ppViewSlideMaster
'--------------------
'Setup the master
With oPPTApp.ActivePresentation.SlideMaster.HeadersFooters
.Footer.Visible = msoTrue
.SlideNumber.Visible = msoTrue
End With

With PPPres.SlideMaster.Shapes("Rectangle 2").TextFrame.TextRange
.Font.Bold = msoTrue
.Font.Italic = msoTrue
.Font.Size = 24
.Font.Name = "Arial"
.ParagraphFormat.Alignment = ppAlignLeft
End With

PPPres.SlideMaster.Shapes("Rectangle 2").Select
With PPPres.Windows(1).Selection.ShapeRange
.Top = 0
.Left = 20

.ScaleHeight 0.8, msoFalse, msoScaleFromTopLeft
.ScaleWidth 0.88, msoFalse, msoScaleFromTopLeft
End With

PPPres.SlideMaster.Shapes("Rectangle 5").Select
With PPPres.Windows(1).Selection.ShapeRange
.Height = 30
.Width = 600
.Left = 20.75
End With

With PPPres.Windows(1).Selection.ShapeRange.TextFrame.TextRange
.Font.Size = 8
.Font.Name = "Arial"
End With

PPPres.SlideMaster.Shapes("Rectangle 5").TextFrame.TextRange.Text = _
"Proprietary and Confidential - Not for Disclosure Outside Verizon Wireless"

oPPTApp.Activewindow.Selection.ShapeRange.ScaleHeight 0.6, msoFalse, msoScaleFromTopLeft
With oPPTApp.Activewindow.Selection.ShapeRange
.IncrementLeft 39.25
.IncrementTop 30#
End With

PPPres.SlideMaster.Shapes("Rectangle 6").Select
With PPPres.Windows(1).Selection.ShapeRange.TextFrame.TextRange
.Font.Size = 8
.Font.Name = "Arial"
End With

oPPTApp.Activewindow.Selection.ShapeRange.ScaleHeight 0.5, msoFalse, msoScaleFromTopLeft
With oPPTApp.Activewindow.Selection.ShapeRange
.IncrementLeft 36#
.IncrementTop 30#
End With

'Delete rectangle 3
PPPres.SlideMaster.Shapes("Rectangle 3").Select
oPPTApp.Activewindow.Selection.ShapeRange.Delete

If slidedate = 1 Then
PPPres.SlideMaster.Shapes("Rectangle 4").Select
With PPPres.Windows(1).Selection.ShapeRange.TextFrame.TextRange
.Font.Size = 8
.Font.Name = "Arial"
.Characters(Start:=1, Length:=21).InsertDateTime DateTimeFormat:=ppDateTimeMMddyyHmm, InsertAsField:=msoTrue
End With
oPPTApp.Activewindow.Selection.ShapeRange.ScaleHeight 0.5, msoFalse, msoScaleFromTopLeft
With oPPTApp.Activewindow.Selection.ShapeRange
'.IncrementLeft 36#
.IncrementTop 30#
End With
Else
PPPres.SlideMaster.Shapes("Rectangle 4").Select
oPPTApp.Activewindow.Selection.ShapeRange.Delete
End If

'Add lines
PPPres.SlideMaster.Shapes.AddLine(0#, 74#, 720#, 74#).Select
With oPPTApp.Activewindow.Selection.ShapeRange
.Line.Weight = 5.5
.Line.Visible = msoTrue
.Line.Style = msoLineSingle
.Line.ForeColor.SchemeColor = ppShadow
End With

PPPres.SlideMaster.Shapes.AddLine(0#, 80#, 720#, 80#).Select
With oPPTApp.Activewindow.Selection.ShapeRange
.Line.Weight = 2.5
.Line.Visible = msoTrue
.Line.Style = msoLineSingle
.Line.ForeColor.SchemeColor = ppShadow
End With

'Copy in logo
ThisWorkbook.Sheets("VBA").Shapes("Picture 1").Copy

With PPPres.SlideMaster.Shapes.Paste
.Align msoAlignCenters, True
.Align msoAlignMiddles, True
End With

PPPres.SlideMaster.Shapes("Picture 9").Select
With oPPTApp.Activewindow.Selection.ShapeRange
.IncrementLeft 295.5
.IncrementTop -234.38
End With
oPPTApp.Activewindow.Selection.ShapeRange.IncrementTop 10#

'Close master view:
oPPTApp.Activewindow.ViewType = ppViewSlide
'-------------
'Add slide 1
Set ppslide = PPPres.Slides.Add(PPPres.Slides.Count + 1, ppLayoutText)

ppslide.Shapes("Rectangle 3").Select
oPPTApp.Activewindow.Selection.ShapeRange.TextFrame.TextRange.Characters(Start:=1, Length:=1).Select
With oPPTApp.Activewindow.Selection.TextRange
With .Font
.Name = "Arial"
.Size = 32
.Bold = msoTrue
.Italic = msoTrue
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color.SchemeColor = ppForeground
End With
With .ParagraphFormat
.Alignment = ppAlignCenter
.LineRuleWithin = msoTrue
.SpaceWithin = 1.5
.Bullet.Visible = msoFalse
End With
.Text = "Verizon Wireless" + _
Chr$(CharCode:=13) + ThisWorkbook.Sheets("VBA").Range("C9").Value + Chr(13) + ThisWorkbook.Sheets("Menu").Range("arearegion").Value + Chr(13) + _
ThisWorkbook.Sheets("VBA").Range("C10").Value
End With

ppslide.Shapes("Rectangle 2").Select
oPPTApp.Activewindow.Selection.ShapeRange.Delete
'-----------
''Slide 2:
'Set ppslide = PPPres.Slides.Add(PPPres.Slides.Count + 1, ppLayoutText)
'
' ppslide.Shapes("Rectangle 2").TextFrame.TextRange.Text = _
' "Agenda" + Chr(13) + ThisWorkbook.Sheets("Menu").Range("arearegion").Value
'
'For r = 1 To Worksheets("VBA").Range("Agenda").CurrentRegion.Rows.Count
'If r = 1 Then
' aaa = Worksheets("VBA").Range("Agenda").item®.Value
'Else
'aaa = aaa + Chr(13) + Worksheets("VBA").Range("Agenda").item®.Value
'End If
'Next r
'
'ppslide.Shapes("Rectangle 3").TextFrame.TextRange.Text = aaa
'
' With ppslide.Shapes("Rectangle 3").TextFrame.TextRange
' .Font.Size = 18
' .Font.Italic = msoTrue
' .Font.Name = "Arial"
' End With
'
' oPPTApp.Activewindow.View.GotoSlide Index:=2
' ppslide.Shapes("Rectangle 3").Select
' oPPTApp.Activewindow.Selection.ShapeRange.TextFrame.TextRange.Select
' With oPPTApp.Activewindow.Selection.TextRange.ParagraphFormat
' .LineRuleWithin = msoTrue
' .SpaceWithin = 1.5
' .LineRuleBefore = msoTrue
' .SpaceBefore = 0.2
' .LineRuleAfter = msoFalse
' .SpaceAfter = 0
' With .Bullet
' .Visible = msoTrue
' .UseTextColor = msoTrue
' .Font.Name = "Wingdings"
' .Character = 167
' End With
' End With
' With oPPTApp.Activewindow.Selection
' .ShapeRange.TextFrame.AutoSize = ppAutoSizeShapeToFitText
' .ShapeRange.Left = 70
' .ShapeRange.Top = 140
' .TextRange.Font.Bold = msoTrue
' End With

' oPPTApp.Activewindow.Selection.ShapeRange.IncrementTop -48#
' oPPTApp.Activewindow.Selection.ShapeRange.ScaleHeight 1.15, msoFalse, msoScaleFromTopLeft
oPPTApp.Activewindow.Selection.Unselect

'Activewindow.Selection.SlideRange.Shapes("Rectangle 3").Select
' Activewindow.Selection.ShapeRange.TextFrame.TextRange.Select
' Activewindow.Selection.ShapeRange.TextFrame.AutoSize = ppAutoSizeShapeToFitText
' With Activewindow.Selection.ShapeRange
' .Left = 70
' .Top = 140
' End With
' Activewindow.Selection.ShapeRange.Top = 143.88
' Activewindow.Selection.TextRange.Font.Bold = msoTrue
End Sub


Sub createappdpage()

Set ppslide = PPPres.Slides.Add(PPPres.Slides.Count + 1, ppLayoutText)

With ppslide.Shapes("Rectangle 3").TextFrame.TextRange
With .Font
.Name = "Arial"
.Size = 32
.Bold = msoTrue
.Italic = msoTrue
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color.SchemeColor = ppForeground
End With
With .ParagraphFormat
.Alignment = ppAlignCenter
.LineRuleWithin = msoTrue
.SpaceWithin = 1.5
.Bullet.Visible = msoFalse
End With
.Text = Chr(13) + "Appendix"
End With

ppslide.Shapes("Rectangle 2").Delete

End Sub
Last edited by HansV on 06 Jan 2011, 14:20, edited 1 time in total.
Reason: to place code in [code]...[/code] tags

User avatar
StuartR
Administrator
Posts: 12577
Joined: 16 Jan 2010, 15:49
Location: London, Europe

Re: EXCEL VBA ERROR After (2003 -> 2010 Excel) Upgrd

Post by StuartR »

Can you set a breakpoint on the line
PPPres.SlideMaster.Shapes("Rectangle 2").TextFrame.TextRange
Then when the code stops at the breakpoint can you see what output you get from the following commands in the immediate window.
? PPPres.SlideMaster.Shapes.Count
? PPPres.SlideMaster.Shapes("Rectangle 2").HasTextFrame
StuartR


aluislugo
NewLounger
Posts: 5
Joined: 04 Jan 2011, 19:39

Re: EXCEL VBA ERROR After (2003 -> 2010 Excel) Upgrd

Post by aluislugo »

yes here's my output however.
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: EXCEL VBA ERROR After (2003 -> 2010 Excel) Upgrd

Post by HansV »

Welcome to Eileen's Lounge!

When I run your code and get the error message, the slide master has 5 shapes:

Title Placeholder 1 (the slide title)
Text Placeholder 2 (the bulleted text area)
Date Placeholder 3 (in the footer)
Footer Placeholder 4 (ditto)
Slide Number Placeholder 5 (ditto)

As you see, there are no shapes "Rectangle 1", "Rectangle 2" etc.
As far as I can tell, your Shapes("Rectangle 2") corresponds to the first shape, i.e. Shapes(1), Shapes("Rectangle 3") to Shapes(2) etc.
Best wishes,
Hans

aluislugo
NewLounger
Posts: 5
Joined: 04 Jan 2011, 19:39

Re: EXCEL VBA ERROR After (2003 -> 2010 Excel) Upgrd

Post by aluislugo »

Hi Hans this almost worked..now I am stuck at shapes "picture 9". What is the corresponding shape for picture 9? also there is a shapes ("picture 1") but I am not sure if this work or not. I'd probably want to know what is the corresponding shape for this as well.

Thank you.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: EXCEL VBA ERROR After (2003 -> 2010 Excel) Upgrd

Post by HansV »

Try changing

Code: Select all

  With PPPres.SlideMaster.Shapes.Paste
    .Align msoAlignCenters, True
    .Align msoAlignMiddles, True
  End With

  PPPres.SlideMaster.Shapes("Picture 9").Select
  With oPPTApp.Activewindow.Selection.ShapeRange
    .IncrementLeft 295.5
    .IncrementTop -234.38
  End With
to

Code: Select all

  With PPPres.SlideMaster.Shapes.Paste
    .Align msoAlignCenters, True
    .Align msoAlignMiddles, True
    .IncrementLeft 295.5
    .IncrementTop -234.38
  End With
Best wishes,
Hans

aluislugo
NewLounger
Posts: 5
Joined: 04 Jan 2011, 19:39

Re: EXCEL VBA ERROR After (2003 -> 2010 Excel) Upgrd

Post by aluislugo »

Hi Hans that worked, but need help with "picture 1" and "picture 3"

Thank you

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: EXCEL VBA ERROR After (2003 -> 2010 Excel) Upgrd

Post by HansV »

Change

Code: Select all

  With PPPres.SlideMaster.Shapes.Paste
    .Align msoAlignCenters, True
    .Align msoAlignMiddles, True
  End With

  PPPres.SlideMaster.Shapes("Picture 9").Select
  With oPPTApp.Activewindow.Selection.ShapeRange
    .IncrementLeft 295.5
    .IncrementTop -234.38
  End With
  oPPTApp.Activewindow.Selection.ShapeRange.IncrementTop 10#
to

Code: Select all

  With PPPres.SlideMaster.Shapes.Paste
    .Align msoAlignCenters, True
    .Align msoAlignMiddles, True
    .IncrementLeft 295.5
    .IncrementTop -224.38
  End With
Picture 1 is a shape on the VBA sheet in the workbook containing the code:

ThisWorkbook.Sheets("VBA").Shapes("Picture 1").Copy

So look for a picture on the VBA sheet, select it and look at the name in the address box on the left hand side of the formula bar.
Best wishes,
Hans

aluislugo
NewLounger
Posts: 5
Joined: 04 Jan 2011, 19:39

Re: EXCEL VBA ERROR After (2003 -> 2010 Excel) Upgrd

Post by aluislugo »

Hi Hans, yes you are right Picture 1 does exist and therefore should not cause an error. However Picture 3 is still causing an error. How can I modify the code to fix Picture 3? BTW I did a search for objects and I did not find a picture 3.

Thank you.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: EXCEL VBA ERROR After (2003 -> 2010 Excel) Upgrd

Post by HansV »

Change

Code: Select all

'Paste the range and align
With ppslide.Shapes.Paste
.Align msoAlignCenters, True
.Align msoAlignMiddles, True
End With
ppslide.Shapes("Picture 3").IncrementTop 32#
to

Code: Select all

'Paste the range and align
  With ppslide.Shapes.Paste
    .Align msoAlignCenters, True
    .Align msoAlignMiddles, True
    .IncrementTop 32#
  End With
As you see, in the various replacements I have posted in this thread, the names Picture 3 and Picture 9 aren't used anymore - everything is done within the With ... End With blocks. If you need to add more pictures later on, you can follow the same framework:

Code: Select all

  With ppSlide.Shapes.Paste
    ' set properties here
    ...
    ...
  End With
This avoids having to know the name of the pasted picture.
Best wishes,
Hans