Excel Druckbereich als Screenshot speichern

Lenni · 1970-01-01T00:00:00+00:00

Moin Excellianer Das Problem: Eine Tabelle (nur 1 Sheet) soll anderen als Datei (!) zur Ansicht zur Verfügung gestellt werden. Die gesamte Exceldatei ist aufgrund der Makros und weiterer Tabellenblätter zu groß... Meine Idee ist nun, dieses eine Tabellenblatt mit einem Druckbereich zu Versehen (das ist also schon geschehen) und dann diesen Druckbreich als Screenshot in eine *.jpg-, *.bmp- und/oder *.gif-Datei abzuspeichern. Ich machte mich auf die Suche und fand schon mal diesen Beitrag hier im Archiv: https://www.herber.de/forum/archiv/912to916/t915918.htm ...und ich stoße an meine VBA-Grenzen... • Ich möchte den Druckbereich von nur 1nem Tabellenblatt als Screenshot/Grafikdatei erstellen. • Diese Datei soll in zwei (!) anderen Ordnern extra gespeichert werden. • In dem einen Ordner nur mit dem Namen der Exceldatei, in dem anderen Ordner mit dem Dateinamen+ZelleA1+ZelleA2 (...die Zellen A1 und A2 sind in dem betr. Tabellenblatt) • Eine in den betreffenden Ordnern bereits vorhandene Datei gleichen Namens soll einfach ohne Nachfrage überschrieben werden Ich bitte um Eure Hilfe. Vielen Dank! Gruß Lenni

Hallo Lenni,
probier mal.

' **********************************************************************
' Modul: Modul1  Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub exportPrintArea()
  Dim lngRet As Long
  Dim strPath1 As String, strPath2 As String
  
  strPath1 = "E:\Temp"
  strPath2 = "E:\Temp\Test"
  
  With Sheets("Tabelle1")
    strPath1 = IIf(Right(strPath1, 1) = "\", strPath1, strPath1 & "\") & _
      Mid(ThisWorkbook.Name, 1, InStrRev(ThisWorkbook.Name, ".") - 1) & ".jpg"
    
    strPath2 = IIf(Right(strPath2, 1) = "\", strPath2, strPath2 & "\") & _
      Mid(ThisWorkbook.Name, 1, InStrRev(ThisWorkbook.Name, ".") - 1) & _
      .Range("A1").Text & .Range("A2").Text & ".jpg"
    
    
    lngRet = RangeToImage(strPath1, .Range(.PageSetup.PrintArea))
    lngRet = RangeToImage(strPath2, .Range(.PageSetup.PrintArea))
  End With
  
  If lngRet = 0 Then
    MsgBox "Druckbereich erfolgreich exportiert"
  Else
    MsgBox "Fehler beim Export"
  End If
End Sub


Function RangeToImage(ByVal ImageFile As String, ByRef ImageRange As Object) As Long
  Dim objPict As Object, objChrt As Chart
  Dim strExt As String, bDelPic As Boolean
  
  On Error GoTo ErrExit
  Application.ScreenUpdating = False
  
  RangeToImage = -1
  
  With ImageRange.Parent
    If TypeName(ImageRange) = "Range" Then
      .Activate
      .Range("X20000").Select
      ImageRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
      
      .PasteSpecial Format:="Bitmap"
      
      For Each objPict In .Shapes
        If objPict.TopLeftCell.Address(0, 0) = "X20000" Then Exit For
      Next
      
      .Range("A1").Select
      bDelPic = True
    ElseIf TypeName(ImageRange) = "Shape" Then
      Set objPict = ImageRange
    End If
    
    objPict.Copy
    
    Set objChrt = .ChartObjects.Add(1, 1, objPict.Width + 8, objPict.Height + 8).Chart
    
    strExt = Mid(ImageFile, InStrRev(ImageFile, ".") + 1)
    
    objChrt.Paste
    objChrt.Export ImageFile, FilterName:=strExt
    objChrt.Parent.Delete
    If bDelPic Then objPict.Delete
    DoEvents
    Set objPict = Nothing
    Set objChrt = Nothing
    RangeToImage = 0
  End With
  
  ErrExit:
  Application.ScreenUpdating = True
  If Not objChrt Is Nothing Then objChrt.Parent.Delete
  If bDelPic Then If Not objPict Is Nothing Then objPict.Delete
  Set objPict = Nothing
  Set objChrt = Nothing
End Function

« Gruß Sepp »

Moin Karin! Moin Josef!
Vielen Dank für Eure Hilfe!
Ich habe die "schnell gebastelte" Grund-Datei (die Orginal ist zu groß!) mal hochgeladen. Ich glaube, das ist der bessere Weg.
Der Kennwortschutz der Tabellenblätter ist: xyz
Die beiden Zellen für den zu speichernden Bilddateinamen wären "AA8" und "AB8" und liegen im ausgeblendeten Bereich des Tabellenblattes "Wochenplan".
https://www.herber.de/bbs/user/76108.xls
Ich habe Eure Vorschläge zwischenzeitlich an anderen Rechnern testen können: Dein Vorschlag, Karin, funktionierte auch unter der neuesten Excel-Version nicht. Es kamen Fehlermeldungen. Dein Vorschlag Josef, lief an allen mir zur Verfügung stehenden Excel-Versionen ohne Fehlermeldungen, exportierte aber keine Bilddateien und es kam Deine MsgBox "Fehlerhafter Export" (Das finde ich übrigens Klasse!).
Dann habe ich eine Blanko-Datei genommen, einen Druckbereich definiert und Eure Vorschläge "eingebaut": Keine Fehlermeldungen mehr, aber bei kein Bildexport bei Deinem Vorschlag Karin. Bei Josefs Vorschlag kam es nun zu einem Bildexport, aber es waren Blanko-Bilder (obwohl Zellen im Druckbreich ausgefüllt waren).
Liegt es evtl. am Kennwortschutz meines Tabellenblattes oder daran, dass Zeilen und Spalten im Druckbereich ausgeblendet sind...
Danke Euch nochmals!
Gruß
Lenni

Excel Druckbereich als Screenshot speichern

Forumthread: Excel Druckbereich als Screenshot speichern

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial