Thema: Tabellenblattbereich als Grafik speichern

StandardModule: Modul1

Harold Staff -- see http://www.geocities.com/davemcritchie/excel/xl2gif.htm
XL2GIF_module -- GIF_Snapshot
Dim container As Chart
Dim containerbok As Workbook
Dim Obnavn As String
Dim 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
   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

Public Sub GIF_Snapshot()
   Dim varReturn As Variant
   Dim MyAddress As String
   Dim SaveName As Variant
   Dim MySuggest As String
   Dim Hi As Integer
   Dim Wi As Integer
   Dim 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
      End If
      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

Beiträge aus dem Excel-Forum zu den Themen Grafik und Grafikexport