Duck Dich. Hier kommt ein Monstrum
29.08.2003 11:47:30
Andreas Water
Sub SchiessBild2(param1range, param2dateiname, param3sleep)
' Macht die eigentliche Arbeit von Bild schiessen aufrufen
'Application.Goto Reference:=Range(param1range)
'Selection.CopyPicture appearance:=xlScreen, Format:=xlPicture
'ActiveSheet.Pictures.Paste.Select
Dim leftp1range As String
On Error Resume Next
Kill ("Ausgabe.gif")
On Error GoTo 0
' Macro to save a range as a gif-file
' using the capability of Excel to do so for charts.
' Norbert Koehler 1999-08-26
Dim objCurrentShape As Object
Dim strCurrentSheet As String
Dim strGIFname As String
Dim strTempShape As String
Dim intExistingCharts As Integer
Dim intI As Integer
Dim intShapeHeight As Integer
Dim intShapeWidth As Integer
Range("A1").Select
strCurrentSheet = ActiveSheet.Name
Selection.CurrentRegion.Select
Selection.Range(param1range).Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Selection.SpecialCells(xlCellTypeLastCell).Select
Selection.Offset(1, 1).Select
ActiveSheet.PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False
strTempShape = Selection.Name
intExistingCharts = ActiveSheet.ChartObjects.Count
'MsgBox "Nos of existing Charts " & intExistingCharts
'For intI = 1 To ActiveSheet.Shapes.Count Step 1
For intI = ActiveSheet.Shapes.Count To ActiveSheet.Shapes.Count Step 1
'MsgBox ActiveSheet.Shapes.Count & " shape(s) " & ActiveSheet.Shapes(intI).Type
ActiveSheet.Shapes(intI).Select
If ActiveSheet.Shapes(intI).Type = msoPicture Then
intShapeHeight = ActiveSheet.Shapes(intI).Height
intShapeWidth = ActiveSheet.Shapes(intI).Width
'MsgBox "Height " & intShapeHeight & " Width " & intShapeWidth
'strGIFname = ThisWorkbook.Path & "\" & ThisWorkbook.Name & Selection.Name & ".gif"
'strGIFname = ThisWorkbook.Path & "\Excel " & Selection.Name & ".gif"
strGIFname = "Ausgabe.gif"
Charts.Add
ActiveChart.ChartType = xlXYScatter
ActiveChart.Location Where:=xlLocationAsObject, Name:=strCurrentSheet
ActiveChart.HasLegend = False
ActiveWindow.Visible = False
ActiveSheet.ChartObjects(intExistingCharts + 1).Left = 0
ActiveSheet.ChartObjects(intExistingCharts + 1).Top = 0
ActiveSheet.ChartObjects(intExistingCharts + 1).Height = intShapeHeight + 8
ActiveSheet.ChartObjects(intExistingCharts + 1).Width = intShapeWidth + 8
ActiveSheet.Shapes(intI).Copy
ActiveSheet.ChartObjects(intExistingCharts + 1).Activate
ActiveChart.ChartArea.Select
With Selection.Border
.Weight = 2
.LineStyle = 0
End With
ActiveChart.Paste
Application.CutCopyMode = False
Set objCurrentShape = ActiveSheet.ChartObjects(intExistingCharts + 1).Chart
objCurrentShape.Export Filename:=strGIFname, FilterName:="GIF"
ActiveSheet.ChartObjects(intExistingCharts + 1).Delete
End If
Next intI
On Error Resume Next
ActiveSheet.Shapes(strTempShape).Delete
On Error GoTo 0
'Range("A1").Select
' Erster Versuch - .GIF Datei ist zu gross
' Range(param1range).Select
' Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
' Dim cht As Chart
' Set cht = Charts.Add
' With cht
' On Error Resume Next
' .Axes(xlValue).MajorGridlines.Delete
' .Axes(xlValue).Delete
' .PlotArea.ClearFormats
' .Axes(xlCategory).Delete
' .Legend.Delete
' .ChartTitle.Delete
' .ChartArea.Clear
' .Paste
' On Error GoTo 0
' End With
' cht.Export "Ausgabe.gif"
' Application.DisplayAlerts = False
' cht.Delete
' Application.DisplayAlerts = True
On Error Resume Next
Kill (param2dateiname & ".gif")
On Error GoTo 0
On Error Resume Next
Name "Ausgabe.gif" As LCase(param2dateiname) & ".gif"
On Error GoTo 0
' Und zum Schluss selektieren wir nur ein Feld in dem Blatt.
leftp1range = Left(param1range, InStr(1, param1range, ":", vbTextCompare) - 1)
Range(leftp1range).Select
End Sub