Workaround/Lösung
11.06.2019 16:30:03
EtoPHG
Hallo Ralph,
Ich habe meinen Level nie angegeben und als Excel-Profi würde ich mich schon gar nicht bezeichnen.
Diesen Codeersatz für deine Sub habe ich auf XL365 2016 getestet und er funktioniert für alle deine erwähnten Fälle (Einzelnes Sheet, mehrere aber nicht alle und alle Sheets):
' ********************************************
' * Seiteneinrichtung (Aufruf über UserForm2)*
Sub Layouteinrichtung()
Dim Ausrichtung_txt As String, Papier_txt As String
Dim Zugriff_id As Integer
Dim LogoFusszeile As Double
Dim LogoHeight As Double
Dim DateiExistiert As Boolean
Dim nStep As String
Dim objSheet As Object
On Error GoTo Error_Handler
' Faktor für die Anpassung Fußzeilenlogo
LogoFusszeile = 0.5
LogoHeight = CDbl(Replace(UserForm2.TextBox2.Text, ",", "."))
If UserForm2.ToggleButton2.Caption = "Querformat" Then Ausrichtung_txt = xlLandscape
If UserForm2.ToggleButton2.Caption = "Hochformat" Then Ausrichtung_txt = xlPortrait
If UserForm2.ToggleButton3.Caption = "A4" Then Papier_txt = xlPaperA4
If UserForm2.ToggleButton3.Caption = "A3" Then Papier_txt = xlPaperA3
For Each objSheet In ThisWorkbook.Windows(1).SelectedSheets
With objSheet
nStep = "Select " & objSheet.Name
.Select
.PageSetup.RightHeader = "&G"
.PageSetup.LeftFooter = "&G"
With .PageSetup.RightHeaderPicture
' Logo NBT2
nStep = "Logo NBT2"
If UserForm2.ToggleButton1.Caption = "NBT2" Then
DateiExistiert = Not (GetAttr(ThisWorkbook.Path & "\" & "Logo1.jpg") _
And vbDirectory) = vbDirectory
If DateiExistiert Then
.Filename = ThisWorkbook.Path & "\" & "LOGO1.jpg"
Else
Zugriff_id = MsgBox("Kein Zugriff auf die Logo-Datei!", _
vbCritical + vbOKCancel + vbDefaultButton1)
If Zugriff_id = 2 Then Exit Sub
End If
.Height = Application.CentimetersToPoints(LogoHeight)
' Debug.Print objSheet.Name & "=" & .Height & " " & nStep
End If
' Logo NBT3
nStep = "Logog NBT3"
If UserForm2.ToggleButton1.Caption = "NBT3" Then
DateiExistiert = Not (GetAttr(ThisWorkbook.Path & "\" & "Logo2.jpg") _
And vbDirectory) = vbDirectory
If DateiExistiert Then
.Filename = ThisWorkbook.Path & "\" & "LOGO2.jpg"
Else
Zugriff_id = MsgBox("Kein Zugriff auf die Logo-Datei!", _
vbCritical + vbOKCancel + vbDefaultButton1)
If Zugriff_id = 2 Then Exit Sub
End If
.Height = Application.CentimetersToPoints(LogoHeight)
' Debug.Print objSheet.Name & "=" & .Height & " " & nStep
End If
End With
nStep = "Logo Fußzeile"
' Logo
With .PageSetup.LeftFooterPicture
DateiExistiert = Not (GetAttr(ThisWorkbook.Path & "\" & "Logo3.jpg") _
And vbDirectory) = vbDirectory
If DateiExistiert Then
.Filename = ThisWorkbook.Path & "\" & "LOGO3.jpg"
Else
Zugriff_id = MsgBox("Kein Zugriff auf die Logo-Datei!", _
vbCritical + vbOKCancel + vbDefaultButton1)
If Zugriff_id = 2 Then Exit Sub
End If
.Height = Application.CentimetersToPoints(LogoHeight) _
- Application.CentimetersToPoints(LogoFusszeile)
' Debug.Print objSheet.Name & "=" & .Height & " " & nStep
End With
' Seiteneinrichtung
nStep = "PageSetup"
With .PageSetup
.LeftHeader = UserForm2.TextBox1.Text & Chr(10) & _
UserForm2.ComboBox1.Text & Chr(10) & _
"Datum" & vbTab & ": " & "&D"
.CenterHeader = "&""Arial,Bold""" & "&A"
.CenterFooter = "&""Arial,Standard""&F"
.RightFooter = "&""Arial,Standard""Seite &P von &N"
.LeftMargin = Application.CentimetersToPoints(1.5)
.RightMargin = Application.CentimetersToPoints(1.5)
.TopMargin = Application.CentimetersToPoints(2.2)
.BottomMargin = Application.CentimetersToPoints(1.8)
.HeaderMargin = Application.CentimetersToPoints(0.7)
.FooterMargin = Application.CentimetersToPoints(0.7)
' .PrintQuality = 600
.Orientation = Ausrichtung_txt
.PaperSize = Papier_txt
.FirstPageNumber = xlAutomatic
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
' Debug.Print objSheet.Name & "/Pagesetup/" & nStep
End With
End With
Next
Error_Handler:
If Err.Number 0 Then
MsgBox "Error at " & nStep & "!" & vbCrLf & _
Err.Description, _
vbCritical, "ErrNum:" & Err.Number
Err.Clear
End If
End Sub
Gruess Hansueli