Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Dim sld As slide, sh As Shape, cursh As Shape, cursh2 As Shape
- Set sh = ActiveWindow.Selection.ShapeRange(1)
- 'Do something
- Set cursh = ActiveWindow.Selection.ShapeRange(2)
- cursh.textFrame.TextRange.Copy
- Set sld = Application.ActiveWindow.View.slide
- Set sh = sld.shapes.AddShape(Type:=msoShapeRectangle, _
- Left:=50, Top:=50, Width:=500, Height:=50)
- sh.textFrame.TextRange.PasteSpecial ppPasteText
- sh.Line.Visible = msoFalse
- cursh.Delete
- Set cursh2 = ActiveWindow.Selection.ShapeRange(3)
- cursh.textFrame.TextRange.Copy
- Set sld = Application.ActiveWindow.View.slide
- Set sh = sld.shapes.AddShape(Type:=msoShapeRectangle, _
- Left:=50, Top:=50, Width:=500, Height:=50)
- sh.textFrame.TextRange.PasteSpecial ppPasteText
- sh.Line.Visible = msoFalse
- cursh.Delete
- Sub Select_SlideTitle_Only2()
- 'Note: Set sh = ActiveWindow.Selection.ShapeRange(1)(To use for selecting active shape
- Dim sld As slide, sh As Shape, cursh As Shape, cursh2 As Shape
- Dim Tbl As Table, myRow As Long, myCol As Long
- Dim myWidthST As Long, myHeightST As Long, myTopST As Long, myLeftST As Long, myFontST As String, myCNFontST As String, myFontsizeST As Long, myFontcolorST As String, _
- myMarginST As Long, myShapenameST As String, myVerticalAlignmentST As String, myBulletST As String, myBoldST As String, myAlignmentST As String
- 'Define for Message
- Dim myWidthMT As Long, myHeightMT As Long, myTopMT As Long, myLeftMT As Long, myFontMT As String, myCNFontMT As String, myFontsizeMT As Long, myFontcolorMT As String, _
- myMarginMT As Long, myShapenameMT As String, myVerticalAlignmentMT As String, myBulletMT As String, myBoldMT As String, myAlignmentMT As String
- 'Select textbox, place them on itx designated location and name it "Messagebox" with margin as zero
- 'Define for source formatting
- Dim myWidthS As Long, myHeightS As Long, myTopS As Long, myLeftS As Long, myFontS As String, myCNFontS As String, myFontsizeS As Long, myFontcolorS As String, _
- myMarginS As Long, myShapenameS As String, myVerticalAlignmentS As String, myBulletS As String, myBoldS As String, myAlignmentS As String
- 'Select textbox and turn the textbox to Frutiger 55 Roman formatting with margin all around as zero
- myFontST = "Frutiger 45 Light"
- myFontsizeST = 28
- myWidthST = 723.6
- myHeightST = 74.16
- myTopST = 0.0002362005
- myLeftST = 33.12
- myMarginST = 0
- myShapenameST = "PAGE HEADING"
- myVerticalAlignmentST = msoAnchorBottom
- Dim x As Long
- x = InputBox("Please enter a number for format. 1 = Title only, 2 = Title + Message, 3 = Title + Message + Source(Left Btm, 4 = Slide title + Message + Source(Center bottom)", "Gerald Slide Title Formatting")
- Select Case x
- Case Is = 1
- Set sh = ActiveWindow.Selection.ShapeRange(1)
- With sh
- .Width = myWidthST
- .Height = myHeightST
- .Top = myTopST
- .Left = myLeftST
- .Fill.Visible = msoFalse
- .Name = myShapenameST
- End With
- With sh.textFrame.TextRange.ParagraphFormat
- .Alignment = ppAlignLeft
- .Bullet = msoFalse
- End With
- With sh.textFrame.TextRange.Font
- .Name = myFontST
- .Size = myFontsizeST
- .Bold = msoFalse
- End With
- With sh.textFrame
- .MarginLeft = myMarginST
- .MarginRight = myMarginST
- .MarginBottom = myMarginST
- .MarginTop = myMarginST
- .VerticalAnchor = myVerticalAlignmentST
- End With
- Case Is = 2
- 'Slide Title
- myFontST = "Frutiger 45 Light"
- myFontsizeST = 28
- myWidthST = 723.6
- myHeightST = 74.16
- myTopST = 0.0002362005
- myLeftST = 33.12
- myMarginST = 0
- myShapenameST = "PAGE HEADING"
- myVerticalAlignmentST = msoAnchorBottom
- Set sh = ActiveWindow.Selection.ShapeRange(1)
- With sh
- .Width = myWidthST
- .Height = myHeightST
- .Top = myTopST
- .Left = myLeftST
- .Fill.Visible = msoFalse
- .Name = myShapenameST
- End With
- With sh.textFrame.TextRange.ParagraphFormat
- .Alignment = ppAlignLeft
- .Bullet = msoFalse
- End With
- With sh.textFrame.TextRange.Font
- .Name = myFontST
- .Size = myFontsizeST
- .Bold = msoFalse
- End With
- With sh.textFrame
- .MarginLeft = myMarginST
- .MarginRight = myMarginST
- .MarginBottom = myMarginST
- .MarginTop = myMarginST
- .VerticalAnchor = myVerticalAlignmentST
- End With
- 'Message Text
- myFontMT = "UBSHeadline"
- myFontsizeMT = 14
- myFontcolorMT = RGB(70, 71, 73)
- myWidthMT = 723.6
- myHeightMT = 21.6
- myTopMT = 85.5
- myLeftMT = 33.12
- myBoldMT = msoFalse
- myMarginMT = 0
- myShapenameMT = "MESSAGE TEXT"
- myVerticalAlignmentMT = msoAnchorTop
- Set cursh = ActiveWindow.Selection.ShapeRange(2)
- cursh.textFrame.TextRange.Copy
- Set sld = Application.ActiveWindow.View.slide
- Set sh = sld.shapes.AddShape(Type:=msoShapeRectangle, _
- Left:=50, Top:=50, Width:=150, Height:=50) 'this shape will now be called sh
- sh.textFrame.TextRange.PasteSpecial ppPasteText
- sh.Line.Visible = msoFalse 'remove border
- cursh.Delete 'Delete the selected shape
- With sh
- .Width = myWidthMT
- .Height = myHeightMT
- .Top = myTopMT
- .Left = myLeftMT
- .Name = myShapenameMT
- .Fill.Visible = msoFalse
- End With
- With sh.textFrame.TextRange.ParagraphFormat
- .Alignment = ppAlignLeft
- .Bullet = msoFalse
- End With
- With sh.textFrame.TextRange.Font
- .Name = myFontMT
- .Size = myFontsizeMT
- .Bold = myBoldMT
- .Color.RGB = myFontcolorMT
- End With
- With sh.textFrame
- .MarginLeft = myMarginMT
- .MarginRight = myMarginMT
- .MarginBottom = myMarginMT
- .MarginTop = myMarginMT
- .VerticalAnchor = myVerticalAlignmentMT
- End With
- Case Is = 3
- 'Slide Title
- myFontST = "Frutiger 45 Light"
- myFontsizeST = 28
- myWidthST = 723.6
- myHeightST = 74.16
- myTopST = 0.0002362005
- myLeftST = 33.12
- myMarginST = 0
- myShapenameST = "PAGE HEADING"
- myVerticalAlignmentST = msoAnchorBottom
- Set sh = ActiveWindow.Selection.ShapeRange(1)
- With sh
- .Width = myWidthST
- .Height = myHeightST
- .Top = myTopST
- .Left = myLeftST
- .Fill.Visible = msoFalse
- .Name = myShapenameST
- End With
- With sh.textFrame.TextRange.ParagraphFormat
- .Alignment = ppAlignLeft
- .Bullet = msoFalse
- End With
- With sh.textFrame.TextRange.Font
- .Name = myFontST
- .Size = myFontsizeST
- .Bold = msoFalse
- End With
- With sh.textFrame
- .MarginLeft = myMarginST
- .MarginRight = myMarginST
- .MarginBottom = myMarginST
- .MarginTop = myMarginST
- .VerticalAnchor = myVerticalAlignmentST
- End With
- 'Message Text
- myFontMT = "UBSHeadline"
- myFontsizeMT = 14
- myFontcolorMT = RGB(70, 71, 73)
- myWidthMT = 723.6
- myHeightMT = 21.6
- myTopMT = 85.5
- myLeftMT = 33.12
- myBoldMT = msoFalse
- myMarginMT = 0
- myShapenameMT = "MESSAGE TEXT"
- myVerticalAlignmentMT = msoAnchorTop
- Set cursh = ActiveWindow.Selection.ShapeRange(2)
- cursh.textFrame.TextRange.Copy
- Set sld = Application.ActiveWindow.View.slide
- Set sh = sld.shapes.AddShape(Type:=msoShapeRectangle, _
- Left:=50, Top:=50, Width:=150, Height:=50) 'this shape will now be called sh
- sh.textFrame.TextRange.PasteSpecial ppPasteText
- sh.Line.Visible = msoFalse 'remove border
- With sh
- .Width = myWidthMT
- .Height = myHeightMT
- .Top = myTopMT
- .Left = myLeftMT
- .Name = myShapenameMT
- .Fill.Visible = msoFalse
- End With
- With sh.textFrame.TextRange.ParagraphFormat
- .Alignment = ppAlignLeft
- .Bullet = msoFalse
- End With
- With sh.textFrame.TextRange.Font
- .Name = myFontMT
- .Size = myFontsizeMT
- .Bold = myBoldMT
- .Color.RGB = myFontcolorMT
- End With
- With sh.textFrame
- .MarginLeft = myMarginMT
- .MarginRight = myMarginMT
- .MarginBottom = myMarginMT
- .MarginTop = myMarginMT
- .VerticalAnchor = myVerticalAlignmentMT
- End With
- 'Source Left full
- myFontsizeS = 8
- myWidthS = 723.6
- myHeightS = 15.12
- myTopS = 505.38
- myLeftS = 33.12
- myMarginS = 0
- myAlignmentS = ppAlignLeft
- myBulletS = msoFalse
- myVerticalAlignmentS = msoAnchorBottom
- myShapenameS = "SourceText"
- myFontcolorS = RGB(0, 0, 0)
- Set cursh2 = ActiveWindow.Selection.ShapeRange(3)
- cursh2.textFrame.TextRange.Copy
- Set sld = Application.ActiveWindow.View.slide
- Set sh = sld.shapes.AddShape(Type:=msoShapeRectangle, _
- Left:=50, Top:=50, Width:=150, Height:=50) 'this shape will now be called sh
- sh.textFrame.TextRange.PasteSpecial ppPasteText
- sh.Line.Visible = msoFalse 'remove border
- cursh2.Delete 'Delete the selected shape
- With sh
- .Width = myWidth
- .Height = myHeight
- .Top = myTop
- .Left = myLeft
- .Fill.Visible = msoFalse
- .Name = myShapename
- End With
- With sh.textFrame.TextRange.ParagraphFormat
- .Alignment = myAlignment
- .Bullet = myBullet
- End With
- With sh.textFrame.TextRange.Font
- .Name = myFont
- .Size = myFontsize
- .Bold = msoFalse
- .Color.RGB = myFontcolor
- End With
- With sh.textFrame
- .MarginLeft = myMargin: .MarginRight = myMargin: .MarginBottom = myMargin: .MarginTop = myMargin
- .VerticalAnchor = myVerticalAlignment
- End With
- With sh.textFrame.Ruler
- .TabStops.Add ppTabStopLeft, 30
- .TabStops.Add ppTabStopLeft, 13
- End With
- Case Is = 4
- myFontST = "Frutiger 45 Light"
- myFontsizeST = 28
- myWidthST = 723.6
- myHeightST = 74.16
- myTopST = 0.0002362005
- myLeftST = 33.12
- myMarginST = 0
- myShapenameST = "PAGE HEADING"
- myVerticalAlignmentST = msoAnchorBottom
- Set sh = ActiveWindow.Selection.ShapeRange(1)
- With sh
- .Width = myWidthST
- .Height = myHeightST
- .Top = myTopST
- .Left = myLeftST
- .Fill.Visible = msoFalse
- .Name = myShapenameST
- End With
- With sh.textFrame.TextRange.ParagraphFormat
- .Alignment = ppAlignLeft
- .Bullet = msoFalse
- End With
- With sh.textFrame.TextRange.Font
- .Name = myFontST
- .Size = myFontsizeST
- .Bold = msoFalse
- End With
- With sh.textFrame
- .MarginLeft = myMarginST
- .MarginRight = myMarginST
- .MarginBottom = myMarginST
- .MarginTop = myMarginST
- .VerticalAnchor = myVerticalAlignmentST
- End With
- 'Message Text
- myFontMT = "UBSHeadline"
- myFontsizeMT = 14
- myFontcolorMT = RGB(70, 71, 73)
- myWidthMT = 723.6
- myHeightMT = 21.6
- myTopMT = 85.5
- myLeftMT = 33.12
- myBoldMT = msoFalse
- myMarginMT = 0
- myShapenameMT = "MESSAGE TEXT"
- myVerticalAlignmentMT = msoAnchorTop
- Set cursh = ActiveWindow.Selection.ShapeRange(2)
- cursh.textFrame.TextRange.Copy
- Set sld = Application.ActiveWindow.View.slide
- Set sh = sld.shapes.AddShape(Type:=msoShapeRectangle, _
- Left:=50, Top:=50, Width:=150, Height:=50) 'this shape will now be called sh
- sh.textFrame.TextRange.PasteSpecial ppPasteText
- sh.Line.Visible = msoFalse 'remove border
- cursh.Delete 'Delete the selected shape
- With sh
- .Width = myWidthMT
- .Height = myHeightMT
- .Top = myTopMT
- .Left = myLeftMT
- .Name = myShapenameMT
- .Fill.Visible = msoFalse
- End With
- With sh.textFrame.TextRange.ParagraphFormat
- .Alignment = ppAlignLeft
- .Bullet = msoFalse
- End With
- With sh.textFrame.TextRange.Font
- .Name = myFontMT
- .Size = myFontsizeMT
- .Bold = myBoldMT
- .Color.RGB = myFontcolorMT
- End With
- With sh.textFrame
- .MarginLeft = myMarginMT
- .MarginRight = myMarginMT
- .MarginBottom = myMarginMT
- .MarginTop = myMarginMT
- .VerticalAnchor = myVerticalAlignmentMT
- End With
- 'Source Bottom center full
- myFontsizeS = 8
- myFontcolorS = RGB(0, 0, 0)
- myWidthS = 617.47
- myHeightS = 19.17
- myTopS = 551.9857
- myLeftS = 125.0239
- myMarginS = 0
- myAlignmentS = ppAlignLeft
- myBulletS = msoFalse
- myVerticalAlignmentS = msoAnchorMiddle
- myShapenameS = "SourceText"
- myFontcolorS = RGB(0, 0, 0)
- Set cursh2 = ActiveWindow.Selection.ShapeRange(3)
- cursh2.textFrame.TextRange.Copy
- Set sld = Application.ActiveWindow.View.slide
- Set sh = sld.shapes.AddShape(Type:=msoShapeRectangle, _
- Left:=50, Top:=50, Width:=150, Height:=50) 'this shape will now be called sh
- sh.textFrame.TextRange.PasteSpecial ppPasteText
- sh.Line.Visible = msoFalse 'remove border
- cursh2.Delete 'Delete the selected shape
- With sh
- .Width = myWidth
- .Height = myHeight
- .Top = myTop
- .Left = myLeft
- .Fill.Visible = msoFalse
- .Name = myShapename
- End With
- With sh.textFrame.TextRange.ParagraphFormat
- .Alignment = myAlignment
- .Bullet = myBullet
- End With
- With sh.textFrame.TextRange.Font
- .Name = myFont
- .Size = myFontsize
- .Color.RGB = myFontcolor
- End With
- With sh.textFrame
- .MarginLeft = myMargin: .MarginRight = myMargin: .MarginBottom = myMargin: .MarginTop = myMargin
- .VerticalAnchor = myVerticalAlignment
- End With
- With sh.textFrame.Ruler
- .TabStops.Add ppTabStopLeft, 30
- .TabStops.Add ppTabStopLeft, 13
- End With
- Case Else
- MsgBox ("You have not selected any shape, please try again")
- End Select
- End Sub
Add Comment
Please, Sign In to add comment