H
Hans Mayr
Dear Terry Kreft,
I found a very interesting posting of yours on how to create a
Interleaved 2/5 barcode in Access which you wrote on 05/21/1999.
Unfortunately it uses the user defined type Stripe which was not
included. Can you help me? If you should even have code to produce Code
128 by now that would be most fantastic.
Thanks and best regards,
Hans
Here's the code from the old posting:
*****************************************
To use this
1) put a text box on a report
2) make it's controlsource the field you want to display as a barcode
3) In the Print event of the section containing the control call the
i2of5_draw procedure
So for example if the text box is called barcode and it appears in the
Detail section of the report you could call
Private Sub Detail_Print(Cancel As Integer, PrintCount As Integer)
Call i2of5_draw(Me!barcode, Me, True, False)
End Sub
'************* Code Start ****************
Private Const Stripe_Thin = 1
Private Stripe_Thick As Currency
Private NS As Stripe 'Narrow Stripe
Private WS As Stripe 'Wide Stripe
'The bearerbar appears above and below the control _
Its purpose is to reduce the possibility of a partial scan
Private BearerBar As Currency
Sub i2of5_draw(ctl As TextBox, rpt As Report, WithCheckDigit As
Boolean,
WithBearerBar As Boolean)
'*******************************************************
'Name: I2of5_Draw
'Date: 29 August 1998
'Author: Terry Kreft
'Purpose: This routine takes the value of a control in a report _
and draws an Interleaved 2 of 5 barcode on top of it
' The routine will set ctl.Visible = False
'Called By: OnPrint event of the section of the report(rpt) _
which holds the control(ctl)
'Inputs: rpt - the report to print to _
ctl - the textbox control to print over
'Output: None
'Calls: FillStripe
' DrawBarCode
'*******************************************************
Dim NumBar(0 To 9, 1 To 5) As Stripe 'Array to Hold Number Info
Dim strCodeOut() As Stripe 'Array to pass to DrawBarCode procedure
Dim strCodeIn As String 'String to hold control value
Dim strPair As String * 2
Dim intLen As Integer
Dim intCount As Integer
Dim intX As Integer
Dim intY As Integer
Dim intZ As Integer
Dim intUbound As Integer
Const CTL_SIZE_ERR = 65535 + vbObjectError
Const CTL_SIZE_Height = 65534 + vbObjectError
Const StartBit = 4
Const Endbit = 3
On Error GoTo I2of5_Draw_err
If ctl.Height / 1440 < 0.25 Then
Err.Raise CTL_SIZE_Height
End If
If ctl.Height / ctl.Width < 0.15 Then
Err.Raise CTL_SIZE_ERR
End If
ctl.Visible = False
strCodeIn = ctl.Value & ""
If Len(strCodeIn) > 0 Then
If WithCheckDigit <> False Then
If Len(strCodeIn) Mod 2 = 0 Then strCodeIn = "0" & strCodeIn
strCodeIn = AddCheckDigit(strCodeIn)
Else
If Len(strCodeIn) Mod 2 <> 0 Then strCodeIn = "0" & strCodeIn
End If
intLen = Len(strCodeIn)
Stripe_Thick = GetRelW_Width(ctl, intLen)
If Stripe_Thick > 0 Then
'Define Stripes
With NS
.relHeight = 100
.relTop = 0
.Width = Stripe_Thin
End With
With WS
.relHeight = 100
.relTop = 0
.Width = Stripe_Thick
End With
'Fill the Numbar array with Stripe Info
Call FillStripe(NumBar())
'Define size of Output array
intUbound = StartBit + (intLen * 5) + Endbit
ReDim strCodeOut(1 To intUbound)
'Fill the Start Bit
For intX = 1 To 4
strCodeOut(intX) = NS
Next
'Fill the End Bit
strCodeOut(intUbound) = NS
strCodeOut(intUbound - 1) = NS
strCodeOut(intUbound - 2) = WS
intCount = StartBit
'Fill In Code
For intX = 1 To intLen Step 2
strPair = Mid(strCodeIn, intX, 2)
For intZ = 1 To 5
For intY = 1 To 2
intCount = intCount + 1
strCodeOut(intCount) = NumBar(Mid(strPair, intY, 1), intZ)
Next
Next
Next
End If
End If
'Now call actual print routine
If WithBearerBar <> False Then Call DrawBearerBar(ctl, rpt)
Call drawbarcode(rpt, ctl, strCodeOut())
I2of5_Draw_end:
Erase strCodeOut
Exit Sub
I2of5_Draw_err:
Dim strErr As String
Dim strWidth As String
Dim strHeight As String
strWidth = Format((ctl.Height / 0.15) / 567, "0.000")
strHeight = Format((ctl.Width * 0.15) / 567, "0.000")
Select Case Err
Case CTL_SIZE_ERR
strErr = Err & ": " & "The control dimensions are incorrect:" _
& vbCrLf _
& "either change the height to " _
& strHeight & "cm or " _
& "change the width to " _
& strWidth & "cm minimum"
Case CTL_SIZE_Height
strErr = Err & ": " & "The control dimensions are incorrect:" _
& vbCrLf _
& "the height of the control must be at " _
& "least 0.25in (0.635cm)"
Case Else
strErr = Err & ": " & Err.Description
End Select
MsgBox strErr
Resume I2of5_Draw_end
End Sub
Private Sub FillStripe(ArrIn() As Stripe)
'*******************************************************
'Name: FillStripe
'Date: 29 August 1998
'Author: Terry Kreft
'Purpose: This routine fills the array passed to it _
with the individual bar information for the _
I2of5_Draw procedure
'Input: ArrIn - an array to fill with the bar info
'Output: ArrIn
'Called By: I2of5_Draw
'Calls: None
'*******************************************************
Dim blnArr(0 To 9) As String
Dim intX As Integer
Dim intY As Integer
blnArr(0) = "nnWWn"
blnArr(1) = "WnnnW"
blnArr(2) = "nWnnW"
blnArr(3) = "WWnnn"
blnArr(4) = "nnWnW"
blnArr(5) = "WnWnn"
blnArr(6) = "nWWnn"
blnArr(7) = "nnnWW"
blnArr(8) = "WnnWn"
blnArr(9) = "nWnWn"
For intX = 0 To 9
For intY = 1 To 5
If Choose(intY, Mid(blnArr(intX), 1, 1), _
Mid(blnArr(intX), 2, 1), _
Mid(blnArr(intX), 3, 1), _
Mid(blnArr(intX), 4, 1), _
Mid(blnArr(intX), 5, 1)) = "n" Then
ArrIn(intX, intY) = NS
Else
ArrIn(intX, intY) = WS
End If
Next
Next
End Sub
Private Function GetRelW_Width(ctl As TextBox, C As Integer) As
Currency
'*******************************************************
'Name: GetRelW_Width
'Date: 29 August 1998
'Author: Terry Kreft
'Purpose: Calculates relative width of the wide bar _
for the I2of5_Draw routine
'Input: ctl - the textbox to draw over _
C - The number of characters in the barcode _
to be printed
'Output: Lowest acceptable Wide to Narrow ratio of bars _
or 0 if no acceptable value found _
Also sets value of module level BearerBar variable
'Called By: I2of5_Draw
'Calls: None
'*******************************************************
Dim L As Currency 'Length of symbol
Dim N As Currency 'Wide to Narrow ratio (what I want to return)
Dim x As Currency 'X - dimension (narrow bar width)
Dim blnOK As Boolean
Const minX_AS_Twips = 10.8
Const minN_Ratio As Integer = 2
Const maxN_Ratio As Integer = 3
L = ctl.Width
blnOK = False
For N = minN_Ratio To maxN_Ratio Step 0.1
x = L / ((C * ((2 * N) + 3)) + 6 + N)
If x > 20 Then
If N >= 2 And N <= 3 Then
blnOK = True
Exit For
End If
ElseIf x >= 7.5 Then
If N > 2.2 And N <= 3 Then
blnOK = True
Exit For
Else
blnOK = False
End If
Else
blnOK = False
End If
Next
'This sets the size of the module level BearerBar variable
BearerBar = (N + 1) * x
If blnOK = True Then GetRelW_Width = N
End Function
Private Function AddCheckDigit(strCodeIn As String) As String
'*******************************************************
'Name: AddCheckDigit
'Date: 29 August 1998
'Author: Terry Kreft
'Purpose: Calculates Modulo 10 check digit _
for the I2of5_Draw routine
'Input: strCodeIn - numeric string to add check digit to
'Output: strcodein & checkdigit
'Called By: I2of5_Draw
'Calls: None
'*******************************************************
Dim intTemp As Integer
Dim intLen As Integer
Dim intX As Integer
intLen = Len(strCodeIn)
For intX = 1 To intLen Step 2
intTemp = intTemp + (CInt(Mid(strCodeIn, intX, 1)) * 3)
Next
For intX = 2 To intLen Step 2
intTemp = intTemp + (CInt(Mid(strCodeIn, intX, 1)))
Next
intTemp = intTemp Mod 10
If intTemp > 0 Then intTemp = 10 - intTemp
AddCheckDigit = strCodeIn & CStr(intTemp)
End Function
Private Sub DrawBearerBar(ctl As Control, rpt As Report)
'*******************************************************
'Name: DrawBearerBar
'Date: 29 August 1998
'Author: Terry Kreft
'Purpose: Draws the optional Bearer bars over and under _
the control (ctl) on the report (rpt)
'Input: ctl - the control to draw the bearer bars on _
rpt - the report containing the control
'Output: None
'Called By: I2of5_Draw
'Calls: None
'*******************************************************
Dim lngLineColour As Long
Dim curWidth As Currency
Dim curTop As Currency
Dim curX As Currency
lngLineColour = 0
'Draw top bearer bar
With ctl
curX = .Left
curWidth = .Width
curTop = .Top - BearerBar
End With
rpt.Line (curX, curTop)-(curX + curWidth, curTop + BearerBar),
lngLineColour, BF
'Draw bottom bearer bar
With ctl
curX = .Left
curWidth = .Width
curTop = .Top + .Height
End With
rpt.Line (curX, curTop)-(curX + curWidth, curTop + BearerBar),
lngLineColour, BF
End Sub
'************* Code End ****************
I found a very interesting posting of yours on how to create a
Interleaved 2/5 barcode in Access which you wrote on 05/21/1999.
Unfortunately it uses the user defined type Stripe which was not
included. Can you help me? If you should even have code to produce Code
128 by now that would be most fantastic.
Thanks and best regards,
Hans
Here's the code from the old posting:
*****************************************
To use this
1) put a text box on a report
2) make it's controlsource the field you want to display as a barcode
3) In the Print event of the section containing the control call the
i2of5_draw procedure
So for example if the text box is called barcode and it appears in the
Detail section of the report you could call
Private Sub Detail_Print(Cancel As Integer, PrintCount As Integer)
Call i2of5_draw(Me!barcode, Me, True, False)
End Sub
'************* Code Start ****************
Private Const Stripe_Thin = 1
Private Stripe_Thick As Currency
Private NS As Stripe 'Narrow Stripe
Private WS As Stripe 'Wide Stripe
'The bearerbar appears above and below the control _
Its purpose is to reduce the possibility of a partial scan
Private BearerBar As Currency
Sub i2of5_draw(ctl As TextBox, rpt As Report, WithCheckDigit As
Boolean,
WithBearerBar As Boolean)
'*******************************************************
'Name: I2of5_Draw
'Date: 29 August 1998
'Author: Terry Kreft
'Purpose: This routine takes the value of a control in a report _
and draws an Interleaved 2 of 5 barcode on top of it
' The routine will set ctl.Visible = False
'Called By: OnPrint event of the section of the report(rpt) _
which holds the control(ctl)
'Inputs: rpt - the report to print to _
ctl - the textbox control to print over
'Output: None
'Calls: FillStripe
' DrawBarCode
'*******************************************************
Dim NumBar(0 To 9, 1 To 5) As Stripe 'Array to Hold Number Info
Dim strCodeOut() As Stripe 'Array to pass to DrawBarCode procedure
Dim strCodeIn As String 'String to hold control value
Dim strPair As String * 2
Dim intLen As Integer
Dim intCount As Integer
Dim intX As Integer
Dim intY As Integer
Dim intZ As Integer
Dim intUbound As Integer
Const CTL_SIZE_ERR = 65535 + vbObjectError
Const CTL_SIZE_Height = 65534 + vbObjectError
Const StartBit = 4
Const Endbit = 3
On Error GoTo I2of5_Draw_err
If ctl.Height / 1440 < 0.25 Then
Err.Raise CTL_SIZE_Height
End If
If ctl.Height / ctl.Width < 0.15 Then
Err.Raise CTL_SIZE_ERR
End If
ctl.Visible = False
strCodeIn = ctl.Value & ""
If Len(strCodeIn) > 0 Then
If WithCheckDigit <> False Then
If Len(strCodeIn) Mod 2 = 0 Then strCodeIn = "0" & strCodeIn
strCodeIn = AddCheckDigit(strCodeIn)
Else
If Len(strCodeIn) Mod 2 <> 0 Then strCodeIn = "0" & strCodeIn
End If
intLen = Len(strCodeIn)
Stripe_Thick = GetRelW_Width(ctl, intLen)
If Stripe_Thick > 0 Then
'Define Stripes
With NS
.relHeight = 100
.relTop = 0
.Width = Stripe_Thin
End With
With WS
.relHeight = 100
.relTop = 0
.Width = Stripe_Thick
End With
'Fill the Numbar array with Stripe Info
Call FillStripe(NumBar())
'Define size of Output array
intUbound = StartBit + (intLen * 5) + Endbit
ReDim strCodeOut(1 To intUbound)
'Fill the Start Bit
For intX = 1 To 4
strCodeOut(intX) = NS
Next
'Fill the End Bit
strCodeOut(intUbound) = NS
strCodeOut(intUbound - 1) = NS
strCodeOut(intUbound - 2) = WS
intCount = StartBit
'Fill In Code
For intX = 1 To intLen Step 2
strPair = Mid(strCodeIn, intX, 2)
For intZ = 1 To 5
For intY = 1 To 2
intCount = intCount + 1
strCodeOut(intCount) = NumBar(Mid(strPair, intY, 1), intZ)
Next
Next
Next
End If
End If
'Now call actual print routine
If WithBearerBar <> False Then Call DrawBearerBar(ctl, rpt)
Call drawbarcode(rpt, ctl, strCodeOut())
I2of5_Draw_end:
Erase strCodeOut
Exit Sub
I2of5_Draw_err:
Dim strErr As String
Dim strWidth As String
Dim strHeight As String
strWidth = Format((ctl.Height / 0.15) / 567, "0.000")
strHeight = Format((ctl.Width * 0.15) / 567, "0.000")
Select Case Err
Case CTL_SIZE_ERR
strErr = Err & ": " & "The control dimensions are incorrect:" _
& vbCrLf _
& "either change the height to " _
& strHeight & "cm or " _
& "change the width to " _
& strWidth & "cm minimum"
Case CTL_SIZE_Height
strErr = Err & ": " & "The control dimensions are incorrect:" _
& vbCrLf _
& "the height of the control must be at " _
& "least 0.25in (0.635cm)"
Case Else
strErr = Err & ": " & Err.Description
End Select
MsgBox strErr
Resume I2of5_Draw_end
End Sub
Private Sub FillStripe(ArrIn() As Stripe)
'*******************************************************
'Name: FillStripe
'Date: 29 August 1998
'Author: Terry Kreft
'Purpose: This routine fills the array passed to it _
with the individual bar information for the _
I2of5_Draw procedure
'Input: ArrIn - an array to fill with the bar info
'Output: ArrIn
'Called By: I2of5_Draw
'Calls: None
'*******************************************************
Dim blnArr(0 To 9) As String
Dim intX As Integer
Dim intY As Integer
blnArr(0) = "nnWWn"
blnArr(1) = "WnnnW"
blnArr(2) = "nWnnW"
blnArr(3) = "WWnnn"
blnArr(4) = "nnWnW"
blnArr(5) = "WnWnn"
blnArr(6) = "nWWnn"
blnArr(7) = "nnnWW"
blnArr(8) = "WnnWn"
blnArr(9) = "nWnWn"
For intX = 0 To 9
For intY = 1 To 5
If Choose(intY, Mid(blnArr(intX), 1, 1), _
Mid(blnArr(intX), 2, 1), _
Mid(blnArr(intX), 3, 1), _
Mid(blnArr(intX), 4, 1), _
Mid(blnArr(intX), 5, 1)) = "n" Then
ArrIn(intX, intY) = NS
Else
ArrIn(intX, intY) = WS
End If
Next
Next
End Sub
Private Function GetRelW_Width(ctl As TextBox, C As Integer) As
Currency
'*******************************************************
'Name: GetRelW_Width
'Date: 29 August 1998
'Author: Terry Kreft
'Purpose: Calculates relative width of the wide bar _
for the I2of5_Draw routine
'Input: ctl - the textbox to draw over _
C - The number of characters in the barcode _
to be printed
'Output: Lowest acceptable Wide to Narrow ratio of bars _
or 0 if no acceptable value found _
Also sets value of module level BearerBar variable
'Called By: I2of5_Draw
'Calls: None
'*******************************************************
Dim L As Currency 'Length of symbol
Dim N As Currency 'Wide to Narrow ratio (what I want to return)
Dim x As Currency 'X - dimension (narrow bar width)
Dim blnOK As Boolean
Const minX_AS_Twips = 10.8
Const minN_Ratio As Integer = 2
Const maxN_Ratio As Integer = 3
L = ctl.Width
blnOK = False
For N = minN_Ratio To maxN_Ratio Step 0.1
x = L / ((C * ((2 * N) + 3)) + 6 + N)
If x > 20 Then
If N >= 2 And N <= 3 Then
blnOK = True
Exit For
End If
ElseIf x >= 7.5 Then
If N > 2.2 And N <= 3 Then
blnOK = True
Exit For
Else
blnOK = False
End If
Else
blnOK = False
End If
Next
'This sets the size of the module level BearerBar variable
BearerBar = (N + 1) * x
If blnOK = True Then GetRelW_Width = N
End Function
Private Function AddCheckDigit(strCodeIn As String) As String
'*******************************************************
'Name: AddCheckDigit
'Date: 29 August 1998
'Author: Terry Kreft
'Purpose: Calculates Modulo 10 check digit _
for the I2of5_Draw routine
'Input: strCodeIn - numeric string to add check digit to
'Output: strcodein & checkdigit
'Called By: I2of5_Draw
'Calls: None
'*******************************************************
Dim intTemp As Integer
Dim intLen As Integer
Dim intX As Integer
intLen = Len(strCodeIn)
For intX = 1 To intLen Step 2
intTemp = intTemp + (CInt(Mid(strCodeIn, intX, 1)) * 3)
Next
For intX = 2 To intLen Step 2
intTemp = intTemp + (CInt(Mid(strCodeIn, intX, 1)))
Next
intTemp = intTemp Mod 10
If intTemp > 0 Then intTemp = 10 - intTemp
AddCheckDigit = strCodeIn & CStr(intTemp)
End Function
Private Sub DrawBearerBar(ctl As Control, rpt As Report)
'*******************************************************
'Name: DrawBearerBar
'Date: 29 August 1998
'Author: Terry Kreft
'Purpose: Draws the optional Bearer bars over and under _
the control (ctl) on the report (rpt)
'Input: ctl - the control to draw the bearer bars on _
rpt - the report containing the control
'Output: None
'Called By: I2of5_Draw
'Calls: None
'*******************************************************
Dim lngLineColour As Long
Dim curWidth As Currency
Dim curTop As Currency
Dim curX As Currency
lngLineColour = 0
'Draw top bearer bar
With ctl
curX = .Left
curWidth = .Width
curTop = .Top - BearerBar
End With
rpt.Line (curX, curTop)-(curX + curWidth, curTop + BearerBar),
lngLineColour, BF
'Draw bottom bearer bar
With ctl
curX = .Left
curWidth = .Width
curTop = .Top + .Height
End With
rpt.Line (curX, curTop)-(curX + curWidth, curTop + BearerBar),
lngLineColour, BF
End Sub
'************* Code End ****************