AW: PageSetup Header erst beim 2. Laden
07.06.2020 12:00:07
Peer
Hallo onur.
Sorry für die späte Reaktion.
Du hast recht, ich hätte die gesamten Sub angeben können. Das möchte ich nun nachholen.
Option Explicit
Sub druckGrau(control As IRibbonControl)
Dim arrWerte() ' Variable für Array
Dim raZelle As Range ' Variable für die Zelle als Range
Dim LoZaehler As Long ' Schleifenzähler
Dim loZaehler2 As Long ' Schleifenzähler
Dim rngDruckbereich As Range ' Druckbereich
ActiveSheet.PageSetup.PrintArea = "$B$4:$O$50"
'Druckbereich festlegen
Set rngDruckbereich = Range("B4,O50")
' Bildschirmaktualisierung aus
Application.ScreenUpdating = False
' Blattschutz aufheben
ActiveSheet.Unprotect Password:=""
' Ausführung in Tabelle1
With ActiveSheet
' Schleife über jede Zelle des benutzten Bereichs
For Each raZelle In ActiveSheet.UsedRange
' Zelle ist mit einer Füllfarbe Weiß oder Schriftfarbe Rot formatiert
If raZelle.Interior.ColorIndex 2 Or raZelle.Font.Color = 255 Then
' Array dynamisch erweitern
ReDim Preserve arrWerte(0 To 3, 0 To LoZaehler)
' Einlesen der Zelladresse in das Array
arrWerte(0, LoZaehler) = raZelle.Address
' Einlesen der Füllfarbe in das der Zelle in das Array
arrWerte(1, LoZaehler) = raZelle.Interior.Color
arrWerte(2, LoZaehler) = raZelle.Font.Color
arrWerte(3, LoZaehler) = raZelle.Font.Bold
' Füllfarbe der Zelle auf Weiß setzen
raZelle.Interior.ColorIndex = 2
' Schriftschnitt auf nicht Fett setzen
raZelle.Font.Bold = False
' Schriftfarbe auf Schwarz setzen
raZelle.Font.ColorIndex = 1
' Schleifenzähler um 1 erhöhen
LoZaehler = LoZaehler + 1
End If
Next raZelle
' .Range("B1:N8").EntireColumn.Hidden = True
' Tabelle drucken
' .PrintOut
' Einstellungen des Ausdrucks
.Range("B1:L7").EntireRow.Hidden = False
With .PageSetup
.HeaderMargin = 20 'Abstand vom oberen Seitenabstand
.LeftHeader = ""
.CenterHeader = ""
.CenterHeader = "&""Arial,bold""&16" & "Erfassungsbeleg Verwendung / Nebenbezü _
ge"
.RightHeader = "&G" 'Steuerzeichen für das Einfügen einer Grafik
With .RightHeaderPicture
.Filename = ThisWorkbook.Path & "\" & "db_logo.jpg" ' Grafik aus dem _
Stammverzeichnis der Excel-Datei laden
.Height = 24
.Width = 37
'.ColorType = msoPictureGrayscale 'Grafik grau
'.Brightness = 0.36 'Helligkeit 0,0 (stark abgetönt) bis 1,0 (sehr hell)
End With
.Orientation = xlPortrait
.FooterMargin = 0.5 'Abstand vom unteren Seitenrand
.LeftFooter = "&""Arial""&8" & "L.RBG-S-32 - Erfassungsbeleg Verwendungen/ _
Nebenbezüge - Rev. 0 - 01.01.2009"
.RightFooter = ""
End With
' Seitenvorschau öffnen
.PrintPreview
' Drucker Auswahl Dialog öffnen
' .Application.Dialogs(xlDialogPrint).Show
' Schleife über alle Elemente des Arrays
For loZaehler2 = 0 To LoZaehler - 1
' Zurückübertragen der ausgelesenen Füllfarben
.Range(arrWerte(0, loZaehler2)).Interior.Color = arrWerte(1, loZaehler2)
.Range(arrWerte(0, loZaehler2)).Font.Color = arrWerte(2, loZaehler2)
.Range(arrWerte(0, loZaehler2)).Font.Bold = arrWerte(3, loZaehler2)
Next loZaehler2
.Range("B1:L7").EntireRow.Hidden = True
End With
' Blattschutz aktivieren
ActiveSheet.Protect Password:=""
' Bildschirmaktualisierung ein
Application.ScreenUpdating = True
End Sub
und
Sub EmailSenden(control As IRibbonControl)
Dim mePDFD As String 'Anhang-Name
Dim MyOutApp As Object 'Email Client
Dim MyMessage As Object 'Email-Kopf
Dim Adressat As Object 'Empfänger
Dim arrMonat()
Dim MyPerson As String
Dim MyName As String
Dim MyFunction As String
Dim MyNumber As String
Dim wks As Worksheet
Set wks = Sheets("Parameter")
MyName = wks.Cells(15, 3)
MyFunction = wks.Cells(15, 7)
MyNumber = wks.Cells(15, 9)
MyPerson = MyName & " " & MyFunction & " " & MyNumber
'Abfrage, ob aktives Sheet kein "Monat" ist
Select Case ActiveSheet.name
Case "Ferien", "Parameter", "Feiertage", "Hinweise", "Gesamtstunden", "Kompatibilitätsbericht", "Reiseziele"
MsgBox "Keinen Monat ausgewählt!" & vbCrLf & "Klicke auf ein Monats-Register und versuche es nochmal"
Exit Sub
Case Else
'Anhang-Name definieren
mePDFD = ThisWorkbook.Path & "\" & "Erfassungsbeleg für den Monat " _
& Format(ActiveSheet.Range("E4"), "MMMM"" ""YYYY") & ".pdf"
'aktuelle Tabelle in die Zwischenanlage kopieren
ThisWorkbook.ActiveSheet.Copy
'aktuelle Tabelle als Ausgabedatei (hier .pdf) festlegen
ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=mePDFD, Quality:=xlQualityStandard, _
IncludeDocProperties:=False, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
ActiveWorkbook.Close False
With ThisWorkbook.ActiveSheet.PageSetup
.Orientation = xlPortrait
.LeftHeader = ""
.LeftHeader = "Name: " & MyName & Chr(10) & _
"Pers.Nr.: " & MyNumber & Chr(10) & _
"Funktion: " & MyFunction '"&K03" & MyPerson 'blau
.CenterHorizontally = True
'.BlackAndWhite = True 'schwarz/weiss
.CenterHeader = "&""ARIAL,Fett""&20" & "Erfassungsbeleg" & Chr(10) & "&""ARIAL""&16" & Format(ActiveSheet.Range("E4"), "MMMM"" ""YYYY")
.RightHeader = "&G" 'Steuerzeichen für das Einfügen einer Grafik
With .RightHeaderPicture
If Dir(ThisWorkbook.Path & "\" & "db_logo.jpg") = "" Then
MsgBox "Füge die 'DB Logo'-Datei ins Stammverzeichnis der Excel-Datei ein!" & Chr(10) & "Es wird ohne dieses Logo gedruckt!"
.Filename = ""
Else
.Filename = ThisWorkbook.Path & "\" & "db_logo.jpg" ' Grafik aus dem Stammverzeichnis der Excel-Datei laden
.Height = 24
.Width = 37
'.ColorType = msoPictureGrayscale 'Grafik grau
'.Brightness = 0.36 'Helligkeit 0,0 (stark abgetönt) bis 1,0 (sehr hell)
End If
End With
.LeftFooter = "&""Arial""&8" & "L.RBG-S-32 - Erfassungsbeleg Verwendungen/Nebenbezüge - Rev. 0 - 01.01.2009"
.RightFooter = ""
End With
Set MyOutApp = CreateObject("Outlook.Application") 'Email-Client festlegen
Set MyMessage = MyOutApp.CreateItem(0) 'neue Email erstellen
Set Adressat = Sheets("Parameter").Cells(25, 3) 'Empfänger aus Tabelle "Parameter"
With MyMessage
.To = Adressat 'oder andere Emailadresse
.Subject = "Erfassungsbeleg" 'Betreffzeile
.body = "Lieber Kollege" & vbCrLf & vbCrLf _
& "Im Anhang der Erfassungsbeleg" & vbCrLf & vbCrLf & _
"Mit freundlichen Grüßen" & vbCrLf & ActiveSheet.Cells(5, 5)
.Attachments.Add mePDFD 'Anhang aus Zwischenanlage einfügen
.Display 'alles anzeigen
End With
Kill mePDFD 'lösche Anhang
Set MyMessage = Nothing 'setze Email auf Null, damit keine Dateileichen im Speicher verbleiben
Set MyOutApp = Nothing 'setze Email-Client auf Null, damit keine Dateileichen im Speicher verbleiben
End Select
End Sub
Die Datei ist inzwischen auf 700 kb angestiegen und ist in sich schon so verflochten, dass ich sie gar nicht mehr so klein machen kann, um sie hochladen zu können. Vieles würde dann nicht mehr funktionieren oder nachvollziehbar sein.
Daher dachte ich mir, vielleicht hier jemanden zu finden, der meine Frage als einfach einstufen konnte und eine Lösung auch ohne viel Code gehabt hätte.
LG
Peer