Zoom-Wert aller Sheets auf PC-Auflösung anpassen

Computer: Software & Programmierung Visual Basic
#1

Hallo.

Habe den unten stehenden Code aus dem Internet und möchte ihn gerne auf mein Projekt anpassen. Es geht um die automatische Zoom-Anpassung an die PC-Auflösung.

Wie müsste der Code lauten, wenn ich nicht das aktive Fenster (activeWindow), sondern alle meine Arbeitsblätter auf einen neuen Zoom-Wert einstellen möchte?

Arbeitsblätter wären zurzeit:

Tabelle 1
Tabelle 2
Tabelle 3
Tabelle 4
Tabelle 5
Tabelle 6

Der Code:

Option Explicit

Private Declare Function GetSystemMetrics Lib „user32“ (ByVal nIndex As Long) As Long

Const SM_CXSCREEN = 0
Const SM_CYSCREEN = 1

Sub Aufloesung()
Dim intBreit As Integer
Dim intHoch As Integer
Dim strErgebnis As String
intBreit = GetSystemMetrics(SM_CXSCREEN) intHoch = GetSystemMetrics(SM_CYSCREEN) strErgebnis = intBreit & „x“ & intHoch
Select Case strErgebnis

Case „1280x1024“
ActiveWindow.Zoom = 75
Case „1024x768“
ActiveWindow.Zoom = 85
Case „800x600“
ActiveWindow.Zoom = 80
Case Else
MsgBox „Unbekannte Aufloesung“
End Select
End Sub

Vielen Dank im voraus.
Danny.

#2

Hallo Danny,

ich glaube, das ist eine der wenigen Gelegenheiten, wo man Select bzw. Activate braucht. Ich weiß nicht, wie man Excel dazu bringt, dass ein Workbook mehrere Fenster hat. Da man Zoom nur auf ein Fenster anwenden kann, sehe ich nur die Möglichkeit, nacheinander alle Worksheets in das Fenster (den Vordergrund) zu holen und dann zu zoomen. Das geht z.B. so:

Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Const SM\_CXSCREEN = 0
Const SM\_CYSCREEN = 1


Sub Aufloesung()
 Dim intBreit As Integer
 Dim intHoch As Integer
 Dim strErgebnis As String
 Dim zoomfactor As Integer
 Dim blatt As Worksheet

 intBreit = GetSystemMetrics(SM\_CXSCREEN)
 intHoch = GetSystemMetrics(SM\_CYSCREEN)
 strErgebnis = intBreit & "x" & intHoch
 zoomfactor = 0
 Select Case strErgebnis
 Case "1280x1024"
 zoomfactor = 75
 Case "1024x768"
 zoomfactor = 85
 Case "800x600"
 zoomfactor = 80
 Case Else
 MsgBox "Unbekannte Aufloesung"
 End Select
 If zoomfactor \> 0 Then
 For Each blatt In Worksheets
 blatt.Activate
 ActiveWindow.Zoom = zoomfactor
 Next blatt
 End If
End Sub

Gruß, Andreas

#3

Vielen Dank.

Das hilft mir sehr weiter!