title image


Smiley Re: Formular mit Berichtsfeld
Hallo trekking,



es handelt sich hierbeim um einen Barcode,

der im Bericht erstellt wird ohne Barcode Schrift, mit folgender Funktion.



Oder kann man den Code so änderen das der Barcode auch im Formular angezeigt wird.

Aufruf im Bericht Beim Drucken: Call MD_Barcode39(Barcode, Me)

Hier der Code.

Danke für deine Hilfe.

Gruß Johannes



Function MD_Barcode39(Ctrl As Control, rpt As Report)



On Error GoTo ErrorTrap_BarCode39



Dim Nbar As Single, Wbar As Single, Qbar As Single, Nextbar As Single

Dim CountX As Single, CountY As Single, CountR As Single

Dim Parts As Single, Pix As Single, Color As Long, BarCodePlus As Variant

Dim Stripes As String, BarType As String, Barcode As String

Dim Mx As Single, my As Single, Sx As Single, Sy As Single

Const White = 16777215: Const Black = 0

Const Nratio = 20, Wratio = 55, Qratio = 35



'Get control size and location properties.

Sx = Ctrl.Left: Sy = Ctrl.TOP: Mx = Ctrl.Width: my = Ctrl.Height



'Set handle on control.

Barcode = Ctrl



'Calculate actual and relative pixels values.

Parts = (Len(Barcode) + 2) * ((6 * Nratio) + (3 * Wratio) + (1 * Qratio))

Pix = (Mx / Parts):

Nbar = (20 * Pix): Wbar = (55 * Pix): Qbar = (35 * Pix)



'Initialize bar index and color.

Nextbar = Sx

Color = White



'Pad each end of string with start/stop characters.

BarCodePlus = "*" & UCase(Barcode) & "*"



'Walk through each character of the barcode contents.

For CountX = 1 To Len(BarCodePlus)



'Get Barcode 1/0 string for indexed character.

Stripes = MD_BC39(Mid$(BarCodePlus, CountX, 1))

For CountY = 1 To 9



'For each 1/0, draw a wide/narrow bar.

BarType = Mid$(Stripes, CountY, 1)



'Toggle the color (black/white).

If Color = White Then Color = Black Else Color = White

Select Case BarType



Case "1"

'Draw a wide bar.

rpt.Line (Nextbar, Sy)-Step(Wbar, my), Color, BF

Nextbar = Nextbar + Wbar



Case "0"

'Draw a narrow bar.

rpt.Line (Nextbar, Sy)-Step(Nbar, my), Color, BF

Nextbar = Nextbar + Nbar



End Select

Next CountY



'Toggle the color (black/white).

If Color = White Then Color = Black Else Color = White



'Draw intermediate "quiet" bar.

rpt.Line (Nextbar, Sy)-Step(Qbar, my), Color, BF

Nextbar = Nextbar + Qbar



Next CountX



Exit_BarCode39:

Exit Function



ErrorTrap_BarCode39:

Resume Exit_BarCode39



End Function



Function MD_BC39(CharCode As String) As String



On Error GoTo ErrorTrap_BC39



ReDim BC39(90)



BC39(32) = "011000100" ' space

BC39(36) = "010101000" ' $

BC39(37) = "000101010" ' %

BC39(42) = "010010100" ' * Start/Stop

BC39(43) = "010001010" ' +

BC39(45) = "010000101" ' |

BC39(46) = "110000100" ' .

BC39(47) = "010100010" ' /

BC39(48) = "000110100" ' 0

BC39(49) = "100100001" ' 1

BC39(50) = "001100001" ' 2

BC39(51) = "101100000" ' 3

BC39(52) = "000110001" ' 4

BC39(53) = "100110000" ' 5

BC39(54) = "001110000" ' 6

BC39(55) = "000100101" ' 7

BC39(56) = "100100100" ' 8

BC39(57) = "001100100" ' 9

BC39(65) = "100001001" ' A

BC39(66) = "001001001" ' B

BC39(67) = "101001000" ' C

BC39(68) = "000011001" ' D

BC39(69) = "100011000" ' E

BC39(70) = "001011000" ' F

BC39(71) = "000001101" ' G

BC39(72) = "100001100" ' H

BC39(73) = "001001100" ' I

BC39(74) = "000011100" ' J

BC39(75) = "100000011" ' K

BC39(76) = "001000011" ' L

BC39(77) = "101000010" ' M

BC39(78) = "000010011" ' N

BC39(79) = "100010010" ' O

BC39(80) = "001010010" ' P

BC39(81) = "000000111" ' Q

BC39(82) = "100000110" ' R

BC39(83) = "001000110" ' S

BC39(84) = "000010110" ' T

BC39(85) = "110000001" ' U

BC39(86) = "011000001" ' V

BC39(87) = "111000000" ' W

BC39(88) = "010010001" ' X

BC39(89) = "110010000" ' Y

BC39(90) = "011010000" ' Z



MD_BC39 = BC39(Asc(CharCode))



Exit_BC39:

Exit Function



ErrorTrap_BC39:

MD_BC39 = ""

Resume Exit_BC39



End Function





geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: