使用Excel VBA生成代码128条形码 [英] Generating Code 128 Barcodes using Excel VBA

查看：2471 发布时间：2017/9/3 23:14:19 excel vba code128

本文介绍了使用Excel VBA生成代码128条形码的处理方法，对大家解决问题具有一定的参考价值，需要的朋友们下面随着小编来一起学习吧！

问题描述

我试图通过使用VBA来获取Excel中生成的Code 128条形码。我发现一个VBA课程，有人通过VBForums（随后修改为使用Excel VBA）制作和共享，但我遇到问题使其工作。

如果我在启用Excel宏的电子表格中使用下面的代码，那么当尝试在任何输入上使用Code128_Str（）函数时，我会得到#VALUE错误。 p>

我没有必要的技巧来正确调试代码。如果这个脚本可以纠正，我认为这对许多尝试这样做的人来说是非常有用的。该脚本使用免费字体生成相关Code 128输出条形码。

参考资料：
http：//www.barcodeman .com / info / c128.php3 （字体下载）
http://www.vbforums.com/printthread.php?t=514742&pp=40&page=1 （原始论坛主题与代码）

***
'由Paul Curescu（CVMichael）制作***
'由Paulo Cunha（pcunha）修改，与char128.ttf一起使用word或excel on 16 / 05/2011
'的字体在http://grandzebu.net/index.php?page=/informatique/codbar-en/code128.htm

'参考文献：
'http://www.barcodeman.com/info/c128.php3

私人枚举eCode128Type
eCode128_CodeSetA = 1
eCode128_CodeSetB = 2
eCode128_CodeSetC = 3
End Enum

私有类型tCode
ASet As String
BSet As String
CSet As String
BarSpacePattern As String
结束类型

Private CodeArr（）作为tCode

私有子类Class_Initialize（）
ReDim CodeArr（106）

AddEntry 0，，，00 ，Chr（32）
AddEntry 1，！，！，01，Chr（33）
AddEntry 2，，，02 （34）
AddEntry 3，＃，＃，03，Chr（35）
AddEntry 4，$，$，04，Chr（36）
AddEntry 5，％，％，05，Chr（37）
AddEntry 6，&，&，06，Chr（38）
AddEntry 7，，，07，Chr（39）
AddEntry 8，（，（，08，Chr（40）
AddEntry 9， 09，Chr（41）
AddEntry 10，*，*，10，Chr（42）
AddEntry 11，+， +，11，Chr（43）
AddEntry 12，，，，，12，Chr（44）
AddEntry 13， - ， - ， 13，Chr（45）
AddEntry 14，。，。，14，Chr（46）
AddEntry 15，/，/，15 Chr（47）
AddEntry 16，0，0，16，Chr（48）
AddEntry 17，1，1，17
AddEntry 18，2，2，18，Chr（50）
AddEntr y 19，3，3，19，Chr（51）
AddEntry 20，4，4，20，Chr（52）
AddEntry 21， 5，5，21，Chr（53）
AddEntry 22，6，6，22，Chr（54）
AddEntry 23，7 7，23，Chr（55）
AddEntry 24，8，8，24，Chr（56）
AddEntry 25，9，9 25，Chr（57）
AddEntry 26，：，：，26，Chr（58）
AddEntry 27，;，;，27 （59）
AddEntry 28，<，" 28，Chr（60）
AddEntry 29，=，=，29 ）
AddEntry 30，>，>，30，Chr（62）
AddEntry 31，？，？，31，Chr（63）
AddEntry 32，@，@，32，Chr（64）
AddEntry 33，A，A，33，Chr（65）
AddEntry 34，B，B，34，Chr（66）
AddEntry 35，C，C，35，Chr（67）
AddEntry 36，D ，D，36，Chr（68）
AddEntry 37，E，E，37，Chr（69）
AddEntry 38，F ，38，Chr（70）
AddEntry 39，G，G，39，Chr（71）
AddEntry 40，H，H Chr（72）
AddEntry 41，I，I，41，Chr（73）
AddEntry 42，J，J，42
AddEntry 43，K，K，43，Chr（75）
AddEntry 44，L，L，44，Chr（76）
AddEntry 45，M，M，45，Chr（77）
AddEntry 46，N，N，46，Chr（78）
AddEntry 47， O，O，47，Chr（79）
AddEntry 48，P，P，48，Chr（80）
AddEntry 49，Q Q，49，Chr（81）
AddEntry 50，R，R，50，Chr（82）
AddEntry 51，S，S Chr（83）
AddEntry 52，T，T，52，Chr（84）
AddEntry 53，U，U，53 （85）
AddEntry 54，V，V，54，Chr（86）
AddEntry 55，W，W，55，Chr（87）
AddEntry 56，X，X，56，Chr（88）
AddEntry 57，Y，Y，57，Chr（89）
AddEntry 58，Z，Z，58，Chr（90）
AddEntry 59，[，[，59，Chr（91）
AddEntry 60， \\，\\，60，Chr（92）
AddEntry 61，]，]，61，Chr（93）
AddEntr y 62，^，^，62，Chr（94）
AddEntry 63，_，_，63，Chr（95）
AddEntry 64，Chr （0），`，64，Chr（96）'Null
AddEntry 65，Chr（1），a，65，Chr（97）'SOH
AddEntry 66 ，Chr（2），b，66，Chr（98）'STX
AddEntry 67，Chr（3），c，67，Chr（99）'ETX
AddEntry 68，Chr（4），d，68，Chr（100）'EOT
AddEntry 69，Chr（5），e，69，Chr（101）'ENQ
AddEntry 70，Chr（6），f，70，Chr（102）'ACK
AddEntry 71，Chr（7），g，71，Chr（103）
AddEntry 72，Chr（8），h，72，Chr（104）'BS
AddEntry 73，Chr（9），i，73 'HT
AddEntry 74，Chr（10），j，74，Chr（106）'LF
AddEntry 75，Chr（11），k，75 107）'VT
AddEntry 76，Chr（12），l，76，Chr（108）'FF
AddEntry 77，Chr（13），m，77 Chr（109）'CR
AddEntry 78，Chr（14），n，78，Chr（110）'SO
AddEntry 79，Chr（15），o，79 ，Chr（111）'SI
AddEntry 80，Chr（16），p，80，Chr（112）'DLE
AddEntry 81，Chr（17），q，81，Chr（113） DC1
AddEntry 82，Chr（18），r，82，Chr（114）'DC2
AddEntry 83，Chr（19），s，83 ）'DC3
AddEntry 84，Chr（20），t，84，Chr（116）'DC4
AddEntry 85，Chr（21），u，85 （117）'NAK
AddEntry 86，Chr（22），v，86，Chr（118）'SYN
AddEntry 87，Chr（23），w ，Chr（119）'ETB
AddEntry 88，Chr（24），x，88，Chr（120）'CAN
AddEntry 89，Chr（25），y 89，Chr（121）'EM
AddEntry 90，Chr（26），z，90，Chr（122）'SUB
AddEntry 91，Chr（27），91，Chr（123）'ESC
AddEntry 92，Chr（28），|，92，Chr（124）'FS
AddEntry 93，Chr（29） }，93，Chr（125）'GS
AddEntry 94，Chr（30），〜，94，Chr（126）'RS
AddEntry 95，Chr（31），Chr（127），95，Chr（200）'US，DEL
AddEntry 96，FNC 3，FNC 3，96，Chr 1）
AddEntry 97，FNC 2，FNC 2，97，Chr（202）
AddEntry 98，SHIFT，SHIFT，98
AddEntry 99，CODE C，CODE C，99，Chr（204）
AddEntry 100，CODE B，FNC 4，CODE B ）
AddEntry 101，FNC 4，CODE A，CODE A，Chr（206）
AddEntry 102，FNC 1，FNC 1，FNC 1 （207）
AddEntry 103，Start A，Start A，Start A，Chr（208）
AddEntry 104，Start B，Start B ，Chr（209）
AddEntry 105，Start C，Start C，Start C，Chr（210）
AddEntry 106，Stop，Stop Chr（211）
End Sub

Private Sub AddEntry（ByVal Index As Integer，ASet As String，BSet As String，CSet As String，BarSpacePattern As String）
With CodeArr索引）
.ASet = ASet
.BSet = BSet
.CSet = CSet
.BarSpacePattern = Replace（BarSpacePattern，，）
End With
End Sub

公共功能Code128_Str（ByVal Str A s String）
Code128_Str =替换（BuildStr（Str），，）
结束函数

私有函数BuildStr（ByVal Str As String）As String
Dim SCode As eCode128Type，PrevSCode As eCode128Type
Dim CurrChar As String，ArrIndex As Integer，CharIndex As Long
Dim CheckDigit As Integer，CCodeIndex As Integer，TotalSum As Long

SCode = eCode128_CodeSetB
如果Str像## *那么SCode = eCode128_CodeSetC

TotalSum = 0
CharIndex = 1

选择案例SCode
案例eCode128_CodeSetA
TotalSum = TotalSum +（103 * CharIndex）
BuildStr = Trim（BuildStr）& Chr（208）
案例eCode128_CodeSetB
TotalSum = TotalSum +（104 * CharIndex）
BuildStr = Trim（BuildStr）& Chr（209）
案例eCode128_CodeSetC
TotalSum = TotalSum +（105 * CharIndex）
BuildStr = Trim（BuildStr）& Chr（210）
结束选择

PrevSCode = SCode

Do Until Len（Str）= 0
如果Str Like#### * 然后SCode = eCode128_CodeSetC

如果SCode = eCode128_CodeSetC和Mid（Str，1，2）像##然后
CurrChar = Mid（Str，1，2）
Else
CurrChar = Mid（Str，1，1）
End If

ArrIndex = GetCharIndex（CurrChar，SCode，True）

如果ArrIndex< ;> -1然后
如果CodeArr（ArrIndex）.BSet = CurrChar和（（SCode = eCode128_CodeSetC和CodeArr（ArrIndex）.CSet&CurrChar）或（SCode = eCode128_CodeSetA和CodeArr（ArrIndex）.ASet& ; CurrChar））然后
SCode = eCode128_CodeSetB
ElseIf CodeArr（ArrIndex）.ASet = CurrChar和CodeArr（ArrIndex）.BSet& CurrChar然后
SCode = eCode128_CodeSetA
ElseIf CodeArr（ArrIndex）.CSet = CurrChar然后
SCode = eCode128_CodeSetC
End If

如果PrevSCode<> SCode然后
选择案例SCode
案例eCode128_CodeSetA
CCodeIndex = GetCharIndex（CODE A，PrevSCode，False）
案例eCode128_CodeSetB
CCodeIndex = GetCharIndex（CODE B ，PrevSCode，False）
案例eCode128_CodeSetC
CCodeIndex = GetCharIndex（CODE C，PrevSCode，False）
结束选择

TotalSum = TotalSum +（CCodeIndex * CharIndex ）
BuildStr = Trim（BuildStr）& CodeArr（CCodeIndex）.BarSpacePattern

CharIndex = CharIndex + 1
PrevSCode = SCode
End If

BuildStr = Trim（BuildStr）& CodeArr（ArrIndex）.BarSpacePattern

TotalSum = TotalSum +（ArrIndex * CharIndex）
CharIndex = CharIndex + 1
如果

如果SCode = eCode128_CodeSetC然后
Str = Mid（Str，3）
Else
Str = Mid（Str，2）
End If
Loop

CheckDigit = TotalSum Mod 103

BuildStr = Trim（BuildStr）& CodeArr（CheckDigit）.BarSpacePattern
BuildStr = Trim（BuildStr）& Chr（211）
结束函数

私有函数GetCharIndex（ByVal Char As String，ByVal CodeType As eCode128Type，ByVal Recurse As Boolean）As Integer
Dim K As Long

选择案例代码类型
案例eCode128_CodeSetA
对于K = 0到UBound（CodeArr）
如果Char = CodeArr（K）.ASet然后退出
下一个K
案例eCode128_CodeSetB
对于K = 0到UBound（CodeArr）
如果Char = CodeArr（K）.BSet然后退出
下一个K
案例eCode128_CodeSetC
对于K = 0到UBound（CodeArr）
如果Char = CodeArr（K）.CSet然后退出
下一个K
结束选择

如果K = UBound CodeArr）+ 1然后
如果不重复然后
GetCharIndex = -1
Else
选择案例CodeType
案例eCode128_CodeSetA
GetCharIndex = GetCharIndex（Char，eCode128_CodeSetC ，False）
案例eCode128_CodeSetB
GetCharIndex = GetCharIndex（Char，eCode128_CodeSetA，False）
案例eCode128_CodeSetC
GetCharIndex = GetCharIndex（Char，eCode128_CodeSetB，False）
结束选择

如果GetCharIndex = -1然后
选择案例CodeType
案例eCode128_CodeSetA
GetCharIndex = GetCharIndex（Char，eCode128_CodeSetB，False）
案例eCode128_CodeSetB
GetCharIndex = GetCharIndex（Char，eCode128_CodeSetC ，False）
案例eCode128_CodeSetC
GetCharIndex = GetCharIndex（Char，eCode128_CodeSetA，False）
结束选择
如果
结束If
Else
GetCharIndex = K
结束如果
结束函数

公共函数Code128_GetWidth（ByVal Str As String，可选ByVal BarWidth As Integer = 1）As Long
Dim K As Long，Width As Long

Str = Replace（Code128_Str（Str），，）
Debug.Print Str
对于K = 1 To Len（Str）
宽度=宽度+ Val（Mid（Str，K，1））
下一个K

Code128_GetWidth =宽度* BarWidth +（28 * BarWidth）
结束函数

私有子类_Terminate（）

结束子

解决方案

以下是如何使用它
您需要具有

< $>

模块（存储可从Excel
电子表格调用的UDF函数）

类模块（存储类对象）

模块
其中Class1是类模块的名称

 公共功能Code128_Str（ByVal Str As String）As String 
 Dim c As Class1 
 Set c = New Class1 
 Code128_Str = c.Code128_Str（Str）
结束函数

类模块

 '***由Michael Ciurescu（CVMichael）制作*** 
'由保罗修改Cunha（pcunha）与char128.ttf一起使用word或excel on 16/05/2011 
'的字体在http://grandzebu.net/index.php?page=/informatique/codbar-en/ code128.htm 
 
 
'参考资料：
'http://www.barcodeman.com/info/c128.php3 
 
私人枚举eCode128Type 
 eCode128_CodeSetA = 1 
 eCode128_CodeSetB = 2 
 eCode128_CodeSetC = 3 
结束枚举
 
私有类型tCode 
 ASet As String 
 BSet As String 
 CSet As String 
 BarSpacePattern As String 
结束类型
 
 Private CodeArr（）As tCode 
 
 Private Sub Class_Initialize（）
 ReDim CodeArr（106）
 
 AddEntry 0，，，00，Chr（32）
 AddEntry 1，！，！，01 ，Chr（33）
 AddEntry 2，，，02，Chr（34）
 AddEntry 3，＃，＃，03 （35）
 AddEntry 4，$，$，04，Chr（36 ）
 AddEntry 5，％，％，05，Chr（37）
 AddEntry 6，&，&，06，Chr（38）
 AddEntry 7，'，'，07，Chr（39）
 AddEntry 8，（，（，08，Chr（40）
 AddEntry 9，09，Chr（41）
 AddEntry 10，*，*，10，Chr（42）
 AddEntry 11， ，+，11，Chr（43）
 AddEntry 12，，，，，12，Chr（44）
 AddEntry 13， - ， - ，13，Chr（45）
 AddEntry 14，。，。，14，Chr（46）
 AddEntry 15，/，/， ，Chr（47）
 AddEntry 16，0，0，16，Chr（48）
 AddEntry 17，1，1，17 49）
 AddEntry 18，2，2，18，Chr（50）
 AddEntry 19，3，3，19，Chr（51）
 AddEntry 20，4，4，20，Chr（52）
 AddEntry 21，5，5，21，Chr（53）
 AddEntry 22 ，6，6，22，Chr（54）
 AddEntry 23，7，7，23，Chr（55）
 AddEntry 24，8 ，8，24，Chr（56）
 AddEntry 25，9，9，25，Chr（57）
 AddEntry 26，： ，：，26，Chr（58）
 AddEntry 27，;，;，27，Chr（59）
 AddEntry 28，<，< ;28，Chr（60）
 AddEntry 29，=，=，29，Chr（61）
 AddEntry 30，>，& ，30，Chr（62）
 AddEntry 31，？，？，31，Chr（63）
 AddEntry 32，@，@，32 ，Chr（64）
 AddEntry 33，A，A，33，Chr（65）
 AddEntry 34，B，B，34 ）
 AddEntry 35，C，C，35，Chr（67）
 AddEntry 36，D，D，36，Chr（68）
 AddEntry 37，E，E，37，Chr（69）
 AddEntry 38，F，F，38，Chr（70）
 AddEntry 39， G，G，39，Chr（71）
 AddEntry 40，H，H，40，Chr（72）
 AddEntry 41，I I，41，Chr（73）
 AddEntry 42，J，J，42，Chr（74）
 AddEntry 43，K，K 43，Chr（75）
 AddEntry 44，L，L，44，Chr（76）
 AddEntry 45，M，M，45 Chr（77）
 AddEntry 46，N，N，46，Chr（78）
 AddEntry 47，O，O，47 
 AddEntry 48，P，P，48，Chr（80）
 AddEntry 49，Q，Q，49，Chr（81）
 AddEntry 50，R，R，50，Chr（82）
 AddEntry 51，S，S，51，Chr（83）
 AddEntry 52，T ，T，52，Chr（84）
 AddEntry 53，U，U，53，Chr（85）
 AddEntry 54，V ，54，Chr（86）
 AddEntry 55，W，W，55，Chr（87）
 AddEntry 56，X，X ，Chr（88）
 AddEntry 57，Y，Y，57，Chr（89）
 AddEntry 58，Z，Z，58 90）
 AddEntry 59，[，[，59，Chr（91）
 AddEntry 60，\，\，60 
 AddEntry 61，]，]，61，Chr（93）
 AddEntry 62，^，^，62，Chr（94）
 AddEntry 63，_，_，63，Chr（95）
 AddEntry 64，Chr（0），`，64，Chr（96）'Null 
 AddEntry 65，Chr（1），a，65，Chr（97）'SOH 
 AddEntry 66，Chr（2），b，66，Chr（98）'STX 
 AddEntry 67，Chr（3），c，67，Chr（99）'ETX 
 AddEntry 68，Chr 4），d，68，Chr（100）'EOT 
 AddEntry 69，Chr（5），e，69，Chr（101）'ENQ 
 AddEntry 70， Chr（6），f，70，Chr（102）'ACK 
 AddEntry 71，Chr（7），g，71，Chr（103）'BEL 
 AddEntry 72，Chr（8），h，72，Chr（104）'BS 
 AddEntry 73，Chr（9），i，73，Chr（105）'HT 
 AddEntry 74，Chr（10），j，74，Chr（106）'LF 
 AddEntry 75，Chr（11），k，75，Chr（107） b $ b AddEntry 76，Chr（12），l，76，Chr（108）'FF 
 AddEntry 77，Chr（13），m，77，Chr（109） CR 
 AddEntry 78，Chr（14），n，78，Chr（110）'SO 
 AddEntry 79，Chr（15），o，79 ）'SI 
 AddEntry 80，Chr（16），p，80，Chr（112）'DLE 
 AddEntry 81，Chr（17），q，81 （113）'DC1 
 AddEntry 82，Chr（18），r，82，Chr（114）'DC2 
 AddEntry 83，Chr（19），s ，Chr（115）'DC3 
 AddEntry 84，Chr（20），t，84，Chr（116）'DC4 
 AddEntry 85，Chr（21），u 85，Chr（117）'NAK 
 AddEntry 86，Chr（22），v，86，Chr（118）'SYN 
 AddEntry 87，Chr（23） ，87，Chr（119）'ETB 
 AddEntry 88，Chr（24），x，88，Chr（120）'CAN 
 AddEntry 89，Chr（25） （23）Chr（121）'EM 
 AddEntry 90，Chr（26），z，90，Chr（122）'SUB 
 AddEntry 91，Chr（27） ，{，91，Chr（123）'ESC 
 AddEntry 92，Chr（28），|，92，Chr（124）'FS 
 AddEntry 93，Chr 29），}，93，Chr（125）'GS 
 AddEntry 94，Chr（30），〜，94，Chr（126）'RS 
 AddEntry 95， Chr（31），Chr（127），95，Chr（200）'US，DEL 
 AddEntry 96，FNC 3，FNC 3，96，Chr（201）
 AddEntry 97，FNC 2，FNC 2，97，Chr（202）
 AddEntry 98，SHIFT，SHIFT，98，Chr（203）
 AddEntry 99，CODE C，CODE C，99，Chr（204）
 AddEntry 100，CODE B，FNC 4，CODE B，Chr（205）
 AddEntry 101FNC 4，CODE A，CODE A，Chr（206）
 AddEntry 102，FNC 1，FNC 1 ，FNC 1，Chr（207）
 AddEntry 103，Start A，Start A，Start A，Chr（208）
 AddEntry 104，Start B B，起始B，Chr（209）
 AddEntry 105，Start C，Start C，Start C，Chr（210）
 AddEntry 106，Stop停止，停止，Chr（211）
 End Sub 
 
 Private Sub AddEntry（ByVal Index As Integer，ASet As String，BSet As String，CSet As String，BarSpacePattern As String） 
与CodeArr（索引）
 .ASet = ASet 
 .BSet = BSet 
 .CSet = CSet 
 .BarSpacePattern =替换（BarSpacePattern，，） 
结束
 End Sub 
 
公共功能Code128_Str（ByVal Str As String）
 Code128_Str =替换（BuildStr（Str），，）
结束函数
 
私有函数BuildStr（ByVal Str As String）As String 
 Dim SCode As eCode128Type，PrevSCode As eCode128Type 
 Dim CurrChar As String，ArrIndex As Integer，CharIndex As Long 
 Dim CheckDigit As Integer，CCodeIndex As Integer，TotalSum As Long 
 
 SCode = eCode128_CodeSetB 
如果Str像## *那么SCode = eCode128_CodeSetC 
 
 TotalSum = 0 
 CharIndex = 1 
 
选择案例SCode 
案例eCode128_CodeSetA 
 TotalSum = TotalSum +（103 * CharIndex）
 BuildStr = Trim（BuildStr）& Chr（208）
案例eCode128_CodeSetB 
 TotalSum = TotalSum +（104 * CharIndex）
 BuildStr = Trim（BuildStr）& Chr（209）
案例eCode128_CodeSetC 
 TotalSum = TotalSum +（105 * CharIndex）
 BuildStr = Trim（BuildStr）& Chr（210）
结束选择
 
 PrevSCode = SCode 
 
 Do Until Len（Str）= 0 
如果Str Like#### * 然后SCode = eCode128_CodeSetC 
 
如果SCode = eCode128_CodeSetC和Mid（Str，1，2）像##然后
 CurrChar = Mid（Str，1，2）
 Else 
 CurrChar = Mid（Str，1，1）
 End If 
 
 ArrIndex = GetCharIndex（CurrChar，SCode，True）
 
如果ArrIndex< ;> -1然后
如果CodeArr（ArrIndex）.BSet = CurrChar和（（SCode = eCode128_CodeSetC和CodeArr（ArrIndex）.CSet&CurrChar）或（SCode = eCode128_CodeSetA和CodeArr（ArrIndex）.ASet& ; CurrChar））然后
 SCode = eCode128_CodeSetB 
 ElseIf CodeArr（ArrIndex）.ASet = CurrChar和CodeArr（ArrIndex）.BSet& CurrChar然后
 SCode = eCode128_CodeSetA 
 ElseIf CodeArr（ArrIndex）.CSet = CurrChar然后
 SCode = eCode128_CodeSetC 
 End If 
 
如果PrevSCode<> SCode然后
选择案例SCode 
案例eCode128_CodeSetA 
 CCodeIndex = GetCharIndex（CODE A，PrevSCode，False）
案例eCode128_CodeSetB 
 CCodeIndex = GetCharIndex（CODE B ，PrevSCode，False）
案例eCode128_CodeSetC 
 CCodeIndex = GetCharIndex（CODE C，PrevSCode，False）
结束选择
 
 TotalSum = TotalSum +（CCodeIndex * CharIndex ）
 BuildStr = Trim（BuildStr）& CodeArr（CCodeIndex）.BarSpacePattern 
 
 CharIndex = CharIndex + 1 
 PrevSCode = SCode 
 End If 
 
 BuildStr = Trim（BuildStr）& CodeArr（ArrIndex）.BarSpacePattern 
 
 TotalSum = TotalSum +（ArrIndex * CharIndex）
 CharIndex = CharIndex + 1 
如果
 
如果SCode = eCode128_CodeSetC然后
 Str = Mid（Str，3）
 Else 
 Str = Mid（Str，2）
 End If 
 Loop 
 
 CheckDigit = TotalSum Mod 103 
 
 BuildStr = Trim（BuildStr）& CodeArr（CheckDigit）.BarSpacePattern 
 BuildStr = Trim（BuildStr）& Chr（211）
结束函数
 
私有函数GetCharIndex（ByVal Char As String，ByVal CodeType As eCode128Type，ByVal Recurse As Boolean）As Integer 
 Dim K As Long 
 
选择案例代码类型
案例eCode128_CodeSetA 
对于K = 0到UBound（CodeArr）
如果Char = CodeArr（K）.ASet然后退出
下一个K 
案例eCode128_CodeSetB 
对于K = 0到UBound（CodeArr）
如果Char = CodeArr（K）.BSet然后退出
下一个K 
案例eCode128_CodeSetC 
对于K = 0到UBound（CodeArr）
如果Char = CodeArr（K）.CSet然后退出
下一个K 
结束选择
 
如果K = UBound CodeArr）+ 1然后
如果不重复然后
 GetCharIndex = -1 
 Else 
选择案例CodeType 
案例eCode128_CodeSetA 
 GetCharIndex = GetCharIndex（Char，eCode128_CodeSetC ，False）
案例eCode128_CodeSetB 
 GetCharIndex = GetCharIndex（Char，eCode128_CodeSetA，False）
案例eCode128_CodeSetC 
 GetCharIndex = GetCharIndex（Char，eCode128_CodeSetB，False）
结束选择
 
如果GetCharIndex = -1然后
选择案例CodeType 
案例eCode128_CodeSetA 
 GetCharIndex = GetCharIndex（Char，eCode128_CodeSetB，False）
案例eCode128_CodeSetB 
 GetCharIndex = GetCharIndex（Char，eCode128_CodeSetC ，False）
案例eCode128_CodeSetC 
 GetCharIndex = GetCharIndex（Char，eCode128_CodeSetA，False）
结束选择
如果
结束If 
 Else 
 GetCharIndex = K 
结束如果
结束函数
 
公共函数Code128_GetWidth（ByVal Str As String，可选ByVal BarWidth As Integer = 1）As Long 
 Dim K As Long，Width As Long 
 
 Str = Replace（Code128_Str（Str），，）
 Debug.Print Str 
对于K = 1 To Len（Str）
宽度=宽度+ Val（Mid（Str，K，1））
下一个K 
 
 Code128_GetWidth =宽度* BarWidth +（28 * BarWidth）
结束函数
 
 
 
私有子类_Terminate（）
 
结束子

然后在SpreadSheet中，在任何单元格中，可以调用
= Code128_Str（TESTING）
或
= Code128_Str（A1）

I'm trying to get Code 128 barcodes generated in Excel, through the use of VBA. I've found a VBA class that somebody made and shared via VBForums (subsequently modified to work with Excel VBA), but I'm having problems getting it to work.

If I use the code below in an Excel Macro-enabled spreadsheet, I get the #VALUE error when trying to use the Code128_Str() function on any input.

I lack the necessary skills to debug the code properly. If this script can be corrected, I think it would be immensely useful to many people trying to do the same. The script in question uses the free font to generate the relevant Code 128 output barcodes.

References: http://www.barcodeman.com/info/c128.php3 (Font Download) http://www.vbforums.com/printthread.php?t=514742&pp=40&page=1 (Original Forum Thread with Code)

' ***    Made By Michael Ciurescu (CVMichael)   ***
'Modified by Paulo Cunha (pcunha) to work with char128.ttf on word or excel on 16/05/2011
'the font at in http://grandzebu.net/index.php?page=/informatique/codbar-en/code128.htm


' References:
' http://www.barcodeman.com/info/c128.php3

Private Enum eCode128Type
    eCode128_CodeSetA = 1
    eCode128_CodeSetB = 2
    eCode128_CodeSetC = 3
End Enum

Private Type tCode
    ASet As String
    BSet As String
    CSet As String
    BarSpacePattern As String
End Type

Private CodeArr() As tCode

Private Sub Class_Initialize()
    ReDim CodeArr(106)

    AddEntry 0, " ", " ", "00", Chr(32)
    AddEntry 1, "!", "!", "01", Chr(33)
    AddEntry 2, """", """", "02", Chr(34)
    AddEntry 3, "#", "#", "03", Chr(35)
    AddEntry 4, "$", "$", "04", Chr(36)
    AddEntry 5, "%", "%", "05", Chr(37)
    AddEntry 6, "&", "&", "06", Chr(38)
    AddEntry 7, "'", "'", "07", Chr(39)
    AddEntry 8, "(", "(", "08", Chr(40)
    AddEntry 9, ")", ")", "09", Chr(41)
    AddEntry 10, "*", "*", "10", Chr(42)
    AddEntry 11, "+", "+", "11", Chr(43)
    AddEntry 12, ",", ",", "12", Chr(44)
    AddEntry 13, "-", "-", "13", Chr(45)
    AddEntry 14, ".", ".", "14", Chr(46)
    AddEntry 15, "/", "/", "15", Chr(47)
    AddEntry 16, "0", "0", "16", Chr(48)
    AddEntry 17, "1", "1", "17", Chr(49)
    AddEntry 18, "2", "2", "18", Chr(50)
    AddEntry 19, "3", "3", "19", Chr(51)
    AddEntry 20, "4", "4", "20", Chr(52)
    AddEntry 21, "5", "5", "21", Chr(53)
    AddEntry 22, "6", "6", "22", Chr(54)
    AddEntry 23, "7", "7", "23", Chr(55)
    AddEntry 24, "8", "8", "24", Chr(56)
    AddEntry 25, "9", "9", "25", Chr(57)
    AddEntry 26, ":", ":", "26", Chr(58)
    AddEntry 27, ";", ";", "27", Chr(59)
    AddEntry 28, "<", "<", "28", Chr(60)
    AddEntry 29, "=", "=", "29", Chr(61)
    AddEntry 30, ">", ">", "30", Chr(62)
    AddEntry 31, "?", "?", "31", Chr(63)
    AddEntry 32, "@", "@", "32", Chr(64)
    AddEntry 33, "A", "A", "33", Chr(65)
    AddEntry 34, "B", "B", "34", Chr(66)
    AddEntry 35, "C", "C", "35", Chr(67)
    AddEntry 36, "D", "D", "36", Chr(68)
    AddEntry 37, "E", "E", "37", Chr(69)
    AddEntry 38, "F", "F", "38", Chr(70)
    AddEntry 39, "G", "G", "39", Chr(71)
    AddEntry 40, "H", "H", "40", Chr(72)
    AddEntry 41, "I", "I", "41", Chr(73)
    AddEntry 42, "J", "J", "42", Chr(74)
    AddEntry 43, "K", "K", "43", Chr(75)
    AddEntry 44, "L", "L", "44", Chr(76)
    AddEntry 45, "M", "M", "45", Chr(77)
    AddEntry 46, "N", "N", "46", Chr(78)
    AddEntry 47, "O", "O", "47", Chr(79)
    AddEntry 48, "P", "P", "48", Chr(80)
    AddEntry 49, "Q", "Q", "49", Chr(81)
    AddEntry 50, "R", "R", "50", Chr(82)
    AddEntry 51, "S", "S", "51", Chr(83)
    AddEntry 52, "T", "T", "52", Chr(84)
    AddEntry 53, "U", "U", "53", Chr(85)
    AddEntry 54, "V", "V", "54", Chr(86)
    AddEntry 55, "W", "W", "55", Chr(87)
    AddEntry 56, "X", "X", "56", Chr(88)
    AddEntry 57, "Y", "Y", "57", Chr(89)
    AddEntry 58, "Z", "Z", "58", Chr(90)
    AddEntry 59, "[", "[", "59", Chr(91)
    AddEntry 60, "\", "\", "60", Chr(92)
    AddEntry 61, "]", "]", "61", Chr(93)
    AddEntry 62, "^", "^", "62", Chr(94)
    AddEntry 63, "_", "_", "63", Chr(95)
    AddEntry 64, Chr(0), "`", "64", Chr(96) ' Null
    AddEntry 65, Chr(1), "a", "65", Chr(97) ' SOH
    AddEntry 66, Chr(2), "b", "66", Chr(98) ' STX
    AddEntry 67, Chr(3), "c", "67", Chr(99) ' ETX
    AddEntry 68, Chr(4), "d", "68", Chr(100) ' EOT
    AddEntry 69, Chr(5), "e", "69", Chr(101) ' ENQ
    AddEntry 70, Chr(6), "f", "70", Chr(102) ' ACK
    AddEntry 71, Chr(7), "g", "71", Chr(103) ' BEL
    AddEntry 72, Chr(8), "h", "72", Chr(104) ' BS
    AddEntry 73, Chr(9), "i", "73", Chr(105) ' HT
    AddEntry 74, Chr(10), "j", "74", Chr(106) ' LF
    AddEntry 75, Chr(11), "k", "75", Chr(107) ' VT
    AddEntry 76, Chr(12), "l", "76", Chr(108) ' FF
    AddEntry 77, Chr(13), "m", "77", Chr(109) ' CR
    AddEntry 78, Chr(14), "n", "78", Chr(110) ' SO
    AddEntry 79, Chr(15), "o", "79", Chr(111) ' SI
    AddEntry 80, Chr(16), "p", "80", Chr(112) ' DLE
    AddEntry 81, Chr(17), "q", "81", Chr(113) ' DC1
    AddEntry 82, Chr(18), "r", "82", Chr(114) ' DC2
    AddEntry 83, Chr(19), "s", "83", Chr(115) ' DC3
    AddEntry 84, Chr(20), "t", "84", Chr(116) ' DC4
    AddEntry 85, Chr(21), "u", "85", Chr(117) ' NAK
    AddEntry 86, Chr(22), "v", "86", Chr(118) ' SYN
    AddEntry 87, Chr(23), "w", "87", Chr(119) ' ETB
    AddEntry 88, Chr(24), "x", "88", Chr(120) ' CAN
    AddEntry 89, Chr(25), "y", "89", Chr(121) ' EM
    AddEntry 90, Chr(26), "z", "90", Chr(122) ' SUB
    AddEntry 91, Chr(27), "{", "91", Chr(123) ' ESC
    AddEntry 92, Chr(28), "|", "92", Chr(124) ' FS
    AddEntry 93, Chr(29), "}", "93", Chr(125) ' GS
    AddEntry 94, Chr(30), "~", "94", Chr(126) ' RS
    AddEntry 95, Chr(31), Chr(127), "95", Chr(200) ' US, DEL
    AddEntry 96, "FNC 3", "FNC 3", "96", Chr(201)
    AddEntry 97, "FNC 2", "FNC 2", "97", Chr(202)
    AddEntry 98, "SHIFT", "SHIFT", "98", Chr(203)
    AddEntry 99, "CODE C", "CODE C", "99", Chr(204)
    AddEntry 100, "CODE B", "FNC 4", "CODE B", Chr(205)
    AddEntry 101, "FNC 4", "CODE A", "CODE A", Chr(206)
    AddEntry 102, "FNC 1", "FNC 1", "FNC 1", Chr(207)
    AddEntry 103, "Start A", "Start A", "Start A", Chr(208)
    AddEntry 104, "Start B", "Start B", "Start B", Chr(209)
    AddEntry 105, "Start C", "Start C", "Start C", Chr(210)
    AddEntry 106, "Stop", "Stop", "Stop", Chr(211)
End Sub

Private Sub AddEntry(ByVal Index As Integer, ASet As String, BSet As String, CSet As String, BarSpacePattern As String)
    With CodeArr(Index)
        .ASet = ASet
        .BSet = BSet
        .CSet = CSet
        .BarSpacePattern = Replace(BarSpacePattern, " ", "")
    End With
End Sub

Public Function Code128_Str(ByVal Str As String)
    Code128_Str = Replace(BuildStr(Str), " ", "")
End Function

Private Function BuildStr(ByVal Str As String) As String
    Dim SCode As eCode128Type, PrevSCode As eCode128Type
    Dim CurrChar As String, ArrIndex As Integer, CharIndex As Long
    Dim CheckDigit As Integer, CCodeIndex As Integer, TotalSum As Long

    SCode = eCode128_CodeSetB
    If Str Like "##*" Then SCode = eCode128_CodeSetC

    TotalSum = 0
    CharIndex = 1

    Select Case SCode
    Case eCode128_CodeSetA
        TotalSum = TotalSum + (103 * CharIndex)
        BuildStr = Trim(BuildStr) & Chr(208)
    Case eCode128_CodeSetB
        TotalSum = TotalSum + (104 * CharIndex)
        BuildStr = Trim(BuildStr) & Chr(209)
    Case eCode128_CodeSetC
        TotalSum = TotalSum + (105 * CharIndex)
        BuildStr = Trim(BuildStr) & Chr(210)
    End Select

    PrevSCode = SCode

    Do Until Len(Str) = 0
        If Str Like "####*" Then SCode = eCode128_CodeSetC

        If SCode = eCode128_CodeSetC And Mid(Str, 1, 2) Like "##" Then
            CurrChar = Mid(Str, 1, 2)
        Else
            CurrChar = Mid(Str, 1, 1)
        End If

        ArrIndex = GetCharIndex(CurrChar, SCode, True)

        If ArrIndex <> -1 Then
            If CodeArr(ArrIndex).BSet = CurrChar And ((SCode = eCode128_CodeSetC And CodeArr(ArrIndex).CSet <> CurrChar) Or (SCode = eCode128_CodeSetA And CodeArr(ArrIndex).ASet <> CurrChar)) Then
                SCode = eCode128_CodeSetB
            ElseIf CodeArr(ArrIndex).ASet = CurrChar And CodeArr(ArrIndex).BSet <> CurrChar Then
                SCode = eCode128_CodeSetA
            ElseIf CodeArr(ArrIndex).CSet = CurrChar Then
                SCode = eCode128_CodeSetC
            End If

            If PrevSCode <> SCode Then
                Select Case SCode
                Case eCode128_CodeSetA
                    CCodeIndex = GetCharIndex("CODE A", PrevSCode, False)
                Case eCode128_CodeSetB
                    CCodeIndex = GetCharIndex("CODE B", PrevSCode, False)
                Case eCode128_CodeSetC
                    CCodeIndex = GetCharIndex("CODE C", PrevSCode, False)
                End Select

                TotalSum = TotalSum + (CCodeIndex * CharIndex)
                BuildStr = Trim(BuildStr) & CodeArr(CCodeIndex).BarSpacePattern

                CharIndex = CharIndex + 1
                PrevSCode = SCode
            End If

            BuildStr = Trim(BuildStr) & CodeArr(ArrIndex).BarSpacePattern

            TotalSum = TotalSum + (ArrIndex * CharIndex)
            CharIndex = CharIndex + 1
        End If

        If SCode = eCode128_CodeSetC Then
            Str = Mid(Str, 3)
        Else
            Str = Mid(Str, 2)
        End If
    Loop

    CheckDigit = TotalSum Mod 103

    BuildStr = Trim(BuildStr) & CodeArr(CheckDigit).BarSpacePattern
    BuildStr = Trim(BuildStr) & Chr(211)
End Function

Private Function GetCharIndex(ByVal Char As String, ByVal CodeType As eCode128Type, ByVal Recurse As Boolean) As Integer
    Dim K As Long

    Select Case CodeType
    Case eCode128_CodeSetA
        For K = 0 To UBound(CodeArr)
            If Char = CodeArr(K).ASet Then Exit For
        Next K
    Case eCode128_CodeSetB
        For K = 0 To UBound(CodeArr)
            If Char = CodeArr(K).BSet Then Exit For
        Next K
    Case eCode128_CodeSetC
        For K = 0 To UBound(CodeArr)
            If Char = CodeArr(K).CSet Then Exit For
        Next K
    End Select

    If K = UBound(CodeArr) + 1 Then
        If Not Recurse Then
            GetCharIndex = -1
        Else
            Select Case CodeType
            Case eCode128_CodeSetA
                GetCharIndex = GetCharIndex(Char, eCode128_CodeSetC, False)
            Case eCode128_CodeSetB
                GetCharIndex = GetCharIndex(Char, eCode128_CodeSetA, False)
            Case eCode128_CodeSetC
                GetCharIndex = GetCharIndex(Char, eCode128_CodeSetB, False)
            End Select

            If GetCharIndex = -1 Then
                Select Case CodeType
                Case eCode128_CodeSetA
                    GetCharIndex = GetCharIndex(Char, eCode128_CodeSetB, False)
                Case eCode128_CodeSetB
                    GetCharIndex = GetCharIndex(Char, eCode128_CodeSetC, False)
                Case eCode128_CodeSetC
                    GetCharIndex = GetCharIndex(Char, eCode128_CodeSetA, False)
                End Select
            End If
        End If
    Else
        GetCharIndex = K
    End If
End Function

Public Function Code128_GetWidth(ByVal Str As String, Optional ByVal BarWidth As Integer = 1) As Long
    Dim K As Long, Width As Long

    Str = Replace(Code128_Str(Str), " ", "")
    Debug.Print Str
    For K = 1 To Len(Str)
        Width = Width + Val(Mid(Str, K, 1))
    Next K

    Code128_GetWidth = Width * BarWidth + (28 * BarWidth)
End Function



Private Sub Class_Terminate()

End Sub

解决方案

Here's how to use it You need to have

Module (To store the UDF function which you can call from Excel spreadsheet)
Class Module (To store the class object)

Module Where Class1 is the name of the Class Module

Public Function Code128_Str(ByVal Str As String) As String
Dim c As Class1
Set c = New Class1
Code128_Str = c.Code128_Str(Str)
End Function

Class Module

' ***    Made By Michael Ciurescu (CVMichael)   ***
'Modified by Paulo Cunha (pcunha) to work with char128.ttf on word or excel on 16/05/2011
'the font at in http://grandzebu.net/index.php?page=/informatique/codbar-en/code128.htm


' References:
' http://www.barcodeman.com/info/c128.php3

Private Enum eCode128Type
    eCode128_CodeSetA = 1
    eCode128_CodeSetB = 2
    eCode128_CodeSetC = 3
End Enum

Private Type tCode
    ASet As String
    BSet As String
    CSet As String
    BarSpacePattern As String
End Type

Private CodeArr() As tCode

Private Sub Class_Initialize()
    ReDim CodeArr(106)

    AddEntry 0, " ", " ", "00", Chr(32)
    AddEntry 1, "!", "!", "01", Chr(33)
    AddEntry 2, """", """", "02", Chr(34)
    AddEntry 3, "#", "#", "03", Chr(35)
    AddEntry 4, "$", "$", "04", Chr(36)
    AddEntry 5, "%", "%", "05", Chr(37)
    AddEntry 6, "&", "&", "06", Chr(38)
    AddEntry 7, "'", "'", "07", Chr(39)
    AddEntry 8, "(", "(", "08", Chr(40)
    AddEntry 9, ")", ")", "09", Chr(41)
    AddEntry 10, "*", "*", "10", Chr(42)
    AddEntry 11, "+", "+", "11", Chr(43)
    AddEntry 12, ",", ",", "12", Chr(44)
    AddEntry 13, "-", "-", "13", Chr(45)
    AddEntry 14, ".", ".", "14", Chr(46)
    AddEntry 15, "/", "/", "15", Chr(47)
    AddEntry 16, "0", "0", "16", Chr(48)
    AddEntry 17, "1", "1", "17", Chr(49)
    AddEntry 18, "2", "2", "18", Chr(50)
    AddEntry 19, "3", "3", "19", Chr(51)
    AddEntry 20, "4", "4", "20", Chr(52)
    AddEntry 21, "5", "5", "21", Chr(53)
    AddEntry 22, "6", "6", "22", Chr(54)
    AddEntry 23, "7", "7", "23", Chr(55)
    AddEntry 24, "8", "8", "24", Chr(56)
    AddEntry 25, "9", "9", "25", Chr(57)
    AddEntry 26, ":", ":", "26", Chr(58)
    AddEntry 27, ";", ";", "27", Chr(59)
    AddEntry 28, "<", "<", "28", Chr(60)
    AddEntry 29, "=", "=", "29", Chr(61)
    AddEntry 30, ">", ">", "30", Chr(62)
    AddEntry 31, "?", "?", "31", Chr(63)
    AddEntry 32, "@", "@", "32", Chr(64)
    AddEntry 33, "A", "A", "33", Chr(65)
    AddEntry 34, "B", "B", "34", Chr(66)
    AddEntry 35, "C", "C", "35", Chr(67)
    AddEntry 36, "D", "D", "36", Chr(68)
    AddEntry 37, "E", "E", "37", Chr(69)
    AddEntry 38, "F", "F", "38", Chr(70)
    AddEntry 39, "G", "G", "39", Chr(71)
    AddEntry 40, "H", "H", "40", Chr(72)
    AddEntry 41, "I", "I", "41", Chr(73)
    AddEntry 42, "J", "J", "42", Chr(74)
    AddEntry 43, "K", "K", "43", Chr(75)
    AddEntry 44, "L", "L", "44", Chr(76)
    AddEntry 45, "M", "M", "45", Chr(77)
    AddEntry 46, "N", "N", "46", Chr(78)
    AddEntry 47, "O", "O", "47", Chr(79)
    AddEntry 48, "P", "P", "48", Chr(80)
    AddEntry 49, "Q", "Q", "49", Chr(81)
    AddEntry 50, "R", "R", "50", Chr(82)
    AddEntry 51, "S", "S", "51", Chr(83)
    AddEntry 52, "T", "T", "52", Chr(84)
    AddEntry 53, "U", "U", "53", Chr(85)
    AddEntry 54, "V", "V", "54", Chr(86)
    AddEntry 55, "W", "W", "55", Chr(87)
    AddEntry 56, "X", "X", "56", Chr(88)
    AddEntry 57, "Y", "Y", "57", Chr(89)
    AddEntry 58, "Z", "Z", "58", Chr(90)
    AddEntry 59, "[", "[", "59", Chr(91)
    AddEntry 60, "\", "\", "60", Chr(92)
    AddEntry 61, "]", "]", "61", Chr(93)
    AddEntry 62, "^", "^", "62", Chr(94)
    AddEntry 63, "_", "_", "63", Chr(95)
    AddEntry 64, Chr(0), "`", "64", Chr(96) ' Null
    AddEntry 65, Chr(1), "a", "65", Chr(97) ' SOH
    AddEntry 66, Chr(2), "b", "66", Chr(98) ' STX
    AddEntry 67, Chr(3), "c", "67", Chr(99) ' ETX
    AddEntry 68, Chr(4), "d", "68", Chr(100) ' EOT
    AddEntry 69, Chr(5), "e", "69", Chr(101) ' ENQ
    AddEntry 70, Chr(6), "f", "70", Chr(102) ' ACK
    AddEntry 71, Chr(7), "g", "71", Chr(103) ' BEL
    AddEntry 72, Chr(8), "h", "72", Chr(104) ' BS
    AddEntry 73, Chr(9), "i", "73", Chr(105) ' HT
    AddEntry 74, Chr(10), "j", "74", Chr(106) ' LF
    AddEntry 75, Chr(11), "k", "75", Chr(107) ' VT
    AddEntry 76, Chr(12), "l", "76", Chr(108) ' FF
    AddEntry 77, Chr(13), "m", "77", Chr(109) ' CR
    AddEntry 78, Chr(14), "n", "78", Chr(110) ' SO
    AddEntry 79, Chr(15), "o", "79", Chr(111) ' SI
    AddEntry 80, Chr(16), "p", "80", Chr(112) ' DLE
    AddEntry 81, Chr(17), "q", "81", Chr(113) ' DC1
    AddEntry 82, Chr(18), "r", "82", Chr(114) ' DC2
    AddEntry 83, Chr(19), "s", "83", Chr(115) ' DC3
    AddEntry 84, Chr(20), "t", "84", Chr(116) ' DC4
    AddEntry 85, Chr(21), "u", "85", Chr(117) ' NAK
    AddEntry 86, Chr(22), "v", "86", Chr(118) ' SYN
    AddEntry 87, Chr(23), "w", "87", Chr(119) ' ETB
    AddEntry 88, Chr(24), "x", "88", Chr(120) ' CAN
    AddEntry 89, Chr(25), "y", "89", Chr(121) ' EM
    AddEntry 90, Chr(26), "z", "90", Chr(122) ' SUB
    AddEntry 91, Chr(27), "{", "91", Chr(123) ' ESC
    AddEntry 92, Chr(28), "|", "92", Chr(124) ' FS
    AddEntry 93, Chr(29), "}", "93", Chr(125) ' GS
    AddEntry 94, Chr(30), "~", "94", Chr(126) ' RS
    AddEntry 95, Chr(31), Chr(127), "95", Chr(200) ' US, DEL
    AddEntry 96, "FNC 3", "FNC 3", "96", Chr(201)
    AddEntry 97, "FNC 2", "FNC 2", "97", Chr(202)
    AddEntry 98, "SHIFT", "SHIFT", "98", Chr(203)
    AddEntry 99, "CODE C", "CODE C", "99", Chr(204)
    AddEntry 100, "CODE B", "FNC 4", "CODE B", Chr(205)
    AddEntry 101, "FNC 4", "CODE A", "CODE A", Chr(206)
    AddEntry 102, "FNC 1", "FNC 1", "FNC 1", Chr(207)
    AddEntry 103, "Start A", "Start A", "Start A", Chr(208)
    AddEntry 104, "Start B", "Start B", "Start B", Chr(209)
    AddEntry 105, "Start C", "Start C", "Start C", Chr(210)
    AddEntry 106, "Stop", "Stop", "Stop", Chr(211)
End Sub

Private Sub AddEntry(ByVal Index As Integer, ASet As String, BSet As String, CSet As String, BarSpacePattern As String)
    With CodeArr(Index)
        .ASet = ASet
        .BSet = BSet
        .CSet = CSet
        .BarSpacePattern = Replace(BarSpacePattern, " ", "")
    End With
End Sub

Public Function Code128_Str(ByVal Str As String)
    Code128_Str = Replace(BuildStr(Str), " ", "")
End Function

Private Function BuildStr(ByVal Str As String) As String
    Dim SCode As eCode128Type, PrevSCode As eCode128Type
    Dim CurrChar As String, ArrIndex As Integer, CharIndex As Long
    Dim CheckDigit As Integer, CCodeIndex As Integer, TotalSum As Long

    SCode = eCode128_CodeSetB
    If Str Like "##*" Then SCode = eCode128_CodeSetC

    TotalSum = 0
    CharIndex = 1

    Select Case SCode
    Case eCode128_CodeSetA
        TotalSum = TotalSum + (103 * CharIndex)
        BuildStr = Trim(BuildStr) & Chr(208)
    Case eCode128_CodeSetB
        TotalSum = TotalSum + (104 * CharIndex)
        BuildStr = Trim(BuildStr) & Chr(209)
    Case eCode128_CodeSetC
        TotalSum = TotalSum + (105 * CharIndex)
        BuildStr = Trim(BuildStr) & Chr(210)
    End Select

    PrevSCode = SCode

    Do Until Len(Str) = 0
        If Str Like "####*" Then SCode = eCode128_CodeSetC

        If SCode = eCode128_CodeSetC And Mid(Str, 1, 2) Like "##" Then
            CurrChar = Mid(Str, 1, 2)
        Else
            CurrChar = Mid(Str, 1, 1)
        End If

        ArrIndex = GetCharIndex(CurrChar, SCode, True)

        If ArrIndex <> -1 Then
            If CodeArr(ArrIndex).BSet = CurrChar And ((SCode = eCode128_CodeSetC And CodeArr(ArrIndex).CSet <> CurrChar) Or (SCode = eCode128_CodeSetA And CodeArr(ArrIndex).ASet <> CurrChar)) Then
                SCode = eCode128_CodeSetB
            ElseIf CodeArr(ArrIndex).ASet = CurrChar And CodeArr(ArrIndex).BSet <> CurrChar Then
                SCode = eCode128_CodeSetA
            ElseIf CodeArr(ArrIndex).CSet = CurrChar Then
                SCode = eCode128_CodeSetC
            End If

            If PrevSCode <> SCode Then
                Select Case SCode
                Case eCode128_CodeSetA
                    CCodeIndex = GetCharIndex("CODE A", PrevSCode, False)
                Case eCode128_CodeSetB
                    CCodeIndex = GetCharIndex("CODE B", PrevSCode, False)
                Case eCode128_CodeSetC
                    CCodeIndex = GetCharIndex("CODE C", PrevSCode, False)
                End Select

                TotalSum = TotalSum + (CCodeIndex * CharIndex)
                BuildStr = Trim(BuildStr) & CodeArr(CCodeIndex).BarSpacePattern

                CharIndex = CharIndex + 1
                PrevSCode = SCode
            End If

            BuildStr = Trim(BuildStr) & CodeArr(ArrIndex).BarSpacePattern

            TotalSum = TotalSum + (ArrIndex * CharIndex)
            CharIndex = CharIndex + 1
        End If

        If SCode = eCode128_CodeSetC Then
            Str = Mid(Str, 3)
        Else
            Str = Mid(Str, 2)
        End If
    Loop

    CheckDigit = TotalSum Mod 103

    BuildStr = Trim(BuildStr) & CodeArr(CheckDigit).BarSpacePattern
    BuildStr = Trim(BuildStr) & Chr(211)
End Function

Private Function GetCharIndex(ByVal Char As String, ByVal CodeType As eCode128Type, ByVal Recurse As Boolean) As Integer
    Dim K As Long

    Select Case CodeType
    Case eCode128_CodeSetA
        For K = 0 To UBound(CodeArr)
            If Char = CodeArr(K).ASet Then Exit For
        Next K
    Case eCode128_CodeSetB
        For K = 0 To UBound(CodeArr)
            If Char = CodeArr(K).BSet Then Exit For
        Next K
    Case eCode128_CodeSetC
        For K = 0 To UBound(CodeArr)
            If Char = CodeArr(K).CSet Then Exit For
        Next K
    End Select

    If K = UBound(CodeArr) + 1 Then
        If Not Recurse Then
            GetCharIndex = -1
        Else
            Select Case CodeType
            Case eCode128_CodeSetA
                GetCharIndex = GetCharIndex(Char, eCode128_CodeSetC, False)
            Case eCode128_CodeSetB
                GetCharIndex = GetCharIndex(Char, eCode128_CodeSetA, False)
            Case eCode128_CodeSetC
                GetCharIndex = GetCharIndex(Char, eCode128_CodeSetB, False)
            End Select

            If GetCharIndex = -1 Then
                Select Case CodeType
                Case eCode128_CodeSetA
                    GetCharIndex = GetCharIndex(Char, eCode128_CodeSetB, False)
                Case eCode128_CodeSetB
                    GetCharIndex = GetCharIndex(Char, eCode128_CodeSetC, False)
                Case eCode128_CodeSetC
                    GetCharIndex = GetCharIndex(Char, eCode128_CodeSetA, False)
                End Select
            End If
        End If
    Else
        GetCharIndex = K
    End If
End Function

Public Function Code128_GetWidth(ByVal Str As String, Optional ByVal BarWidth As Integer = 1) As Long
    Dim K As Long, Width As Long

    Str = Replace(Code128_Str(Str), " ", "")
    Debug.Print Str
    For K = 1 To Len(Str)
        Width = Width + Val(Mid(Str, K, 1))
    Next K

    Code128_GetWidth = Width * BarWidth + (28 * BarWidth)
End Function



Private Sub Class_Terminate()

End Sub

Then in SpreadSheet, in any cell , you can call like =Code128_Str("TESTING") or =Code128_Str(A1)

这篇关于使用Excel VBA生成代码128条形码的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！

查看全文

使用Excel VBA生成代码128条形码 [英] Generating Code 128 Barcodes using Excel VBA

问题描述

相关文章

Office最新文章

热门教程

热门工具

登录关闭

使用Excel VBA生成代码128条形码 [英] Generating Code 128 Barcodes using Excel VBA

问题描述

相关文章

Office最新文章

热门教程

热门工具

登录 关闭

登录关闭