2017-03-15 5 views
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 

答えて

0

あなたはすべての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) 
+0

コードを変更しましたが、テキストボックスは作成されませんでした。 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(方向:= msoTextOrientationHorizo​​ntal、左:= 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

関連する問題