'*****************************************************************

' Visual Basic & VBA Functions for IDAutomation Barcode Fonts 2009
' © Copyright, 2000-2009 IDAutomation.com, Inc. All rights reserved.
' Redistribution and use of this code in source and/or binary
' forms, with or without modification, are permitted provided
' that: (1) all copies of the source code retain the above
' unmodified copyright notice and this entire unmodified
' section of text, (2) You or Your organization owns a valid
' Developer License to this product from IDAutomation.com
' and, (3) when any portion of this code is bundled in any
' form with an application, a valid notice must be provided
' within the user documentation, start-up screen or in the
' help-about section of the application that specifies
' IDAutomation.com as the provider of the Software bundled
' with the application.
'*****************************************************************

Dim DataToPrint As String

Dim OnlyCorrectData As String
Dim PrintableString As String
Dim Encoding As String
Dim WeightedTotal As Long
Dim Factor As Integer
Dim CheckDigit As Integer
Dim CurrentEncoding As String
Dim CurrentChar As String
Dim CurrentCharNum As Integer
Dim EAN2AddOn As String
Dim EAN5AddOn As String
Dim EANAddOnToPrint As String
Dim StringLength As Integer

'END OF DECLARACTIONS

Public Function UPCa(DataToEncode As String) As String

DataToPrint = ""
OnlyCorrectData = ""
'Check to make sure data is numeric and remove dashes, etc.
StringLength = Len(DataToEncode)
For I = 1 To StringLength
'Add all numbers to OnlyCorrectData string
'2006.2 BDA modified the next 3 lines for compatibility with different office
versions
'If IsNumeric(Mid(DataToEncode, I, 1)) Then OnlyCorrectData = OnlyCorrectData
& Mid(DataToEncode, I, 1)
CurrentCharNum = AscW(Mid(DataToEncode, I, 1))
 If CurrentCharNum > 47 And CurrentCharNum < 58 Then OnlyCorrectData =
OnlyCorrectData & Mid(DataToEncode, I, 1)
Next I
'2006.2 BDA added the next line for general compatibility
StringLength = Len(OnlyCorrectData)
'Remove check digits if they added one
If StringLength < 11 Then OnlyCorrectData = "00000000000"
If StringLength = 15 Then OnlyCorrectData = "00000000000"
If StringLength > 18 Then OnlyCorrectData = "00000000000"
If StringLength = 12 Then OnlyCorrectData = Mid(OnlyCorrectData, 1, 11)
If StringLength = 14 Then OnlyCorrectData = Mid(OnlyCorrectData, 1, 11) &
Mid(OnlyCorrectData, 13, 2)
If StringLength = 17 Then OnlyCorrectData = Mid(OnlyCorrectData, 1, 11) &
Mid(OnlyCorrectData, 13, 5)
EAN2AddOn = ""
EAN5AddOn = ""
EANAddOnToPrint = ""
'2006.2 BDA added the next line for general compatibility
StringLength = Len(OnlyCorrectData)
If StringLength = 16 Then EAN5AddOn = Mid(OnlyCorrectData, 12, 5)
If StringLength = 13 Then EAN2AddOn = Mid(OnlyCorrectData, 12, 2)
'split 12 digit number from add-on

DataToEncode = Mid(OnlyCorrectData, 1, 11)

'<<<< Calculate Check Digit >>>>
Factor = 3
WeightedTotal = 0
For I = Len(DataToEncode) To 1 Step -1
'Get the value of each number starting at the end
CurrentCharNum = Mid(DataToEncode, I, 1)
'multiply by the weighting factor which is 3,1,3,1...
'and add the sum together
WeightedTotal = WeightedTotal + CurrentCharNum * Factor
'change factor for next calculation
Factor = 4 - Factor
Next I
'Find the CheckDigit by finding the number + WeightedTotal that = a multiple of 10
'Divide by 10, get the remainder and subtract from 10
I = (WeightedTotal Mod 10)
If I <> 0 Then
CheckDigit = (10 - I)
Else
CheckDigit = 0
End If
DataToEncode = DataToEncode & CheckDigit
'Now that have the total number including the check digit, determine character to print
 'for proper barcoding
StringLength = Len(DataToEncode)
For I = 1 To StringLength
'Get the ASCII value of each number
CurrentCharNum = AscW(Mid(DataToEncode, I, 1))
'Print different barcodes according to the location of the CurrentChar
Select Case I
Case 1
'For the first character, print the human readable character, the normal
'guard pattern, and then the barcode without the human readable character
'2006.2 BDA modified the next 2 lines for general compatibility
If (CurrentCharNum - 48) > 4 Then DataToPrint = ChrW(CurrentCharNum +
64) & "(" & ChrW(CurrentCharNum + 49)
If (CurrentCharNum - 48) < 5 Then DataToPrint = ChrW(CurrentCharNum +
37) & "(" & ChrW(CurrentCharNum + 49)
Case 2
DataToPrint = DataToPrint & ChrW(CurrentCharNum)
Case 3
DataToPrint = DataToPrint & ChrW(CurrentCharNum)
Case 4
DataToPrint = DataToPrint & ChrW(CurrentCharNum)
Case 5
DataToPrint = DataToPrint & ChrW(CurrentCharNum)
Case 6
'Print the center guard pattern after the 6th character
DataToPrint = DataToPrint & ChrW(CurrentCharNum) & "*"
Case 7
'Add 27 to the ASII value of characters 6-12 to print from character set C
'This is required when printing to the right of the center guard pattern
DataToPrint = DataToPrint & ChrW(CurrentCharNum + 27)
Case 8
DataToPrint = DataToPrint & ChrW(CurrentCharNum + 27)
Case 9
DataToPrint = DataToPrint & ChrW(CurrentCharNum + 27)
Case 10
DataToPrint = DataToPrint & ChrW(CurrentCharNum + 27)
Case 11
DataToPrint = DataToPrint & ChrW(CurrentCharNum + 27)
Case 12
'For the last character, print the barcode without the human readable character,
'the normal guard pattern, and then the human readable character.
'2006.2 BDA modified the next 2 lines for general compatibility
If (CurrentCharNum - 48) > 4 Then DataToPrint = DataToPrint &
ChrW(CurrentCharNum + 59) & "(" & ChrW(CurrentCharNum + 64)
If (CurrentCharNum - 48) < 5 Then DataToPrint = DataToPrint &
ChrW(CurrentCharNum + 59) & "(" & ChrW(CurrentCharNum + 37)
 End Select
Next I
'Process add-ons if they exist
If Len(EAN2AddOn) = 2 Then DataToPrint = DataToPrint &
ProcessEAN2AddOn(EAN2AddOn)
If Len(EAN5AddOn) = 5 Then DataToPrint = DataToPrint &
ProcessEAN5AddOn(EAN5AddOn)
'Return PrintableString
UPCa = DataToPrint
End Function

Public Function ProcessEAN5AddOn(EAN5AddOn As String) As String

If Len(EAN5AddOn) = 5 Then
EANAddOnToPrint = ""
'Get the check digit for the add on
Factor = 3
WeightedTotal = 0
For I = Len(EAN5AddOn) To 1 Step -1
'Get the value of each number starting at the end
CurrentCharNum = Mid(EAN5AddOn, I, 1)
'Multiply by the weighting factor which is 3,9,3,9.
'and add the sum together
If Factor = 3 Then WeightedTotal = WeightedTotal + CurrentCharNum * 3
If Factor = 1 Then WeightedTotal = WeightedTotal + CurrentCharNum * 9
'Change factor for next calculation
Factor = 4 - Factor
Next I
'Find the CheckDigit by extracting the right-most number from WeightedTotal
CheckDigit = Val(Right(WeightedTotal, 1))
'Encode the add-on CheckDigit into the number sets
'by using variable parity between character sets A and B
Select Case CheckDigit
Case 0
Encoding = "BBAAA"
Case 1
Encoding = "BABAA"
Case 2
Encoding = "BAABA"
Case 3
Encoding = "BAAAB"
Case 4
Encoding = "ABBAA"
Case 5
Encoding = "AABBA"
Case 6
Encoding = "AAABB"
 Case 7
Encoding = "ABABA"
Case 8
Encoding = "ABAAB"
Case 9
Encoding = "AABAB"
End Select
'Determine the characters to print for proper barcoding
For I = 1 To Len(EAN5AddOn)
'Get the value of each number encoded with variable parity
CurrentChar = Mid(EAN5AddOn, I, 1)
CurrentEncoding = Mid(Encoding, I, 1)
'Print different barcodes according to the location of the CurrentChar and
CurrentEncoding
Select Case CurrentEncoding
Case "A"
If CurrentChar = "0" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(34)
If CurrentChar = "1" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(35)
If CurrentChar = "2" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(36)
If CurrentChar = "3" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(37)
If CurrentChar = "4" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(38)
If CurrentChar = "5" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(44)
If CurrentChar = "6" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(46)
If CurrentChar = "7" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(47)
If CurrentChar = "8" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(58)
If CurrentChar = "9" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(59)
Case "B"
If CurrentChar = "0" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(122)
If CurrentChar = "1" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(61)
If CurrentChar = "2" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(63)
If CurrentChar = "3" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(64)
 If CurrentChar = "4" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(91)
If CurrentChar = "5" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(92)
If CurrentChar = "6" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(93)
If CurrentChar = "7" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(95)
If CurrentChar = "8" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(123)
If CurrentChar = "9" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(125)
End Select
'Add in the space & add-on guard pattern
Select Case I
Case 1
EANAddOnToPrint = ChrW(43) & EANAddOnToPrint & ChrW(33)
'Print add-on delineators between each add-on character
Case 2
EANAddOnToPrint = EANAddOnToPrint & ChrW(33)
Case 3
EANAddOnToPrint = EANAddOnToPrint & ChrW(33)
Case 4
EANAddOnToPrint = EANAddOnToPrint & ChrW(33)
Case 5
EANAddOnToPrint = EANAddOnToPrint
End Select
Next I
End If
ProcessEAN5AddOn = EANAddOnToPrint
End Function

Public Function ProcessEAN2AddOn(EAN2AddOn As String) As String

'Process the 2 digit add on
EANAddOnToPrint = ""
If Len(EAN2AddOn) = 2 Then
'Get encoding for add on
For I = 0 To 99 Step 4
If Val(EAN2AddOn) = I Then Encoding = "AA"
If Val(EAN2AddOn) = I + 1 Then Encoding = "AB"
If Val(EAN2AddOn) = I + 2 Then Encoding = "BA"
If Val(EAN2AddOn) = I + 3 Then Encoding = "BB"
Next I
For I = 1 To Len(EAN2AddOn)
'Get the value of each number
 'It is encoded with variable parity
CurrentChar = Mid(EAN2AddOn, I, 1)
CurrentEncoding = Mid(Encoding, I, 1)
'Print different barcodes according to the location of the CurrentChar and
CurrentEncoding
Select Case CurrentEncoding
Case "A"
If CurrentChar = "0" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(34)
If CurrentChar = "1" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(35)
If CurrentChar = "2" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(36)
If CurrentChar = "3" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(37)
If CurrentChar = "4" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(38)
If CurrentChar = "5" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(44)
If CurrentChar = "6" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(46)
If CurrentChar = "7" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(47)
If CurrentChar = "8" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(58)
If CurrentChar = "9" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(59)
Case "B"
If CurrentChar = "0" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(122)
If CurrentChar = "1" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(61)
If CurrentChar = "2" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(63)
If CurrentChar = "3" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(64)
If CurrentChar = "4" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(91)
If CurrentChar = "5" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(92)
If CurrentChar = "6" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(93)
If CurrentChar = "7" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(95)
If CurrentChar = "8" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(123)
 If CurrentChar = "9" Then EANAddOnToPrint = EANAddOnToPrint &
ChrW(125)
End Select
'Add in the space & add-on guard pattern
Select Case I
Case 1
EANAddOnToPrint = ChrW(43) & EANAddOnToPrint & ChrW(33)
'Print add-on delineators between each add-on character
Case 2
EANAddOnToPrint = EANAddOnToPrint
End Select
Next I
End If
ProcessEAN2AddOn = ProcessEAN2AddOn & EANAddOnToPrint
End Function

'*****************************************************************
' © Copyright, IDAutomation.com, Inc. All rights reserved.
' Redistribution and use of this code in source and/or binary
' forms, with or without modification, are permitted provided
' that: (1) all copies of the source code retain the above
' unmodified copyright notice and this entire unmodified
' section of text, (2) You or Your organization owns a valid
' Developer License to this product from IDAutomation.com
' and, (3) when any portion of this code is bundled in any
' form with an application, a valid notice must be provided
' within the user documentation, start-up screen or in the
' help-about section of the application that specifies
' IDAutomation.com as the provider of the Software bundled
' with the application.
'*****************************************************************