Weeble
Board Regular
- Joined
- Nov 30, 2016
- Messages
- 95
- Office Version
- 365
So I found this code that creates barcodes as an object, problem is the barcode that is created always ends up to the right side of the formula.
I've tried to change the X and Y variables, but can't really find a way so that it always posts it below the cell not to the right side of the cell.
Also it seams 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 is all about would also be helpful.
I've tried to change the X and Y variables, but can't really find a way so that it always posts it below the cell not to the right side of the cell.
Also it seams 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 is all about would also be helpful.
Code:
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 avbru****.", _
' 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
