How do you avoid different layout of Shape-objects on screen and printed out? - vba

Question

I created some kind of phone protocol sheet in excel and I wanted to add a section with quadrille paper for sketching purposes. Therefore I wrote a quite simple macro in VBA that draws horizontal and vertical lines in a selected range:
Public Sub Fill()
Dim angepeilteMaschenWeiteInPixel As Integer
angepeilteMaschenWeiteInPixel = 15
Dim LinienFarbe As Long
LinienFarbe = RGB(220, 220, 220)
Dim obenLinks As Double, obenRechts As Double
Dim untenLinks As Double, untenRechts As Double
Dim ausgewaehlteRange As Range
Set ausgewaehlteRange = Selection
' Anzahl Spalten und Zeilen ermitteln bei idealer Breite/Höhe 10px
Dim idealeSpaltenAnzahl As Integer
Dim idealeZeilenAnzahl As Integer
idealeSpaltenAnzahl = CInt(Round((ausgewaehlteRange.Width / angepeilteMaschenWeiteInPixel), 0))
idealeZeilenAnzahl = CInt(Round((ausgewaehlteRange.Height / angepeilteMaschenWeiteInPixel), 0))
' Aus der idealen Spalten- und Zeilenanzahl die ideale Maschenweite und - höhe in Pixeln ermitteln
Dim idealeMaschenBreite As Double
Dim idealeMaschenHoehe As Double
idealeMaschenBreite = ausgewaehlteRange.Width / CDbl(idealeSpaltenAnzahl)
idealeMaschenHoehe = ausgewaehlteRange.Height / CDbl(idealeZeilenAnzahl)
' vertikale Linien zeichnen
Dim i As Integer
For i = 1 To idealeSpaltenAnzahl - 1
Dim horizontal As Integer
horizontal = CInt(ausgewaehlteRange.Left + i * idealeMaschenBreite)
Dim oben As Integer
oben = Round(ausgewaehlteRange.Top, 0)
Dim unten As Integer
unten = Round(oben + ausgewaehlteRange.Height, 0)
With ActiveSheet.Shapes.AddLine(horizontal, oben, horizontal, unten).Line
.ForeColor.RGB = LinienFarbe
End With
Next i
' horizontale Linien zeichnen
Dim j As Integer
For j = 1 To idealeZeilenAnzahl - 1
Dim vertikal As Integer
vertikal = CInt(ausgewaehlteRange.Top + j * idealeMaschenHoehe)
Dim links As Integer
links = CInt(Round(ausgewaehlteRange.Left, 0))
Dim rechts As Integer
rechts = CInt(Round(links + ausgewaehlteRange.Width, 0))
With ActiveSheet.Shapes.AddLine(links, vertikal, rechts, vertikal).Line
.ForeColor.RGB = LinienFarbe
End With
Next j
End Sub
in excel everything looks fine:
but in the print preview and also printed out, the horizontal line gap is uneven and I have no idea why:
Anybody out there who can help me?

Answer 1

I suspect the lines are moving with the cells. Try setting the object positioning property to "Don't move or size with cells" which the English value is xlFreeFloating.
Example:
With ActiveSheet.Shapes.AddLine(links, vertikal, rechts, vertikal)
.Line.ForeColor.RGB = LinienFarbe
.Placement = xlFreeFloating
End With
Edit
Interesting behavior... I still think it's related to cells & margins as the lines move with cell width changes in print preview even though position is set to freeform.
I did find a workaround by grouping the lines together.
Added three lines of code. Add the following to both With blocks after Horizontal and Vertical lines are created.
.Select Replace:=False
Now add this line at the end of the sub:
Selection.Group
Now all the lines that were just created are grouped together.
Result image from print preview.
Example of last code block for your reference:
' horizontale Linien zeichnen
Dim j As Integer
For j = 1 To idealeZeilenAnzahl - 1
Dim vertikal As Integer
vertikal = CInt(ausgewaehlteRange.Top + j * idealeMaschenHoehe)
Dim links As Integer
links = CInt(Round(ausgewaehlteRange.Left, 0))
Dim rechts As Integer
rechts = CInt(Round(links + ausgewaehlteRange.Width, 0))
With ActiveSheet.Shapes.AddLine(links, vertikal, rechts, vertikal)
.Line.ForeColor.RGB = LinienFarbe
.Placement = xlFreeFloating
.Select Replace:=False
End With
Next j
Selection.Group
End Sub