I made a VBA script that will read values from one sheet and create a "label" on another sheet.
This label is supposed to be printed on a special paper that is split in three parts.
Since I live in Sweden we use the A4 paper size (297x210 mm). The lables are supposed to be 99x210 mm.
This means each value needs to be printed on the exact position on the paper.
I do this for my company, thus all coputers are exactly the same.
Same model, same version of Windows, same version of Excel.
This is a smal part of the code (what is relevant to the positioning of text)
For i = 2 To Lastrow
' Location name
Sheets("Etikett").Range("A" & intRad) = Sheets("Bins").Range("A" & i)
With Sheets("Etikett").Range("A" & intRad & ":K" & intRad)
.MergeCells = True
.Font.Color = clr
.Font.Size = 150
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.BorderAround Weight:=xlThick
.Borders.Color = clr
.Borders(xlEdgeLeft).Weight = xlThick ' this may look odd but is needed
.Borders(xlEdgeRight).Weight = xlThick
End With
'Checknumber
Sheets("Etikett").Range("B" & intRad + 1) = Sheets("Bins").Range("B" & i)
With Sheets("Etikett").Range("B" & intRad + 1 & ":D" & intRad + 1)
.MergeCells = True
.Font.Color = clr
.Font.Size = 100
.NumberFormat = "00"
.Font.Bold = True
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
End With
' old location
If Sheets("Bins").Range("E" & i) <> "" Then
Sheets("Etikett").Range("K" & intRad + 1) = Sheets("Bins").Range("E" & i)
With Sheets("Etikett").Range("K" & intRad + 1)
.MergeCells = True
.Font.Color = clr
.Font.Size = 8
.Font.Bold = True
.VerticalAlignment = xlBottom
.HorizontalAlignment = xlLeft
End With
End If
' copy already premade barcode or generate barcode if not premade
If Sheets("Bins").Cells(i, 2) < 100 Then
Sheets("0-99").Select
shp = "B" & Right("0" & Sheets("Bins").Cells(i, 2), 2)
Sheets("0-99").Shapes(shp).Select
Else
Sheets("VBA").Select
ThisWorkbook.ActiveSheet.Shapes.SelectAll
Selection.Delete
Code128Generate_v2 30, 0, 40, 2.5, ThisWorkbook.ActiveSheet, Sheets("Bins").Cells(i, 2), 200
ThisWorkbook.ActiveSheet.Shapes.SelectAll
Selection.ShapeRange.Group.Select
End If
'color the barcode
Selection.ShapeRange.Line.ForeColor.RGB = clr
Selection.Copy
Sheets("Etikett").Select
Sheets("Etikett").Range("G" & intRad + 1 & ":J" & intRad + 1).MergeCells = True
' Set rowheights
Sheets("Etikett").Rows(intRad).RowHeight = 135
Sheets("Etikett").Rows(intRad + 1).RowHeight = 115
If Etikettcount Mod 3 = 0 Then ' if it's the last label on paper, no space is needed between this and the next.
Range("G" & intRad + 1).Select
intRad = intRad - 1
Else
Sheets("Etikett").Rows(intRad + 2).RowHeight = 25
Range("G" & intRad + 1).Select
End If
ActiveSheet.Paste ' paste barcode
Etikettcount = Etikettcount + 1
intRad = intRad + 3
End If
Next i
Keep in mind this is not all the code, but this is what copies the text and barcodes and places them on the sheet.
On my computer the output is as expected:
print output
On other computers the last character is slightly cut off and the vertical alignment is not correct.
As I wrote earlier I need the blank space between the lables to be at about 99 mm from the top and then 99 mm between them.
I have uploaded the full file if someone want to test it here: http://hoppvader.nu/docs/Streckkod.xlsm
Note that it's only module3 that is used, module2 is if you choose a checknumber "Checksiffra" other than 00-99.
Any help is appreciated on why it only works on my computer.
The output can be affected by many things like the printer's resolution, the desktop's resolution, the font or the size of the cells.
For instance, when I draw a 10cm by 10cm square shape on a new sheet, the printed result is a 10.5cm x 9.5cm rectangle even though the scaling is disabled in the page setup and in the advanced options.
To get an accurate output, one solution would be to draw the content on a Chart Sheet since any drawing on this type of sheet is printed to the exact size provided in centimeter :
Here's an example to add a Chart sheet and to create the labels:
Sub DrawLabel()
' add new empty Chart sheet '
Dim ch As Chart
Set ch = ThisWorkbook.Charts.Add()
ch.ChartArea.ClearContents
ch.ChartArea.Format.Fill.Visible = msoFalse
ch.ChartArea.Format.line.Visible = msoFalse
' setup page as A4 with no margin '
ch.PageSetup.PaperSize = xlPaperA4
ch.PageSetup.Orientation = xlPortrait
ch.PageSetup.LeftMargin = 0
ch.PageSetup.TopMargin = 0
ch.PageSetup.RightMargin = 0
ch.PageSetup.BottomMargin = 0
ch.PageSetup.HeaderMargin = 0
ch.PageSetup.FooterMargin = 0
DoEvents ' force update '
' add labels
AddText ch, x:=0.5, y:=0.5, w:=19.9, h:=4.6, Color:=vbRed, Border:=3, Size:=150, Text:="DB136C"
AddText ch, x:=2.5, y:=5.1, w:=5, h:=4, Color:=vbRed, Border:=0, Size:=100, Text:="79"
AddText ch, x:=0.5, y:=10, w:=19.9, h:=4.6, Color:=vbGreen, Border:=3, Size:=150, Text:="DB317A"
AddText ch, x:=2.5, y:=14.6, w:=5, h:=4, Color:=vbGreen, Border:=0, Size:=100, Text:="35"
AddText ch, x:=0.5, y:=19.5, w:=19.9, h:=4.6, Color:=vbBlack, Border:=3, Size:=150, Text:="AA102A"
AddText ch, x:=2.5, y:=24.1, w:=5, h:=4, Color:=vbBlack, Border:=0, Size:=100, Text:="10"
End Sub
Private Sub AddText(self As Chart, x#, y#, w#, h#, Color&, Border#, Size#, Text$)
With self.Shapes.AddTextBox( _
msoTextOrientationHorizontal, _
Application.CentimetersToPoints(x) - 8, _
Application.CentimetersToPoints(y) - 8, _
Application.CentimetersToPoints(w), _
Application.CentimetersToPoints(h))
.line.Weight = Border
.line.ForeColor.RGB = Color
.line.Visible = Border <> 0
.TextFrame.VerticalAlignment = xlVAlignCenter
.TextFrame.HorizontalAlignment = xlHAlignCenter
.TextFrame2.TextRange.Font.Name = "Calibri"
.TextFrame2.TextRange.Font.Size = Size
.TextFrame2.TextRange.Font.Bold = msoTrue
.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = Color
.TextFrame2.TextRange.Text = Text
End With
End Sub
If you love us? You can donate to us via Paypal or buy me a coffee so we can maintain and grow! Thank you!
Donate Us With