Gruppe
Grafik
Problem
Der Tabellenblattbereich C6:D8 soll in einer UserForm als ScreenShot dargestellt werden.
StandardModule: Modul1
Dim container As Chart
Dim ContainerBook As Workbook
Dim Obnavn As String
Dim SourceBook As Workbook
Public Sub DialogAufruf()
Call GIF_Snapshot
Application.ScreenUpdating = False
frmSnapShot.Image1.Picture = LoadPicture( _
Application.DefaultFilePath & "\img.gif")
frmSnapShot.Show
Application.ScreenUpdating = False
End Sub
Private Sub ImageContainer_init()
Workbooks.Add 1
ActiveSheet.Name = "GIFcontainer"
Charts.Add
ActiveChart.ChartType = xlColumnClustered
ActiveChart.SetSourceData Source:=Worksheets(1).Range("A1")
ActiveChart.Location Where:=xlLocationAsObject, _
Name:="GIFcontainer"
ActiveChart.ChartArea.ClearContents
Set ContainerBook = ActiveWorkbook
Set container = ActiveChart
End Sub
Private Sub MakeAndSizeChart(ih As Integer, iv As Integer)
Dim Hincrease As Single
Dim Vincrease As Single
Obnavn = Mid(ActiveChart.Name, Len(ActiveSheet.Name) + 1)
Hincrease = ih / ActiveChart.ChartArea.Height
ActiveSheet.Shapes(Obnavn).ScaleHeight Hincrease, _
msoFalse, msoScaleFromTopLeft
Vincrease = iv / ActiveChart.ChartArea.Width
ActiveSheet.Shapes(Obnavn).ScaleWidth Vincrease, _
msoFalse, msoScaleFromTopLeft
End Sub
Private Sub GIF_Snapshot()
Dim SaveName As Variant
Dim Hi As Integer
Dim Wi As Integer
Set SourceBook = ActiveWorkbook
Call ImageContainer_init
SourceBook.Activate
SaveName = Application.DefaultFilePath & "\img.gif"
If Dir(SaveName) <> "" Then
Kill SaveName
End If
Range("C6:D8").Select
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlBitmap
Hi = Selection.Height + 4
Wi = Selection.Width + 6
ContainerBook.Activate
ActiveSheet.ChartObjects(1).Activate
Call MakeAndSizeChart(ih:=Hi, iv:=Wi)
ActiveChart.Paste
ActiveChart.Export Filename:=LCase(SaveName), _
FilterName:="GIF"
ActiveChart.Pictures(1).Delete
SourceBook.Activate
On Error Resume Next
Application.StatusBar = False
ContainerBook.Saved = True
ContainerBook.Close
End Sub
ClassModule: frmSnapShot
Private Sub cmdCancel_Click()
Unload Me
End Sub