Private Type POINTAPI
  x As Long
  y As Long
End Type

Private Const PS_SOLID = 0

Private Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINTAPI) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private CharArray(43) As String

'It is recommended that the relation between Height and NarrowBarWidth is 25:1
'NOTE: this function does not clear the space where it draws
Public Function evalbar(ByVal strBarCode As String, hdc As Long, Optional ByVal left As Long = 50, Optional ByVal top As Long = 50, Optional ByVal BarHeight As Long = 100, Optional ByVal NarrowBarWidth As Long = 4)
    
  Dim binarray As Integer     'retrievs the binary code for the current letter
  Dim loop1 As Integer, loop2 As Integer, loop3 As Integer
  Dim newstrBarCode As String 'hold the modified string
  
  Dim tempPT As POINTAPI
  Dim OldPen As Long, WhitePen As Long, BlackPen As Long
  
  'If array is not initialized yet, initialize it
  If CharArray(0) = "" Then
    Call InitializeArray
  End If
  
  WhitePen = CreatePen(PS_SOLID, 1, RGB(255, 255, 255))
  BlackPen = CreatePen(PS_SOLID, 1, RGB(0, 0, 0))
  
  newstrBarCode = "*" + StrConv(strBarCode, vbUpperCase) + "*"  'add start and stop char changes string to uppercase
  For loop1 = 1 To Len(newstrBarCode)  'loops through each char of the string
    binarray = evalchar(Mid(newstrBarCode, loop1, 1))
    For loop2 = 1 To Len(CharArray(binarray))   'loops through the binary array
      For loop3 = 1 To (CInt(Mid(CharArray(binarray), loop2, 1)) + 1) * NarrowBarWidth 'checks the width 0 for narrow and 1 for wide
        If loop2 Mod 2 Then  'odd char of the string are black, even are white
          Call SelectObject(hdc, BlackPen)
        Else
          Call SelectObject(hdc, WhitePen)
        End If
        Call MoveToEx(hdc, left, top, tempPT)
        Call LineTo(hdc, left, top + BarHeight)
        
        left = left + 1
      Next loop3
    Next loop2
    For loop2 = 1 To NarrowBarWidth 'adds a white space between char
      Call SelectObject(hdc, WhitePen)
      Call MoveToEx(hdc, left, top, tempPT)
      Call LineTo(hdc, left, top + BarHeight)
    
      left = left + 1
    Next loop2
  Next loop1
  
  'Leave everything the way it was
  Call SelectObject(hdc, OldPen)
  Call DeleteObject(WhitePen)
  Call DeleteObject(BlackPen)
  
End Function

Private Function evalchar(echar As String) As Integer
  Select Case echar
    Case "0": evalchar = 0
    Case "1": evalchar = 1
    Case "2": evalchar = 2
    Case "3": evalchar = 3
    Case "4": evalchar = 4
    Case "5": evalchar = 5
    Case "6": evalchar = 6
    Case "7": evalchar = 7
    Case "8": evalchar = 8
    Case "9": evalchar = 9
    Case "A": evalchar = 10
    Case "B": evalchar = 11
    Case "C": evalchar = 12
    Case "D": evalchar = 13
    Case "E": evalchar = 14
    Case "F": evalchar = 15
    Case "G": evalchar = 16
    Case "H": evalchar = 17
    Case "I": evalchar = 18
    Case "J": evalchar = 19
    Case "K": evalchar = 20
    Case "L": evalchar = 21
    Case "M": evalchar = 22
    Case "N": evalchar = 23
    Case "O": evalchar = 24
    Case "P": evalchar = 25
    Case "Q": evalchar = 26
    Case "R": evalchar = 27
    Case "S": evalchar = 28
    Case "T": evalchar = 29
    Case "U": evalchar = 30
    Case "V": evalchar = 31
    Case "W": evalchar = 32
    Case "X": evalchar = 33
    Case "Y": evalchar = 34
    Case "Z": evalchar = 35
    Case "-": evalchar = 36
    Case ".": evalchar = 37
    Case " ": evalchar = 38
    Case "$": evalchar = 39
    Case "/": evalchar = 40
    Case "+": evalchar = 41
    Case "%": evalchar = 42
    Case "*": evalchar = 43
  End Select
End Function

Private Sub InitializeArray()
  CharArray(0) = "000110100"
  CharArray(1) = "100100001"
  CharArray(2) = "001100001"
  CharArray(3) = "101100000"
  CharArray(4) = "000110001"
  CharArray(5) = "100110000"
  CharArray(6) = "001110000"
  CharArray(7) = "000100101"
  CharArray(8) = "100100100"
  CharArray(9) = "001100100"
  CharArray(10) = "100001001"
  CharArray(11) = "001001001"
  CharArray(12) = "101001000"
  CharArray(13) = "000011001"
  CharArray(14) = "100011000"
  CharArray(15) = "001011000"
  CharArray(16) = "000001101"
  CharArray(17) = "100001100"
  CharArray(18) = "001001100"
  CharArray(19) = "000011100"
  CharArray(20) = "100000011"
  CharArray(21) = "001000011"
  CharArray(22) = "101000010"
  CharArray(23) = "000010011"
  CharArray(24) = "100010010"
  CharArray(25) = "001010010"
  CharArray(26) = "000000111"
  CharArray(27) = "100000110"
  CharArray(28) = "001000110"
  CharArray(29) = "000010110"
  CharArray(30) = "110000001"
  CharArray(31) = "011000001"
  CharArray(32) = "111000000"
  CharArray(33) = "010010001"
  CharArray(34) = "110010000"
  CharArray(35) = "011010000"
  CharArray(36) = "010000101"
  CharArray(37) = "110000100"
  CharArray(38) = "011000100"
  CharArray(39) = "010101000"
  CharArray(40) = "010100010"
  CharArray(41) = "010001010"
  CharArray(42) = "000101010"
  CharArray(43) = "010010100"
End Sub