Habe folgenden Code schon vor Jahren aus dem Archiv. Dieser lief auf Office2000 immer bestens.
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 = Application.InputBox("Select " _
& "range to be photographed:", "Picture Selection", _
Selection.AddressLocal, Type:=8)
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 = Application.GetSaveAsFilename( _
initialfilename:=MySuggest _
& ".gif", fileFilter:="Gif Files (*.gif), *.gif")
Range(MyAddress).Select
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlBitmap
If SaveName = False Then GoTo Avbryt
If InStr(SaveName, ".") Then SaveName _
= Left(SaveName, InStr(SaveName, ".") - 1)
Selection.CopyPicture Appearance:=xlScreen, _
Format:=xlBitmap
Hi = Selection.Height + 4 'adjustment for gridlines
Wi = Selection.Width + 6 'adjustment for gridlines
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
Nun wurde aber auf Office 2007 upgedatet, wo ich nun aber ständig die Fehlermeldung:
Laufzeitfehler: Das Element mit dem angegebenen Namen wurde nicht gefunden.
...wenn ich dann auf debuggen gehe wird folgendes angeleuchtet:
ActiveSheet.Shapes(Obnavn).ScaleHeight Hincrease, _
msoFalse, msoScaleFromTopLeft
...allerdings das neue Workbook und das Tabellenblatt mit dem Namen GIFcontainer wird erstellt.
Bin total ratlos. Bitte um Hilfe.
Danke
Georg