VBA Discrepancy

  • Thread starter Thread starter Nikhil
  • Start date Start date
N

Nikhil

Hi
Thanks for help

I created a macro which fixes the position and formatting of a textbox
(which is repeating on all slides)
This is working fine on my machine; when I tested on other machine, position
and formatting remains as I declared in macro — but in slide show the textbox
is jumping.

Not able to rectify why it is jumping when position and other formatting is
same.

Thanks again
Nikhil
 
I am using 2003.
Here is the code

Sub Footer()

Dim LineCount As Integer

On Error Resume Next

With ActiveWindow.Selection.ShapeRange
.Fill.Transparency = 0#
.TextFrame.MarginLeft = 3.6
.TextFrame.MarginRight = 3.6
End With

ActiveWindow.Selection.TextRange.ParagraphFormat.Alignment = ppAlignLeft
ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Font.Size = 10
ActiveWindow.Selection.ShapeRange.Fill.Transparency = 0#
ActiveWindow.Selection.ShapeRange.Width = 711.88
ActiveWindow.Selection.ShapeRange.TextFrame.WordWrap = msoTrue
ActiveWindow.Selection.ShapeRange.TextFrame.autosize =
ppAutoSizeShapeToFitText

ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Paragraphs(Start:=1,
Length:=1).ParagraphFormat.Bullet.Visible = msoFalse
ActiveWindow.Selection.ShapeRange.Shadow.Visible = msoFalse
ActiveWindow.Selection.ShapeRange.Line.Visible = msoFalse
ActiveWindow.Selection.ShapeRange.Fill.Visible = msoFalse
ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Font.Shadow =
msoFalse
ActiveWindow.Selection.TextRange.Font.Color.SchemeColor = ppForeground

With ActiveWindow.Selection.ShapeRange.TextFrame
.HorizontalAnchor = msoAnchorNone
.VerticalAnchor = msoAnchorBottom
End With

With ActiveWindow.Selection.TextRange.ParagraphFormat
.LineRuleWithin = msoTrue
.SpaceWithin = 1
.LineRuleBefore = msoFalse
.SpaceBefore = 0
.LineRuleAfter = msoFalse
.SpaceAfter = 0
End With

LineCount = ActiveWindow.Selection.ShapeRange.TextFrame.TextRange.Lines.Count

If LineCount = 1 Then
With ActiveWindow.Selection.ShapeRange
.Left = 0#
.Top = 512.6
End With

ElseIf LineCount = 2 Then
With ActiveWindow.Selection.ShapeRange
.Left = 0#
.Top = 500.12
End With

ElseIf LineCount = 3 Then
With ActiveWindow.Selection.ShapeRange
.Left = 0#
.Top = 488.2
End With

ElseIf LineCount = 4 Then
With ActiveWindow.Selection.ShapeRange
.Left = 0#
.Top = 476.2
End With

ElseIf LineCount = 5 Then
With ActiveWindow.Selection.ShapeRange
.Left = 0#
.Top = 464.2
End With

ElseIf LineCount = 6 Then
With ActiveWindow.Selection.ShapeRange
.Left = 0#
.Top = 452.2
End With

' ElseIf LineCount > 6 Then
' Call sub longnote

End If

End Sub


Thanks for help
Nikhil
 
I've got to admit I'm a bit confused as to what you are needing to do.

Are you trying to create some sort of footer based on the text in a selected
shape?

If so you might want to work on this route


Dim oTxtBox As Shape
Dim oshp As Shape
Set oshp = ActiveWindow.Selection.ShapeRange(1)
Set oTxtRng = oshp.TextFrame.TextRange
Set oTxtBox = ActiveWindow.Selection.SlideRange(1).Shapes _
..AddTextbox(msoTextOrientationHorizontal, 0, 500, _
ActivePresentation.PageSetup.SlideWidth, 0)
With oTxtBox.TextFrame
..AutoSize = ppAutoSizeShapeToFitText
..WordWrap = True
..MarginLeft = 3.6
..MarginRight = 3.6
..VerticalAnchor = msoAnchorBottom
With .TextRange
..Text = oTxtRng
..Font.Size = 10
..ParagraphFormat.Alignment = ppAlignLeft
End With
End With
oTxtBox.Top = (ActivePresentation.PageSetup.SlideHeight) - oTxtBox.Height
oshp.Delete
Exit Sub
errhandler:
MsgBox "Is something selected"
End Sub

--
Amazing PPT Hints, Tips and Tutorials

http://www.PPTAlchemy.co.uk
http://www.technologytrish.co.uk
email john AT technologytrish.co.uk
 
Back
Top