Question

我在Excel中有一些VBA代码可以将一些文本复制到powerpoint。

复制有效，但我想给文本框添加一种颜色（填充和放大）。

我该怎么做？

我的代码

Sub ExcelRangeToPowerPoint()


Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim i, x, QuestionType, Counter As Integer
Dim oSld As Slide
Dim oShp As Shape
'Dim Question, Answer1, Answer2, Answer3, Answer4 As Text


'Create an Instance of PowerPoint
  On Error Resume Next

    'Is PowerPoint already opened?
     Set PowerPointApp = GetObject(class:="PowerPoint.Application")

    'Clear the error between errors
      Err.Clear

    'If PowerPoint is not already open then open PowerPoint
     If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")

    'Handle if the PowerPoint Application is not found
      If Err.Number = 429 Then
        MsgBox "PowerPoint could not be found, aborting."
        Exit Sub
      End If

  'On Error GoTo 0

'Optimize Code
  Application.ScreenUpdating = False

'Create a New Presentation
  Set myPresentation = PowerPointApp.Presentations.Add



 'define nbr of questions
  Counter = ThisWorkbook.ActiveSheet.Range("A1").Value

'define x to have the correct linenr
    x = 3
 For i = 1 To Counter
    'Add a slide to the Presentation
    Set mySlide = myPresentation.Slides.Add(i, 12) '11 = ppLayoutBlank

    World = ThisWorkbook.ActiveSheet.Range("B" & x).Value
    Question = ThisWorkbook.ActiveSheet.Range("C" & x).Value
    Answer1 = ThisWorkbook.ActiveSheet.Range("D" & x).Value
    Answer2 = ThisWorkbook.ActiveSheet.Range("E" & x).Value
    Answer3 = ThisWorkbook.ActiveSheet.Range("F" & x).Value
    Answer4 = ThisWorkbook.ActiveSheet.Range("G" & x).Value
    Feedback1 = ThisWorkbook.ActiveSheet.Range("L" & x).Value
    Feedback2 = ThisWorkbook.ActiveSheet.Range("M" & x).Value
    Feedback3 = ThisWorkbook.ActiveSheet.Range("N" & x).Value

    mySlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=20, Top:=10, Width:=850, Height:=10).TextFrame.TextRange.Text = World
    mySlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=20, Top:=50, Width:=850, Height:=50).TextFrame.TextRange.Text = Question
    mySlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=20, Top:=100, Width:=850, Height:=50).TextFrame.TextRange.Text = Answer1
    mySlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=20, Top:=170, Width:=850, Height:=50).TextFrame.TextRange.Text = Answer2
    mySlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=20, Top:=240, Width:=850, Height:=50).TextFrame.TextRange.Text = Answer3
    mySlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=20, Top:=310, Width:=850, Height:=50).TextFrame.TextRange.Text = Answer4
    mySlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=50, Top:=400, Width:=200, Height:=50).TextFrame.TextRange.Text = Feedback1
    mySlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=400, Top:=400, Width:=200, Height:=50).TextFrame.TextRange.Text = Feedback2
    mySlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=750, Top:=400, Width:=200, Height:=50).TextFrame.TextRange.Text = Feedback3

    x = x + 1

Next i



'Make PowerPoint Visible and Active
  PowerPointApp.Visible = True
  PowerPointApp.Activate



End Sub

Answer 1

您应该为每个TextBox创建一个对象。之后，您可以编辑它的属性。

Dim x As Presentation
Set x = ActivePresentation

Dim s As Shape

'create object and save it to variable s
Set s = x.Slides(1).Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, Left:=20, Top:=240, Width:=850, Height:=50)

'create background
s.TextFrame.TextRange.Text = "Test"
s.Fill.BackColor.RGB = RGB(128, 0, 0)

'create border
s.Line.DashStyle = msoLineSolid
s.Line.BackColor.RGB = RGB(0, 128, 0)

通过VBA Excel代码将文本框属性更改为powerpoint

1 个答案: