Zelle unter der Mausposition #2

Druckgröße eines Diagramms anpassen

Die Größenangaben in Excel sind in den meisten Fällen Punkt (lt. Onlinehilfe etwa 0,35 mm).
Die Größe eines Punktes ist abhängig vom Ausgabegerät. Nehmen wir als Beispiel einen Punkt am Bildschirm. Ein Punkt ist laut Onlinehilfe 0,35 mm groß. Wie groß dieser nun am Bildschirm dargestellt wird, hängt von mehreren Faktoren ab:

Dabei muss man zum Einen die Pixelzahl, zum Anderen die Physikalische Breite des Monitors und zum dritten die Auflösung in DPI (meistens 96 DPI) berücksichtigen.
Mein 19 Zoll-Monitor hat eine sichtbare Breite von 14,37 Zoll. Dort können nebeneinander 1152 Pixel (1152x864) dargestellt werden. Bei einer Auflösung von 96 DPI sind also 12 virtuelle Zoll verfügbar (1152/96).

Auf dieses virtuelle Maß bezieht sich nun die Angabe der Punktgröße. Also wird ein Punkt am Bildschirm bei mir 1,197 mal (14,37/12) breiter dargestellt, als in der Onlinehilfe angegeben.
Am Bildschirm wird bei mir ein Diagramm von 100 mm Breite, das entspricht bei 0,35 mm/Punkt etwa 286 Punkten, also in einer Breite von ca. 11,8 cm dargestellt.

Die Ausgabe am Drucker kommt der Angabe in der OH schon etwas näher. Bei meinen Messungen ist ein Punkt in Y-Richtung etwa 0,35 mm groß. In X-Richtung scheint es sich um einen Didot-Punkt mit 0,376 mm zu handeln, man muss also nachmessen und die Punktgrößen eventuell etwas anpassen.

Das heißt, wenn ich 100 mm Breite haben möchte, sind das bei 0,35 mm/Punkt knapp 286 errechnete Punkte und genau so breit mache ich jetzt das Diagramm. Drucke ich anschließend das Blatt mit dem Diagramm aus, ist es aber auf dem Papier breiter als 100 mm. Dort kann also ein Punkt nicht 0,35 mm breit sein, sondern muss breiter sein.

Rechne ich jetzt mit 0,37 mm pro Punkt in der X-Richtung, komme ich auf knapp 270 Punkte. Mache ich das Diagramm also 270 Punkte breit und drucke das Tabellenblatt aus, komme ich auf eine, mit dem Lineal nachgemessene Diagrammbreite von ziemlich genau 100 mm.

In dem vorliegenden Beispiel ändere ich iterativ die PlotArea in 1-Punkt-Schritten in X - Richtung und lese bei jedem Schritt die InsideWidth aus. Passt diese mit dem Sollwert überein, wird abgebrochen. Anschließend mache ich das gleiche in der y-Richtung.
Vorher wird nochr gecheckt, wie groß der Inside-Bereich überhaupt werden kann, um nicht umsonst die iterative Größenänderung anzustoßen.

Dabei habe ich festgestellt, dass ab und zu nach Änderung in der Y-Richtung die vorher eingestellte InsideWidth nicht mehr mit dem Sollwert übereinstimmt. Ich kann es aber nicht auf Kommando wiederholen. Es passiert nicht oft, aber es passiert definitiv.

Deshalb habe ich ganz einfach noch einmal die Anpassung durchlaufen lassen, da sich die beiden Größen dann schon ziemlich nahe am Sollwert befinden und sich somit keine großen Änderungen mehr ergeben dürften.

Möglicherweise liegt das an der Ausgangsgröße des Diagramms oder der Plotarea, an der Reihenfolge der Anpassung oder auch nur an der automatischen Skalierung der Achsenbeschschriftungen. Diese fällt auch unangenehm mit (wenn auch kleinen) sprunghaften Größenänderungen auf.
Vielleicht habe ich aber auch tatsächlich nur irgendwo einen Fehler eingebaut.

Option Explicit

Public Sub Anpassen()
' Variablen zum Berechnen
Dim dblDiagrammbreite   As Double
Dim dblDiagrammhöhe     As Double
Dim dblWerteachse       As Double
Dim dblKategorieachse   As Double
Dim dblMaxInsightX      As Double
Dim dblMaxInsightY      As Double
Dim dblActX             As Double
Dim dblActY             As Double
Dim dblPunktX           As Double
Dim dblPunktY           As Double
Dim i                   As Long
Dim strAusgabe          As String

' Variablen für ursprüngliche Werte
Dim dblDiagrDX          As Double
Dim dblDiagrDY          As Double
Dim dblPlotDX           As Double
Dim dblPlotDY           As Double
Dim dblPlotX            As Double
Dim dblPlotY            As Double

' Objektvariable deklarieren
Dim wshMySheet          As Worksheet

' Initialisieren
Set wshMySheet = Worksheets("Tabelle1")
dblPunktX = 0.372 'mm pro Punkt Drucker in X-Richtung
dblPunktY = 0.349 'mm pro Punkt Drucker in Y-Richtung

With wshMySheet
   .Unprotect
   ' Aus dem Tabellenblatt die Zielgrößen holen
   dblDiagrammhöhe = .Range("E2") / dblPunktY
   dblDiagrammbreite = .Range("E3") / dblPunktX
   dblWerteachse = .Range("E4") / dblPunktY
   dblKategorieachse = .Range("E5") / dblPunktX

End With

With wshMySheet.ChartObjects(1)

   ' Ursprüngliche Diagrammbreite holen
   dblDiagrDX = .Width
   ' Breite anpassen
   .Width = dblDiagrammbreite
   strAusgabe = strAusgabe & "Diagrammbreite : " & .Width & " Punkt"

   ' Ursprüngliche Diagrammhöhe holen
   dblDiagrDY = .Height
   ' Höhe anpassen
   .Height = dblDiagrammhöhe
   strAusgabe = strAusgabe & vbCrLf & "Diagrammhöhe : " & .Height & " Punkt"

   With .Chart.PlotArea

      ' Ursprüngliche Werte für Position
      ' Innenbereich merken
      dblPlotX = .Left
      dblPlotY = .Top
      ' Position PlotArea ändern
      .Left = 0
      .Top = 0

      ' Ursprünglichen Wert Breite Innenbereich merken
      dblPlotDX = .Width
      '  Maximale Breite ermitteln
      .Width = dblDiagrammbreite
      dblMaxInsightX = .InsideWidth
      strAusgabe = strAusgabe & vbCrLf & _
         "Maximale Breite InsideWidth : " & dblMaxInsightX & " Punkt"

      ' Ursprünglichen Wert Höhe Innenbereich merken
      dblPlotDY = .Height
      '  Maximale Höhe ermitteln
      .Height = dblDiagrammhöhe
      dblMaxInsightY = .InsideHeight
      strAusgabe = strAusgabe & vbCrLf & _
         "Maximale Höhe InsideHeight : " & dblMaxInsightY & " Punkt"

      If dblMaxInsightX < dblKategorieachse Then
         MsgBox "Diagrammbreite zu niedrig"
         GoTo Fehlerbehandlung
      End If

      If dblMaxInsightY < dblWerteachse Then
         MsgBox "Diagrammhöhe zu niedrig"
         GoTo Fehlerbehandlung
      End If

      For i = 1 To 2
         ' Höhenanpassung beinflusst die Breite
         ' und umgekehrt, deshalb mehrfach
         ' durchlaufen

         ' Breite anpassen
         .Width = dblKategorieachse
         ' innere Breite auslesen
         dblActX = .InsideWidth
         Do While Abs(dblKategorieachse - dblActX) > 1.5
            ' Solange Breite anpassen, bis die
            ' innere Breite im Sollbereich liegt
            If dblActX < dblKategorieachse Then
               .Width = .Width + 1
            Else
               .Width = .Width - 1
            End If
            ' innere Breite auslesen
            dblActX = .InsideWidth
         Loop

         ' Höhe anpassen
         .Height = dblWerteachse
         ' innere Höhe auslesen
         dblActY = .InsideHeight
         Do While Abs(dblWerteachse - dblActY) > 1.5
            ' Solange Höhe anpassen, bis die
            ' innere Höhe im Sollbereich liegt
            If dblActY < dblWerteachse Then
               .Height = .Height + 1
            Else
               .Height = .Height - 1
            End If
            dblActY = .InsideHeight
         Loop

      Next

      strAusgabe = strAusgabe & vbCrLf & _
         "Breite InsideWidth : " & .InsideWidth & " Punkt"

      strAusgabe = strAusgabe & vbCrLf & _
         "Höhe InsideHeight : " & .InsideHeight & " Punkt"

   End With

End With

wshMySheet.EnableSelection = xlUnlockedCells
wshMySheet.Protect

MsgBox strAusgabe

Exit Sub
Fehlerbehandlung:

' Chartgröße wiederherstellen
With wshMySheet.ChartObjects(1)
   .Width = dblDiagrDX
   .Height = dblDiagrDY

   ' Innenbereich wiederherstellen
   With .Chart.PlotArea
      .Left = dblPlotX
      .Top = dblPlotY
      .Width = dblPlotDX
      .Height = dblPlotDY
   End With

End With
wshMySheet.EnableSelection = xlUnlockedCells
wshMySheet.Protect

End Sub