MauriceSmit
Gebruiker
- Lid geworden
- 1 jul 2008
- Berichten
- 168
Hoi!
Ik maak zelf veel gebruik van excel en heb ook een custom toolbar met enige additionele functionaliteiten om het werk te versoepelen; een leuke gadget is een snelle export van je huidige selectie naar powerpoint:
Maak eventueel een knop aan in je werkbalk om deze macro aan te hangen.
Succes!
Ik maak zelf veel gebruik van excel en heb ook een custom toolbar met enige additionele functionaliteiten om het werk te versoepelen; een leuke gadget is een snelle export van je huidige selectie naar powerpoint:
Code:
Public Sub SelectionToPPT()
Dim PPApp As PowerPoint.Application
Set PPApp = GetObject("", "PowerPoint.Application")
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
Dim ScaleFactor As Double
Dim SlideTitle As String
SlideTitle = InputBox("Title for Slide", "Title", ActiveSheet.Name)
With PPApp
.Activate
' Create a new presentation
Set PPPres = .Presentations.Add(msoTrue)
' Set up slide master for office 2003
If Application.Version <> "12.0" Then
PPPres.SlideMaster.Shapes("Rectangle 4").TextFrame.TextRange.Font.Size = 10
PPPres.SlideMaster.Shapes("Rectangle 6").TextFrame.TextRange.Font.Size = 10
PPPres.SlideMaster.Shapes("Rectangle 4").ScaleHeight 0.51, msoFalse, msoScaleFromBottomRight
PPPres.SlideMaster.Shapes("Rectangle 6").ScaleHeight 0.51, msoFalse, msoScaleFromBottomRight
End If
' Format the slides to have a date/time and slide number
With PPPres.SlideMaster.HeadersFooters
With .DateAndTime
.Format = ppDateTimeddddMMMMddyyyy
.Text = ""
.UseFormat = msoTrue
.Visible = msoTrue
End With
.Footer.Visible = msoFalse
.SlideNumber.Visible = msoTrue
End With
With PPSlide
Set PPSlide = PPPres.Slides.Add(1, ppLayoutText)
With PPSlide
' Delete the text slide that is created with the ppLayoutText format
.Shapes(2).Delete
With .Shapes(1)
' Change the height and width of the title text
.ScaleHeight 0.93, msoFalse, msoScaleFromTopLeft
.ScaleWidth 1.02, msoFalse, msoScaleFromTopLeft
' Move the title text
.IncrementLeft -6#
.IncrementTop -21.62
' Format the title text
With .TextFrame.TextRange
.Text = SlideTitle
.Paragraphs(Start:=1, Length:=1).ParagraphFormat.Alignment = ppAlignLeft
.Font.Size = 36
.Font.Color.SchemeColor = ppAccent1
End With
End With
' Add a dividing line between the title and screenshot
With .Shapes.AddLine(0#, 72#, 720#, 72#)
.Line.Weight = 2.25
.Line.Visible = msoTrue
.Line.Style = msoLineSingle
.Line.ForeColor.SchemeColor = ppAccent1
End With
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With .Shapes.Paste
.Top = 80
.Left = 30
If .Height > 430 Then
ScaleFactor = (430 / .Height)
.ScaleHeight ScaleFactor, msoFalse, msoScaleFromTopLeft
If .Width > 665 Then
ScaleFactor = (665 / .Width)
.ScaleWidth ScaleFactor, msoFalse, msoScaleFromTopLeft
End If
Else
ScaleFactor = (665 / .Width)
.ScaleWidth ScaleFactor, msoFalse, msoScaleFromTopLeft
If .Height > 430 Then
ScaleFactor = (430 / .Height)
.ScaleHeight ScaleFactor, msoFalse, msoScaleFromTopLeft
End If
End If
End With
End With
End With
End With
' Clean up
Set PPSlide = Nothing
Set PPPres = Nothing
Set PPApp = Nothing
End Sub
Maak eventueel een knop aan in je werkbalk om deze macro aan te hangen.
Succes!