home *** CD-ROM | disk | FTP | other *** search
/ CD Shareware Magazine 1999 April / CD_Shareware_Magazine_31.iso / Free / Prg / BarCode.exe / ModuleBarcode.bas < prev    next >
Encoding:
BASIC Source File  |  1998-03-18  |  4.2 KB  |  132 lines
  1. Attribute VB_Name = "ModuleBarcode"
  2. Sub DrawBarcode(ByVal bc_string As String, obj As Control)
  3.     
  4.     Dim xpos!, y1!, y2!, dw%, th!, tw, new_string$
  5.     
  6.     'define barcode patterns
  7.     Dim bc(90) As String
  8.     bc(1) = "1 1221"            'pre-amble
  9.     bc(2) = "1 1221"            'post-amble
  10.     bc(48) = "11 221"           'digits
  11.     bc(49) = "21 112"
  12.     bc(50) = "12 112"
  13.     bc(51) = "22 111"
  14.     bc(52) = "11 212"
  15.     bc(53) = "21 211"
  16.     bc(54) = "12 211"
  17.     bc(55) = "11 122"
  18.     bc(56) = "21 121"
  19.     bc(57) = "12 121"
  20.                                 'capital letters
  21.     bc(65) = "211 12"           'A
  22.     bc(66) = "121 12"           'B
  23.     bc(67) = "221 11"           'C
  24.     bc(68) = "112 12"           'D
  25.     bc(69) = "212 11"           'E
  26.     bc(70) = "122 11"           'F
  27.     bc(71) = "111 22"           'G
  28.     bc(72) = "211 21"           'H
  29.     bc(73) = "121 21"           'I
  30.     bc(74) = "112 21"           'J
  31.     bc(75) = "2111 2"           'K
  32.     bc(76) = "1211 2"           'L
  33.     bc(77) = "2211 1"           'M
  34.     bc(78) = "1121 2"           'N
  35.     bc(79) = "2121 1"           'O
  36.     bc(80) = "1221 1"           'P
  37.     bc(81) = "1112 2"           'Q
  38.     bc(82) = "2112 1"           'R
  39.     bc(83) = "1212 1"           'S
  40.     bc(84) = "1122 1"           'T
  41.     bc(85) = "2 1112"           'U
  42.     bc(86) = "1 2112"           'V
  43.     bc(87) = "2 2111"           'W
  44.     bc(88) = "1 1212"           'X
  45.     bc(89) = "2 1211"           'Y
  46.     bc(90) = "1 2211"           'Z
  47.                                 'Misc
  48.     bc(32) = "1 2121"           'space
  49.     bc(35) = ""                 '# cannot do!
  50.     bc(36) = "1 1 1 11"         '$
  51.     bc(37) = "11 1 1 1"         '%
  52.     bc(43) = "1 11 1 1"         '+
  53.     bc(45) = "1 1122"           '-
  54.     bc(47) = "1 1 11 1"         '/
  55.     bc(46) = "2 1121"           '.
  56.     bc(64) = ""                 '@ cannot do!
  57.     bc(65) = "1 1221"           '*
  58.     
  59.     
  60.     
  61.     bc_string = UCase(bc_string)
  62.     
  63.     
  64.     'dimensions
  65.     obj.ScaleMode = 3                               'pixels
  66.     obj.Cls
  67.     obj.Picture = Nothing
  68.     dw = CInt(obj.ScaleHeight / 40)                 'space between bars
  69.     If dw < 1 Then dw = 1
  70.     'Debug.Print dw
  71.     th = obj.TextHeight(bc_string)                  'text height
  72.     tw = obj.TextWidth(bc_string)                   'text width
  73.     new_string = Chr$(1) & bc_string & Chr$(2)      'add pre-amble, post-amble
  74.     
  75.     y1 = obj.ScaleTop
  76.     y2 = obj.ScaleTop + obj.ScaleHeight - 1.5 * th
  77.     obj.Width = 1.1 * Len(new_string) * (15 * dw) * obj.Width / obj.ScaleWidth
  78.     
  79.     
  80.     'draw each character in barcode string
  81.     xpos = obj.ScaleLeft
  82.     For n = 1 To Len(new_string)
  83.         c = Asc(Mid$(new_string, n, 1))
  84.         If c > 90 Then c = 0
  85.         bc_pattern$ = bc(c)
  86.         
  87.         'draw each bar
  88.         For i = 1 To Len(bc_pattern$)
  89.             Select Case Mid$(bc_pattern$, i, 1)
  90.                 Case " "
  91.                     'space
  92.                     obj.Line (xpos, y1)-(xpos + 1 * dw, y2), &HFFFFFF, BF
  93.                     xpos = xpos + dw
  94.                     
  95.                 Case "1"
  96.                     'space
  97.                     obj.Line (xpos, y1)-(xpos + 1 * dw, y2), &HFFFFFF, BF
  98.                     xpos = xpos + dw
  99.                     'line
  100.                     obj.Line (xpos, y1)-(xpos + 1 * dw, y2), &H0&, BF
  101.                     xpos = xpos + dw
  102.                 
  103.                 Case "2"
  104.                     'space
  105.                     obj.Line (xpos, y1)-(xpos + 1 * dw, y2), &HFFFFFF, BF
  106.                     xpos = xpos + dw
  107.                     'wide line
  108.                     obj.Line (xpos, y1)-(xpos + 2 * dw, y2), &H0&, BF
  109.                     xpos = xpos + 2 * dw
  110.             End Select
  111.         Next
  112.     Next
  113.     
  114.     '1 more space
  115.     obj.Line (xpos, y1)-(xpos + 1 * dw, y2), &HFFFFFF, BF
  116.     xpos = xpos + dw
  117.     
  118.     'final size and text
  119.     obj.Width = (xpos + dw) * obj.Width / obj.ScaleWidth
  120.     obj.CurrentX = (obj.ScaleWidth - tw) / 2
  121.     obj.CurrentY = y2 + 0.25 * th
  122.     obj.Print bc_string
  123.     
  124.     'copy to clipboard
  125.     obj.Picture = obj.Image
  126.     Clipboard.Clear
  127.     Clipboard.SetData obj.Image, 2
  128.  
  129.  
  130.  
  131. End Sub
  132.