Question

我想选择3个shapeboxe：，幻灯片标题，子幻灯片标题和源文本。对于第二和第三个选定文本，我将创建一个新文本框并复制并粘贴文本。（我创建这个的原因是我的演示文稿中有一些文本框只是不响应我的VBA代码而只复制并粘贴到新表中，然后我可以跟进格式化。）

我逐步使用F8，直到代码在第3次选择停止 - 然后无法继续。我想可能是第二个文本框创建时，我对第三个文本框的选择不再被认为是选择。我想找到一种方法来创建一个文本框，命名它然后能够在以后调用它以便进行操作。

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

如何使用vba创建文本框，并在以后调用它以执行其他操作

0 个答案: