I found this code that creates barcodes as a shape within Excel.
My problem is, that the created barcode always begins at the right side of the formula. For example if I use the =BarCodefunction(B2), I get the object created in C2. I need the barcode in B3.
I've tried changing the X, Y, but can't really get it to pop in place.
Also it seems to have a bug in the code. If I sometimes update a table in any workbook, it can automaticly create barcodes across different sheets and workbooks. Any help to what that is all about would also be helpful.
Option Explicit
Public Function BarCode_Function(Input_Cell As Range)
'------------------< BarCode_Function() >------------------
'< get Input >
Dim wert As String
wert = Input_Cell.Formula
Dim CellID As String
CellID = "BarCode_" & Input_Cell.Column & "_" & Input_Cell.Row
Dim x As Integer, Y As Integer, Heigth As Integer
x = Input_Cell.Left + Input_Cell.Width + 2
Y = Input_Cell.Top + 2
Heigth = Input_Cell.Height - 4
'</ get Input >
'< create Barcode 39 >
paintCode39 wert, ActiveSheet, "Barcode_" & CellID, 1, x, Y, Heigth
'</ create Barcode 39 >
On Error Resume Next
delete_Shape_Clones
'< Ausgabe >
BarCode_Function = ""
'</ Ausgabe >
'------------------</ BarCode_Function() >------------------
End Function
' -------------------------------------------------------------------
Public Sub paintCode39(ByVal Value As String, _
ByRef Sheet As Worksheet, _
ByVal Name As String, _
ByVal ScaleFactor As Integer, _
ByVal x As Integer, _
ByVal Y As Integer, _
ByVal Height As Integer _
)
' Skapa variabel
Dim i As Integer
Dim j As Integer
Dim sh As Shape
Dim code As String
Dim varArray() As Variant
Dim iCount As Integer
'Initiera positionsvariabeln
'vid behov lägg till start och stoppa tecken till det värde som ska visas
If Left(Value, 1) <> "*" Then Value = "*" & Value
If Right(Value, 1) <> "*" Then Value = Value & "*"
' Bestäm om det redan finns en gammal version av streckkoden
' ligger på arbetsbladet.
For Each sh In Sheet.Shapes
If sh.Name = Name Then
sh.Delete
End If
Next
'Gå igenom värdet som ska visas karaktär för tecken
For i = 1 To Len(Value)
' Koda nuvarande tecken enligt kartläggningstabellen
'Exempel: A blir 1101010010110
code = getCode(Mid(Value, i, 1))
' Kontrollera om giltig kodning hittades.
If code = "" Then
' MsgBox "Streckkodstillverkning avbrutits.", _
' vbCritical, _
' "Odefinierad karaktär"
Exit For
End If
' gå genom baren genom baren
For j = 1 To Len(code)
' Skapa nytt Shape-objekt med ScalFactor-bredd
Set sh = Sheet.Shapes.AddShape(msoShapeRectangle, _
x, _
Y, _
ScaleFactor, _
Height)
' X-Position för att öka bredden på ScalFactor
x = x + ScaleFactor
' Färg svart eller vitt beroende på aktuell kodform
If Mid(code, j, 1) = 1 Then
' Kode = 1 --> svart
sh.Fill.ForeColor.RGB = RGB(0, 0, 0)
sh.Line.ForeColor.RGB = RGB(0, 0, 0)
Else
' Kode = 0 --> Vit
sh.Fill.ForeColor.RGB = RGB(255, 255, 255)
sh.Line.ForeColor.RGB = RGB(255, 255, 255)
End If
'Lägg till staplar i array för senare gruppering
iCount = iCount + 1
ReDim Preserve varArray(1 To iCount)
varArray(iCount) = sh.Name
Next
Next
group:
'Gruppera alla tidigare skapade staplar till en enda grafik
Set sh = Sheet.Shapes.Range(varArray).group
' Namn grupperad grafik
sh.Name = Name
End Sub
Private Function getCode(ByVal Character As String) As String
Dim code As String
Select Case UCase(Character)
Case "*"
code = "1001011011010"
Case "0"
code = "1010011011010"
Case "1"
code = "1101001010110"
Case "2"
code = "1011001010110"
Case "3"
code = "1101100101010"
Case "4"
code = "1010011010110"
Case "5"
code = "1101001101010"
Case "6"
code = "1011001101010"
Case "7"
code = "1010010110110"
Case "8"
code = "1101001011010"
Case "9"
code = "1011001011010"
Case "A"
code = "1101010010110"
Case "B"
code = "1011010010110"
Case "C"
code = "1101101001010"
Case "D"
code = "1010110010110"
Case "E"
code = "1101011001010"
Case "F"
code = "1011011001010"
Case "G"
code = "1010100110110"
Case "H"
code = "1101010011010"
Case "I"
code = "1011010011010"
Case "J"
code = "1010110011010"
Case "K"
code = "1101010100110"
Case "L"
code = "1011010100110"
Case "M"
code = "1101101010010"
Case "N"
code = "1010110100110"
Case "O"
code = "1101011010010"
Case "P"
code = "1011011010010"
Case "Q"
code = "1010101100110"
Case "R"
code = "1101010110010"
Case "S"
code = "1011010110010"
Case "T"
code = "1010110110010"
Case "U"
code = "1100101010110"
Case "V"
code = "1001101010110"
Case "W"
code = "1100110101010"
Case "X"
code = "1001011010110"
Case "Y"
code = "1100101101010"
Case "Z"
code = "1001101101010"
Case "-"
code = "1001010110110"
Case "."
code = "1100101011010"
Case " "
code = "1001101011010"
Case "$"
code = "1001001001010"
Case "/"
code = "1001001010010"
Case "+"
code = "1001010010010"
Case "%"
code = "1010010010010"
Case Else
code = ""
End Select
getCode = code
End Function
Private Sub delete_Shape_Clones()
'-------------------< delete_Shape_Clones() >---------------
Dim Sheet As Worksheet
Set Sheet = ActiveSheet
Dim iShape As Integer
Dim nShapes As Integer
nShapes = Sheet.Shapes.Count
For iShape = 1 To nShapes
Dim objShape As Shape
Dim iLoop As Integer
For iLoop = iShape + 1 To nShapes
If Sheet.Shapes(iLoop).Name = Sheet.Shapes(iShape).Name Then
Sheet.Shapes(iLoop).Delete
nShapes = nShapes - 1
End If
Next
Next
'-------------------</ delete_Shape_Clones() >---------------
End Sub
Just change 3 code rows for X, Y, and Height by these, and the barcode is shown in the cell below (instead of next cell to the right):
X = Input_Cell.Offset(1, 0).Left + 2
Y = Input_Cell.Offset(1, 0).Top + 2
Heigth = Input_Cell.Offset(1, 0).Height - 4
As the code addresses the ActiveSheet (which is the varying active sheet you currently see), it's not bound to a specific sheet. If you want it to work on a specific sheet only, exchange ActiveSheet by e. g. ActiveWorkbook.WorkSheets("My Barcode Sheet")