Bilder aus Tabelle exportieren

Sub Bild_erstellen() Dim myChart As Chart, myChartObject As ChartObject Dim int_with As Integer, int_hight As Integer Application.ScreenUpdating = False Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture int_with = Selection.Width - Selection.Width / 100 * 8 int_hight = Selection.Height - Selection.Height / 100 * 8 Set myChart = Charts.Add Set myChartObject = ActiveChart.ChartObjects.Add(0, 0, int_with, int_hight) With myChartObject.Chart .Paste .Export Filename:=ActiveWorkbook.Path & "\Test1.jpg", FilterName:="JPG", Interactive:= _ _ False End With Application.DisplayAlerts = False myChart.Delete Application.DisplayAlerts = True Set myChart = Nothing Set myChartObject = Nothing Application.ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo Karel,
der Code exportiert alle Bilder der aktiven Tabelle.

' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub savePictures()
  Dim objShp As Shape
  Dim strPath As String

  On Error GoTo Errexit

  strPath = fncBrowseForFolder

  If strPath = "" Then Exit Sub

  Application.ScreenUpdating = False

  For Each objShp In ActiveSheet.Shapes
    If objShp.Type = msoPicture Then
      Exportieren objShp, strPath & "\" & objShp.Name & ".gif"
    End If
  Next

  Errexit:
  Application.ScreenUpdating = True

End Sub

Private Function Exportieren(myShape As Shape, FileName As String)
  'Idea by Nepumuk
  Dim myChart As Chart, myChartObject As ChartObject
  Set myChart = Charts.Add
  Set myChartObject = ActiveChart.ChartObjects.Add(0, 0, _
    myShape.Width, myShape.Height)
  myShape.Copy
  With myChartObject
    With .Chart
      .ChartArea.Border.LineStyle = xlLineStyleNone
      .Paste
      .Export FileName:=FileName, _
        FilterName:="GIF", Interactive:=False
    End With
    .Delete
  End With

  Application.DisplayAlerts = False
  myChart.Delete
  Application.DisplayAlerts = True
  Set myChart = Nothing
  Set myChartObject = Nothing
  Set myShape = Nothing
End Function

Private Function fncBrowseForFolder(Optional ByVal defaultPath = "") As String
  Dim objFlderItem As Object, objShell As Object, objFlder As Object

  Set objShell = CreateObject("Shell.Application")
  Set objFlder = objShell.BrowseForFolder(0&, "Ordner auswählen...", 0&, defaultPath)

  If objFlder Is Nothing Then GoTo Errexit

  Set objFlderItem = objFlder.Self
  fncBrowseForFolder = objFlderItem.Path

  Errexit:

  Set objShell = Nothing
  Set objFlder = Nothing
  Set objFlderItem = Nothing
End Function

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bilder aus Tabelle exportieren

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread