'HAUPTPROGRAMM: Deklarationen

DECLARE FUNCTION code39$ (cKlartext$, lCheck%)
DECLARE FUNCTION barCode$ (nDrucker%, nSchmale%, nTeiler%, nRatio%)

COMMON Error.BarCode

'HAUPTPROGRAMM: DATA-Statements

data.code39:

DATA "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ-. *$/+%"
DATA 111221211,211211112,112211112,212211111,111221112,211221111,112221111
DATA 111211212,211211211,112211211,211112112,112112112,212112111,111122112
DATA 211122111,112122111,111112212,211112211,112112211,111122211,211111122
DATA 112111122,212111121,111121122,211121121,112121121,111111222,211111221
DATA 112111221,111121221,221111112,122111112,222111111,121121112,221121111
DATA 122121111,121111212,221111211,122111211,121121211,121212111,121211121
DATA 121112121,111212121


'----------------------------------------------------------------------
'Alles Folgende sind Demonstrationen der Anwendung (Druckausgabe Epson)
'----------------------------------------------------------------------

DEFINT A-Z

CLS

PRINT "Test Test Test Test Test Test Test Test Test Test Test Test Test Test Test Test"

INPUT "Pixelbreite eines schmalen Elementes"; PBSchmal
INPUT "Pixelbreite eines breiten Elementes"; PBBreit
PRINT
PRINT "Geben Sie nun das Breitenverh„ltnis an."
PRINT "Bsp.: 3 steht f�r 1:3"
INPUT "Breitenverh„ltnis"; BVH
PRINT
INPUT "Was soll gedruckt werden"; Druck$
PRINT
INPUT "Mit Checksummenbildung (-1) oder ohne (0)"; CHKSM

cRueckgabe$ = code39$(Druck$, CHKSM)           ' erfolgreicher Versuch
PRINT cRueckgabe$, Error.BarCode               ' ohne Checksummenbildung

IF Error.BarCode <> 0 THEN
   PRINT "Fehler aufgetreten. Druckstring enthielt die oben aufge-"
   PRINT "f�hrten ung�ltigen Zeichen."
   END
END IF

cPrint$ = barCode$(14, PBSchmal, PBBreit, BVH)          ' Breitenverhaeltnis 1:3
LPRINT CHR$(28) + "3" + CHR$(19)
LPRINT cPrint$
LPRINT cPrint$
LPRINT cPrint$
LPRINT cPrint$
LPRINT cPrint$
LPRINT cPrint$
LPRINT
LPRINT
LPRINT
LPRINT cRueckgabe$
LPRINT CHR$(27); "@";
LPRINT
LPRINT "Eingaben:", PBSchmal, PBBreit, BVH, CHKSM
LPRINT

'Syntax: barCode$ (<nDrucker>, <nSchmale>, <nTeiler>, <nRatio>) -> cRueckgabe
'
'nDrucker       Art des Druckers:
'               0       nur String aus CHR$(0) und CHR$(255)
'               1       Druckstring fuer Epson, einfache Dichte
'               2       Druckstring fuer Epson, doppelte Dichte
'               3       Druckstring fuer Epson, vierfache Dichte
'               etc.    - beliebig erweiterbar -
'
'nSchmale       Pixelbreite eines schmalen Elements
'
'nTeiler        Pixelbreite einer Teilungsluecke
'
'nRatio         Breitenverhaeltnis breites Element zu schmales Element
'
'cRueckgabe     ein String mit Drucksteuerzeichen und Grafikdaten
'-----------------------------------------------------------------------------
FUNCTION barCode$ (nDrucker, nSchmale, nTeiler, nRatio)

SHARED cBarCode$
STATIC nRatio()

REDIM nRatio(2)
nRatio(0) = nTeiler: nRatio(1) = nSchmale: nRatio(2) = nRatio * nRatio(1)

lBar = 0
FOR nIndex = 1 TO LEN(cBarCode$)
    lBar = -1 - lBar
    cPrint$ = cPrint$ + STRING$(nRatio(VAL(MID$(cBarCode$, nIndex, 1))), CHR$(lBar * -255))
NEXT nIndex

Temp$ = ""
FOR i = 1 TO LEN(cPrint$)
    Temp$ = Temp$ + STRING$(3, MID$(cPrint$, i, 1))
NEXT i
cPrint$ = Temp$: Temp$ = ""

Bytes = LEN(cPrint$) / 3
nLength.hi = INT(Bytes / 256)
nLength.lo = Bytes - (nLength.hi * 256)

SELECT CASE nDrucker
CASE 1  'Epson einfache Dichte
        cPrint$ = CHR$(27) + "K" + CHR$(nLength.lo) + CHR$(nLength.hi) + cPrint$
CASE 2  'Epson doppelte Dichte
        cPrint$ = CHR$(27) + "L" + CHR$(nLength.lo) + CHR$(nLength.hi) + cPrint$
CASE 3  'Epson vierfache Dichte
        'CHR$(27)+"Z"
        cPrint$ = CHR$(28) + "Z" + CHR$(nLength.lo) + CHR$(nLength.hi) + cPrint$
CASE 4
        cPrint$ = CHR$(27) + "*" + CHR$(0) + CHR$(nLength.lo) + CHR$(nLength.hi) + cPrint$
CASE 5
        cPrint$ = CHR$(27) + "*" + CHR$(1) + CHR$(nLength.lo) + CHR$(nLength.hi) + cPrint$
CASE 6
        cPrint$ = CHR$(27) + "*" + CHR$(2) + CHR$(nLength.lo) + CHR$(nLength.hi) + cPrint$
CASE 7
        cPrint$ = CHR$(27) + "*" + CHR$(3) + CHR$(nLength.lo) + CHR$(nLength.hi) + cPrint$
CASE 8
        cPrint$ = CHR$(27) + "*" + CHR$(4) + CHR$(nLength.lo) + CHR$(nLength.hi) + cPrint$
CASE 9
        cPrint$ = CHR$(27) + "*" + CHR$(6) + CHR$(nLength.lo) + CHR$(nLength.hi) + cPrint$
CASE 10
        cPrint$ = CHR$(27) + "*" + CHR$(32) + CHR$(nLength.lo) + CHR$(nLength.hi) + cPrint$
CASE 11
        cPrint$ = CHR$(27) + "*" + CHR$(33) + CHR$(nLength.lo) + CHR$(nLength.hi) + cPrint$
CASE 12
        cPrint$ = CHR$(27) + "*" + CHR$(38) + CHR$(nLength.lo) + CHR$(nLength.hi) + cPrint$
CASE 13
        cPrint$ = CHR$(27) + "*" + CHR$(39) + CHR$(nLength.lo) + CHR$(nLength.hi) + cPrint$
CASE 14
        cPrint$ = CHR$(27) + "*" + CHR$(40) + CHR$(nLength.lo) + CHR$(nLength.hi) + cPrint$
END SELECT

barCode$ = cPrint$

END FUNCTION

'-----------------------------------------------------------------------------
'Syntax: code39$(<cKlartext>, <lCheck>) -> <cRueckgabe>
'
'cKlartext      Zeichenkette mit Klartext
'
'lCheck         numerische Variable mit logischem Wert
'               TRUE    Pruefsummenzeichen anfuegen
'               FALSE   keine Pruefsumme bilden
'
'cRueckgabe     Wenn die globale Variable error.barCode einen Fehler anzeigt
'               (TRUE), dann finden sich hier die ungueltigen Zeichen, die
'               den Fehler hervorgerufen haben.
'               Liegt kein Fehler vor, so wird der Klartext, ggf. mit Pruef-
'               zeichen zurueckgegeben.
'-----------------------------------------------------------------------------
FUNCTION code39$ (cKlartext$, lCheck)

STATIC cCode39$, cCode39$()
SHARED cBarCode$

IF cCode39$ = "" THEN
        RESTORE data.code39: READ cCode39$
        DIM cCode39$(LEN(cCode39$))
        FOR nCount = 1 TO LEN(cCode39$): READ cCode39$(nCount): NEXT nCount
END IF

cBarCode$ = ""

FOR nCount = 1 TO LEN(cKlartext$)
        nChar = INSTR(cCode39$, MID$(cKlartext$, nCount, 1))
        IF nChar = 0 THEN
                cUngueltig$ = cUngueltig$ + MID$(cKlartext$, nCount, 1)
        ELSE
                nCheckCode = (nChar + (nChar > 40) - 1) * -(nChar <> 40)
                cBarCode$ = cBarCode$ + cCode39$(nChar)
                nCheckSum = nCheckSum + nCheckCode
                cBarCode$ = cBarCode$ + "0"
        END IF
NEXT nCount

IF cUngueltig$ <> "" THEN
        Error.BarCode = -1
        code39$ = cUngueltig$
        EXIT FUNCTION
END IF

IF lCheck THEN
        nCheckCode = nCheckSum MOD 43
        nChar = nCheckCode + 1 - (nCheckCode > 38)
        cKlartext$ = cKlartext$ + MID$(cCode39$, nChar, 1)
        cBarCode$ = cBarCode$ + cCode39$(nChar)
END IF

code39$ = cKlartext$
Error.BarCode = 0

END FUNCTION