AW: Makro - Excel Bereiche als Bild in PPT kopieren
25.11.2010 12:09:52
Dirk
Hallo Cora,
hier mal ein Beispielcode zur Anpassung.
Das in ein Modul:
Public PPApp As PowerPoint.Application
Public PPPres As PowerPoint.Presentation
Public PPSlide As PowerPoint.Slide, PPFileName
Sub ExcelToNewPowerPoint()
'###############################################################################################
'###
'### This macro copies the relevant sections from the status sheets and insert the data into
'###
'### a powerpoint presentation, (c) dirk schoas 2010
'###
'###############################################################################################
Dim MyRepRange As Range, MyBook As Workbook, MyFind As Range, Firstrow As Long, LastRow As Long
Dim MyRefRange As Range, Cpos As Long, CCnt As Long, i As Long, Rstart As Long, LastR As Boolean
Dim MyStr As String, MyTmplPPT As String
'columns to be presented to Customer in status report:
'C, D, E, G, H
UF2.Show
If UserSel = vbCancel Then
'user cancels, abort
Exit Sub
End If
MyTmplPPT = UF2.TextB1.Value
Unload UF2
'get firstrow
With ActiveSheet.Cells
Set MyRepRange = .Find(what:="Category", LookIn:=xlValues)
If Not MyRepRange Is Nothing Then
Firstrow = MyRepRange.Row
Else
'first row not found, start empty
GoTo user_input
End If
LastRow = Range("L65536").End(xlUp).Row - 8
MyStr = Range(Cells(Firstrow, 3), Cells(LastRow, 5)).Address & "," & Range(Cells(Firstrow, 7), Cells(LastRow, 8)).Address
End With
user_input:
retry_Range:
'get content from AP-sheet through user selection
ActiveSheet.Unprotect "111"
UserSel = vbCancel
Range(MyStr).Select
UF3.TextBox1.Value = ""
UF3.Show vbModeless
Set MyRefRange = ActiveCell
Set MyRepRange = ActiveCell
While UserSel vbOK
DoEvents
If MyRefRange.Address Selection.Address Then
UF3.TextBox1.Value = Selection.Address
Set MyRefRange = Range(Selection.Address)
UF3.Repaint
If UF3.TextBox1.Value "" Then
UF3.CB_OK.Enabled = True
Else
UF3.CB_OK.Enabled = False
End If
End If
Wend
If UserSel = vbOK Then
Set MyRepRange = Range(UF3.TextBox1.Value)
Else
'user canceled
Exit Sub
End If
If MyRepRange Is Nothing Then
'user did not select a range, maybe abort
UserSel = MsgBox("No range was selected. To abort the report generation, select 'Cancel'" & vbCrLf & _
"To select a range, select 'Retry'", 21, " No range selected")
If UserSel = vbCancel Then
Exit Sub
End If
GoTo retry_Range
End If
'process the selected range, check if multiple ranges are selected
Cpos = 1
If InStr(1, MyRepRange.Address, ",") > 0 Then
Set MyRefRange = MyRepRange
'first get number of ranges by getting number of commas
CCnt = Len(MyRefRange.Address) - Len(Replace(MyRefRange.Address, ",", "")) + 1
'now separate the ranges and copy them
Rstart = 1
LastR = False
For i = 1 To CCnt
If i = CCnt Then
Cpos = Len(MyRepRange.Address) + 1
Else
Cpos = InStr(Rstart, MyRepRange.Address, ",")
End If
Set MyRefRange = Range(Mid(MyRepRange.Address, Rstart, Cpos - Rstart))
Debug.Print MyRefRange.Address
If i = CCnt Then
LastR = True
End If
Call ExcelToNewPP(MyTmplPPT, MyRefRange, i, LastR)
Rstart = Cpos + 1
Next i
Else
Call ExcelToNewPP(MyTmplPPT, MyRepRange, 1, True)
End If
Range("D3").Select
ActiveSheet.Protect "111"
End Sub
Sub ExcelToNewPP(MyTemplate As String, MyRange As Range, Slide As Long, last As Boolean)
If Slide = 1 Then
'Dim PPApp As PowerPoint.Application
'Dim PPPres As PowerPoint.Presentation
'Dim PPSlide As PowerPoint.Slide, PPFileName
Dim SD As String, MyTop As Long, MyLeft As Long, Shp As PowerPoint.Shape
Dim ShpRange As PowerPoint.ShapeRange, MyWidth As Long, xfact, Yfact
Dim SLideH As Long, SlideW As Long, SlideRatio, PictRatio
Dim PictWidth As Long, PictHeight As Long
Dim ShpArr(10), i As Long
' Create instance of PowerPoint
Set PPApp = CreateObject("Powerpoint.Application")
' For automation to work, PowerPoint must be visible
' (alternatively, other extraordinary measures must be taken)
PPApp.Visible = True
' Create a presentation
Set PPPres = PPApp.Presentations.Open(MyTemplate, untitled:=msoTrue)
'MyTemplate , untitled:=msoTrue
' Some PowerPoint actions work best in normal slide view
PPApp.ActiveWindow.ViewType = ppViewSlide
' Add first slide to presentation
Set PPSlide = PPPres.Slides(2)
'PPApp.ActiveWindow.Presentation.ApplyTemplate MyTemplate
Else
' Reference existing instance of PowerPoint
Set PPApp = GetObject(, "Powerpoint.Application")
' Reference active presentation
Set PPPres = PPApp.ActivePresentation
PPApp.ActiveWindow.ViewType = 1
' Reference active slide
Set PPSlide = PPPres.Slides _
(PPApp.ActiveWindow.Selection.SlideRange.SlideIndex)
PPSlide.Select
End If
'clean template slide of old report data
PPSlide.Select
If Slide = 1 Then
PPSlide.Shapes.Range.Delete
End If
'copy the selected range
Worksheets(MyRange.Parent.Name).Range(MyRange.Address).Select
Worksheets(MyRange.Parent.Name).Range(MyRange.Address).CopyPicture Appearance:=xlScreen, Format:=xlPicture
' Paste the range
PPSlide.Shapes.Paste.Select
'name shape for reference
PPApp.ActiveWindow.Selection.ShapeRange.Name = "Pic" & Slide
'check if pasted picture already exist
If Slide > 1 Then
MyTop = PPSlide.Shapes("Pic" & Slide - 1).Top
MyLeft = PPSlide.Shapes("Pic" & Slide - 1).Left + PPSlide.Shapes("Pic" & Slide - 1).Width
' Align the pasted range
PPSlide.Shapes("Pic" & Slide).Top = MyTop
PPSlide.Shapes("Pic" & Slide).Left = MyLeft
Else
' Align the pasted range
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
PPApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, True
End If
If last = False Then
Exit Sub
End If
'adjust the position and size of the pictures on the slide, first get width of pictures
For i = 1 To Slide
PictWidth = PictWidth + PPSlide.Shapes("Pic" & i).Width
ShpArr(i) = PPSlide.Shapes("Pic" & i).Name
Next i
PictHeight = PPSlide.Shapes("Pic" & Slide).Height
PictRatio = PictWidth / PictHeight
SlideW = PPApp.ActiveWindow.Presentation.PageSetup.SlideWidth - 30
SLideH = PPApp.ActiveWindow.Presentation.PageSetup.SlideHeight - 40
SlideRatio = (SlideW / SLideH)
xfact = (SlideW - 30) / PictWidth 'scaling factor
With PPSlide.Shapes
.Range(ShpArr).Group.Select
End With
If xfact
'Pictures are wider then the slide, change scale to fit in
PPApp.ActiveWindow.Selection.ShapeRange.Width = PPApp.ActiveWindow.Selection.ShapeRange.Width * xfact
PPApp.ActiveWindow.Selection.ShapeRange.Height = PPApp.ActiveWindow.Selection.ShapeRange.Height * xfact
PPApp.ActiveWindow.Selection.ShapeRange.Left = 20
End If
'ask user for Presentation name and saving path
PPFileName = Application.GetSaveAsFilename("CSIP-Status_" & ActiveSheet.Cells(2, 7).Value & "_" & Cells(2, 5).Value & "_" & ActiveSheet.Combo1.Value & ".ppt", _
"PowerPoint files (*.pp*),*.pp*", 1, "Please enter a filename for the presentation")
' Save and close presentation
With PPPres
.SaveAs PPFileName
'.Close
End With
'Quit PowerPoint
'PPApp.Quit
' Clean up
'Set PPSlide = Nothing
'Set PPPres = Nothing
'Set PPApp = Nothing
End Sub
Das ist der code fuer UF2 (userform)
Private Sub CB_Filedialog_Click()
Dim MyBook, MyPath
Dim pd As FileDialog, Lbox As Variant
MyBook = ThisWorkbook.Name
MyPath = ThisWorkbook.Path
'hide the userform
UF2.Hide
Set pd = Application.FileDialog(msoFileDialogFilePicker)
With pd
.InitialFileName = "*.ppt"
.Filters.Clear
.Filters.Add "PPT template file(*.ppt)", "*.ppt"
.ButtonName = "Use PPT"
.AllowMultiSelect = False
.Title = "User selection required for PPT template"
.InitialView = msoFileDialogViewDetails
.Show
If .SelectedItems.Count = 0 Then
UserSel = vbCancel
Else
UF2.TextB1.Value = .SelectedItems(1)
UF2.CB_OK.Enabled = True
UserSel = vbOK
End If
End With
End Sub
Private Sub CB_OK_Click()
UF2.Hide
UserSel = vbOK
End Sub
Private Sub UserForm_Click()
UF2.Hide
UserSel = vbCancel
End Sub
Private Sub UserForm_Deactivate()
UserSel = vbCancel
End Sub
Userform hat 3 Commandbuttons und eine Textbox, bitte entsprechend die Namen setzen.
Ich hoffe das hilft erst mal weiter.
Gruss
Dirk aus Dubai