更改 Excel VBA 创建的条形码形状的位置
Change position of Excel VBA created barcode shape
我发现这段代码将条形码创建为 Excel 内的形状。
我的问题是，创建的条形码总是从公式的右侧开始。例如，如果我使用 =BarCodefunction(B2)，我将获得在 C2 中创建的对象。我需要B3的条形码。
我试过更改 X、Y，但无法真正让它弹出到位。
代码中似乎也有错误。如果我有时在任何工作簿中更新 table，它可以自动创建跨不同工作表和工作簿的条形码。对这一切的任何帮助也会有所帮助。
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
只需更改 X、Y 和高度的 3 个代码行，条形码就会显示在下面的单元格中（而不是右边的下一个单元格）：
X = Input_Cell.Offset(1, 0).Left + 2
Y = Input_Cell.Offset(1, 0).Top + 2
Heigth = Input_Cell.Offset(1, 0).Height - 4
由于代码针对的是 ActiveSheet（即您当前看到的不同活动 sheet），因此它未绑定到特定的 sheet。如果您希望它仅在特定的 sheet 上工作，请将 ActiveSheet 换成 e。 G。 ActiveWorkbook.WorkSheets("My Barcode Sheet")
我发现这段代码将条形码创建为 Excel 内的形状。
我的问题是，创建的条形码总是从公式的右侧开始。例如，如果我使用 =BarCodefunction(B2)，我将获得在 C2 中创建的对象。我需要B3的条形码。
我试过更改 X、Y，但无法真正让它弹出到位。
代码中似乎也有错误。如果我有时在任何工作簿中更新 table，它可以自动创建跨不同工作表和工作簿的条形码。对这一切的任何帮助也会有所帮助。
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
只需更改 X、Y 和高度的 3 个代码行，条形码就会显示在下面的单元格中（而不是右边的下一个单元格）：
X = Input_Cell.Offset(1, 0).Left + 2
Y = Input_Cell.Offset(1, 0).Top + 2
Heigth = Input_Cell.Offset(1, 0).Height - 4
由于代码针对的是 ActiveSheet（即您当前看到的不同活动 sheet），因此它未绑定到特定的 sheet。如果您希望它仅在特定的 sheet 上工作，请将 ActiveSheet 换成 e。 G。 ActiveWorkbook.WorkSheets("My Barcode Sheet")