Re: Shape in Userform laden
05.01.2003 17:13:45
Nepumuk
Hallo Felix,
du musst noch den Bereich anpassen, in dem sich das Diagramm befindet. Günstig ist es, das Diagramm dem ausgewählen Breich genau anzupassen, dann hats du nicht den Rest der Zellen in dem Gif-Bild.Option Explicit
Dim container As Chart, containerbok As Workbook, Obnavn As String, Sourcebok As Workbook
Function SelectArea() As String
Dim Internrange As Range
On Error GoTo Brutt
Set Internrange = Range("c3:i22") 'Hier Bereich anpassen
SelectArea = Internrange.Address
Exit Function
Brutt:
SelectArea = "A1"
End Function
Function sShortname(ByVal Orrginal As String) As String
Dim iii As Integer
sShortname = ""
For iii = 1 To Len(Orrginal)
If Mid(Orrginal, iii, 1) <> " " Then sShortname = sShortname & Mid(Orrginal, iii, 1)
Next
End Function
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 containerbok = ActiveWorkbook
Set container = ActiveChart
End Sub
Sub MakeAndSizeChart(ih As Integer, iv As Integer)
Dim Hincrease As Single, 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
Public Sub GIF_Snapshot()
Dim varReturn As Variant, MyAddress As String, SaveName As Variant, MySuggest As String
Dim Hi As Integer, Wi As Integer, Suffiks As Long
Set Sourcebok = ActiveWorkbook
MySuggest = sShortname(ActiveSheet.Name)
ImageContainer_init
Sourcebok.Activate
MyAddress = SelectArea
If MyAddress <> "A1" Then
SaveName = "C:\WINDOWS\TEMP\Diagramm"
Range(MyAddress).Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
If SaveName = False Then
GoTo Avbryt
End If
If InStr(SaveName, ".") Then SaveName = Left(SaveName, InStr(SaveName, ".") - 1)
Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Hi = Selection.Height + 4
Wi = Selection.Width + 6
containerbok.Activate
ActiveSheet.ChartObjects(1).Activate
MakeAndSizeChart ih:=Hi, iv:=Wi
ActiveChart.Paste
ActiveChart.Export Filename:=LCase(SaveName) & ".gif", FilterName:="GIF"
ActiveChart.Pictures(1).Delete
Sourcebok.Activate
End If
Avbryt:
On Error Resume Next
Application.StatusBar = False
containerbok.Saved = True
containerbok.Close
End Sub
In die Userform folgenden Code:
Option Explicit
Private Sub UserForm_Activate()
Image1.Picture = LoadPicture("C:\WINDOWS\TEMP\Diagramm.gif")
End Sub
Gruß
Nepumuk