Excel Macro's erstellen nur leere Bilder
#1
Heje Excelfreunde,

habe mit zwei Macros ein merkwürdiges Problem. Mit dem automatischen Ausführen den jeweiligen Macro's werden leere Bilder eines Tabellenausschnittes erzeugt. Führe ich die Macro's dagegen händisch (Taste F8) durch, dann werden genau die Tabellenausschnitte
als Bilddatei erzeugt und abgelegt. Wo liegt das Problem...

Code:
Sub ExportWorksheetAsPicture()
Dim chtPicture As Chart
Dim strSheetName As String
    With Application
        .ScreenUpdating = False
        strSheetName = ActiveSheet.name
        ActiveSheet.Range("A1:w46").CopyPicture Appearance:=xlScreen, Format:=xlPicture
        Set chtPicture = Charts.Add
        chtPicture.Paste
        chtPicture.Export ActiveWorkbook.Path & "\" & strSheetName & ".gif"
        Application.DisplayAlerts = False
        chtPicture.Delete
        Application.DisplayAlerts = True
        Set chtPicture = Nothing
    .ScreenUpdating = True
    End With
End Sub

oder das zweite Beispiel

Code:
Public Sub BildBereichErstellenKopieren()
Dim WStab05 As Worksheet
Dim rngBereich01 As Range
   
    On Error GoTo Fehler
    Set WStab05 = ThisWorkbook.Worksheets("Tabelle5")
    Set rngBereich01 = WStab05.Range("A1:W46")

    With Application
        '.ScreenUpdating = False
        With ActiveWorkbook
            .Unprotect Password:="******"
            With WStab05
                .Unprotect Password:="******"
                rngBereich01.CopyPicture Appearance:=xlScreen, Format:=xlPicture
                With WStab05.ChartObjects.Add(0, 0, Range("A1:W46").Width, Range("A1:W46").Height).Chart
                    .Paste
                    .Export strKompPath
                    .Parent.Delete
                End With
                .Protect Password:="******", DrawingObjects:=True, Contents:=True, Scenarios:=True
            End With
            .Protect Password:="******", Structure:=True, Windows:=False
        End With
        '.ScreenUpdating = True
    End With
    On Error GoTo 0
    Set WStab05 = Nothing
    Set rngBereich01 = Nothing
    Exit Sub

Fehler:
If Err.Number > 0 Then
    MsgBox "UF7_03 Fehlercode : " + CStr(Err.Number) + "  " + Err.Description + "  " + CStr(Err.Source)
End If
End Sub
Vielen Dank
--Janosch
                                                     
Excel  2019 (64bit)  Win 10 Pro (64bit)                              
Antworten Top
#2
Hallo, 19 

in den neuen Excelversionen musst du das Chartobjekt Selektieren/Aktivieren, sonst leere Bilder (bezogen auf dein erstes Beispiel): 21

Code:
Option Explicit
Public Sub Main()
    Dim chtPicture As ChartObject
    Dim strSheetName As String
    Const strTMP As String = "A1:B18" 'ANPASSEN!!!!!
    On Error GoTo Fin
    Application.ScreenUpdating = False
    strSheetName = ActiveSheet.Name
    ActiveSheet.Range(strTMP).CopyPicture Appearance:=xlScreen, Format:=xlPicture
    Set chtPicture = ActiveSheet.ChartObjects.Add(0, 0, Range(strTMP).Width, Range(strTMP).Height)
    With chtPicture
        .Chart.ChartArea.Select
        .Chart.Paste
        .Chart.Export ActiveWorkbook.Path & "\" & strSheetName & ".gif"
    End With
    Application.DisplayAlerts = False
Fin:
    chtPicture.Delete
    Application.DisplayAlerts = True
    Set chtPicture = Nothing
    Application.ScreenUpdating = True
End Sub
[-] Folgende(r) 1 Nutzer sagt Danke an Gast für diesen Beitrag:
  • radagast
Antworten Top
#3
Heje Excelfreunde,

anbei eine Bsp.Datei....


Angehängte Dateien
.xlsm   BildKopieren.xlsm (Größe: 22,54 KB / Downloads: 0)
Vielen Dank
--Janosch
                                                     
Excel  2019 (64bit)  Win 10 Pro (64bit)                              
Antworten Top
#4
Heje Excelfreunde, Case,

anbei die angepasste Datei nach  dem Einwand/Vorschlag nach "Case"...     17 19


Angehängte Dateien
.xlsm   BildKopieren02.xlsm (Größe: 24,06 KB / Downloads: 1)
Vielen Dank
--Janosch
                                                     
Excel  2019 (64bit)  Win 10 Pro (64bit)                              
Antworten Top
#5
Hallöchen,

ich hab im Anhang mal noch was - sieht teilweise etwas konfus aus und müsste an der einen oder anderen Stelle ausgemistet werden, - aber läuft auch noch unter 365 / 64 Das ist noch aus einem alten Projekt, was mal mit 97 erstellt und öfter angepasst wurde.
Ich hatte da das Diagramm fest auf einem tmp-Blatt liegen. Die Größe des Diagramms hat der Code entsprechend dem Ausgabebereich angepasst, eine Skalierung war nach dem Einfügen des "Bildes" auch möglich. Auf das Diagramm wurde per Set verwiesen. Am Ende ist es zwar selektiert, das passiert beim ...paste
Kann man vielleicht den einen oder anderen Codeteil noch als Ansatz für Erweiterungen oder Änderungen verwenden.

Der Punkt damals war, das Programm und Daten in verschiedenen Dateien lagen und auch in der Programmdatei verschiedene Blätter u.a. mit verschiedenen Vorlagen und Parameterdaten usw. zum Einsatz kamen. Da will (und sollte) man ja nicht laufend hin und her selektieren ...


Angehängte Dateien
.xlsm   gifexport.xlsm (Größe: 24,72 KB / Downloads: 4)
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
[-] Folgende(r) 1 Nutzer sagt Danke an schauan für diesen Beitrag:
  • radagast
Antworten Top
#6
Hallo Excelfreunde, schauan,

herzlichen Dank an alle für die Hilfe beim Coderstellen...oder zur Verfügung stellen...
Letztendlich muss man sich mit dem "ChartObjek" näher auseinander setzen.
Vielen Dank
--Janosch
                                                     
Excel  2019 (64bit)  Win 10 Pro (64bit)                              
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste