0
ExcelでテキストをいくつかコピーしてパワーポイントにコピーするVBAコードがあります。VBAエクセルコードを使ってテキストボックスのプロパティを変更する
コピーは機能しますが、テキストボックスに色を付けたいです(&行を入力してください)。
どうすればいいですか?
私のコード
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
コードを変更しましたが、テキストボックスは作成されませんでした。 Set myPresentation = PowerPointApp.Presentations.Add カウンタ= ThisWorkbook.ActiveSheet.Range( "A1")。値 x = 3 i = 1の場合カウンタ mySlide = myPresentation.Slides.Add(i、12)'11を設定する= ppLayoutBlank myPPT = ActivePresentationを設定する S = myPPT.Slides(1).Shapes.AddTextbox(方向:= msoTextOrientationHorizontal、左:= 20、上:= 240、幅:= 850、高さ:= 50) S. TextFrame.TextRange.Text = "Test" S.Fill.BackColor.RGB = RGB(128,0,0) S.Line.DashStyle = msoLineSolid S.Line.BackColor.RGB = RGB(0、128、0) ) – Stoffeltotof