Zurück zur Homepage

Barcode

Das vorherige Beispiel hat gezeigt, dass es sogar mit VBA möglich ist, Bilder auszuwerten, welche Barcode enthalten. Zum Testen habe ich dabei immer wieder neue Bilder benötigt aber auf die Dauer war das Einscannen doch etwas mühsam. Mit Hilfe einer Webcam, welche ich über die Twain-Schnittstelle angesprochen hatte, klappte die ganze Sache dann schon etwas besser. Die Auflösung der Kamera war aber viel zu gering, um bei jeder Vorlage ein vernünftig auszuwertendes Bild geliefert zu bekommen. Außerdem sind Vorlagen, welche Code 39 enthalten, im normalen Haushalt spärlich zu finden. Deshalb habe ich nach Tools gesucht, mit denen ich selbst solche Bildchen erzeugen kann und die zudem noch kostenlos sind.

Wie ich festgestellt habe, gibt es zum Erzeugen von Barcode zwar einige freie Schriftarten, das Erzeugen der zugehörigen Prüfziffern bleibt aber nach wie vor Aufgabe des Benutzers. Auch ist das Exportieren als Bild beim Benutzen einer TT-Schriftart nur umständlich möglich. Programme, welche die Prüfziffern automatisch errechnen und Bilder erzeugen, sind meistens kostenpflichtig und die Schriftarten sind auch nicht defaultmäßig auf jedem System verfügbar. Also habe ich selbst eine kleine Klasse geschrieben, welche Barcodebilder vom Typ Code39 oder EAN13 erzeugt. Diese können als Bilddatei abgespeichert werden oder man kann diese auch einem Steuerelement als Hintergrund zuweisen.

Da das Erzeugen und Auswerten irgendwie zusammengehören, sind beide Beispiele in einer Excel Arbeitsmappe zusammengefasst. Beides, das Erzeugen und Decodieren ist aber recht aufwändig und erfordert eine umfangreiche Erklärung. Damit man den Überblick nicht verliert, wird das Auswerten in einem separaten Dokument beschrieben.

Auch bei diesem Beispiel gilt, dass man den Code frei benutzen kann. Eine Veröffentlichung des Codes oder Teilen davon, womöglich noch unter anderem Namen, sollte aber unterbleiben.

Excel-Dateien zum Download ca. 400 KB: Barcode.xlsm oder Barcode.xls

Das Tabellenblatt Barcode Erzeugen

CreateBarcode

Abbildung 1: Erzeugen von EAN13

CreateCode39

Abbildung 2: Erzeugen von Code39

Auf dem Tabellenblatt “Barcode Erzeugen“ befindet sich ganz oben ein Bildanzeige-Steuerelement. Darunter sind mehrere Schaltflächen angeordnet.

  1. Die breite Schaltfläche direkt unterhalb des Bildsteuerelementes befördert das Bild darin als Hintergrund auf das oberste Bildsteuerelement auf dem Tabellenblattes “Barcode auswerten“. Dort kann es beliebig gedreht und anschließend ausgewertet werden.
  2. Die zwei Schaltflächen darunter erzeugen ein Bild mit Barcode vom Typ EAN 13 und legen es einmal als Hintergrundbild des Bildsteuerelements ab, oder speichern es als Datei.
  3. Die zwei untersten Schaltflächen erzeugen ein Bild mit Barcode vom Typ Code 39 und legen es einmal als Hintergrundbild des Bildsteuerelements ab, oder speichern es als Datei.
  4. In Zelle B30 wird die 12-Stellige Ziffernfolge eingegeben, welche mit berechneter Prüfziffer als Barcode vom Typ EAN13 erzeugt werden soll.
  5. In Zelle B31 wird die Zeichenfolge eingegeben, welche mit einem optional zu berechnenden Prüfzeichen als Barcode vom Typ Code39 erzeugt werden soll. Das Kontrollkästchen rechts daneben legt fest, ob zusätzlich ein Prüfzeichen generiert wird.
  6. In Zelle B32 wird die Dicke eines schmalen Balkens in Pixeln eingegeben.
  7. Die Hintergrundfarbe in Zelle B33 wird als Hintergrundfarbe des erzeugten Bildes benutzt.
  8. Die Textformatierung der Zelle B34 wird als Format für die Zeichen und Ziffern unterhalb des erzeugten Barcodes benutzt.
  9. In Zelle B35 und B36 wird die Breite und Höhe der Ruhezone um den eigentlichen Barcode festgelegt. Die Angaben als Pixel gewertet.
  10. In Zelle B37 wird die Balkenhöhe des Barcodes in Pixel festgelegt.

Das Klassenmodul des Tabellenblatts Barcode erzeugen

Option Explicit

Private Sub cmdCreateCode39_Click()
   Dim objBarcode As New clsCreateBarcode
   Dim objDest    As IPictureDisp
   Dim strText    As String
   Dim lngWidth   As Long
   Dim lngHeight  As Long
   
   strText = Me.Range("B31")
   With objBarcode
      .Balkendicke = CLng(Me.Range("B32"))
      .Hintergrundfarbe = Me.Range("B33").Interior.Color
      .Schriftdicke = CLng(Me.Range("B34"))
      .Textfarbe = Me.Range("B34").Font.Color
      .Schriftart = Me.Range("B34").Font.Name
      .RuhezoneBreite = CLng(Me.Range("B35"))
      .RuhezoneHöhe = CLng(Me.Range("B36"))
      .Balkenbreite = CLng(Me.Range("B37"))
      Set objDest = .CreateCode39(strText, Me.Range("C31"))
      lngWidth = .GrößeX
      lngHeight = .GrößeY
   End With
   Me.OLEObjects("Image1").Object.Picture = objDest
   MsgBox "Bild in der Größe" & vbCrLf _
      & "x=" & lngWidth & "  y=" & lngHeight & vbCrLf _
      & "erzeugt"
End Sub

Private Sub cmdCode39Export_Click()
   Dim varSave    As Variant
   Dim objBarcode As New clsCreateBarcode
   Dim objDest    As IPictureDisp
   Dim strText    As String
   Dim lngWidth   As Long
   Dim lngHeight  As Long
   
   strText = Me.Range("B31")
   
   With objBarcode
      .Balkendicke = CLng(Me.Range("B32"))
      .Hintergrundfarbe = Me.Range("B33").Interior.Color
      .Schriftdicke = CLng(Me.Range("B34"))
      .Textfarbe = Me.Range("B34").Font.Color
      .Schriftart = Me.Range("B34").Font.Name
      .RuhezoneBreite = CLng(Me.Range("B35"))
      .RuhezoneHöhe = CLng(Me.Range("B36"))
      .Balkenbreite = CLng(Me.Range("B37"))
      Set objDest = .CreateCode39(strText, Me.Range("C31"))
      lngWidth = .GrößeX
      lngHeight = .GrößeY
   End With
   
   varSave = Application.GetSaveAsFilename( _
      FileFilter:="JPG Files (*.jpg), *.jpg")
   If varSave <> False Then
      If Dir(varSave) <> "" Then Kill varSave
      SavePicture objDest, varSave
   End If
   MsgBox "Bild in der Größe" & vbCrLf _
      & "x=" & lngWidth & "  y=" & lngHeight & vbCrLf _
      & "erzeugt"
End Sub

Private Sub cmdCreateEAN_Click()
   Dim objBarcode As New clsCreateBarcode
   Dim objDest    As IPictureDisp
   Dim strText    As String
   Dim lngWidth   As Long
   Dim lngHeight  As Long
   
   strText = Me.Range("B30")
   With objBarcode
      .Balkendicke = CLng(Me.Range("B32"))
      .Hintergrundfarbe = Me.Range("B33").Interior.Color
      .Schriftdicke = CLng(Me.Range("B34"))
      .Textfarbe = Me.Range("B34").Font.Color
      .Schriftart = Me.Range("B34").Font.Name
      .RuhezoneBreite = CLng(Me.Range("B35"))
      .RuhezoneHöhe = CLng(Me.Range("B36"))
      .Balkenbreite = CLng(Me.Range("B37"))
      Set objDest = .CreateEAN13(strText)
      lngWidth = .GrößeX
      lngHeight = .GrößeY
   End With
   Me.OLEObjects("Image1").Object.Picture = objDest
   MsgBox "Bild in der Größe" & vbCrLf _
      & "x=" & lngWidth & "  y=" & lngHeight & vbCrLf _
      & "erzeugt"
End Sub

Private Sub cmdEANExport_Click()
   Dim varSave    As Variant
   Dim objBarcode As New clsCreateBarcode
   Dim objDest    As IPictureDisp
   Dim strText    As String
   Dim lngWidth   As Long
   Dim lngHeight  As Long
   
   strText = Me.Range("B30")
   
   With objBarcode
      .Balkendicke = CLng(Me.Range("B32"))
      .Hintergrundfarbe = Me.Range("B33").Interior.Color
      .Schriftdicke = CLng(Me.Range("B34"))
      .Textfarbe = Me.Range("B34").Font.Color
      .Schriftart = Me.Range("B34").Font.Name
      .RuhezoneBreite = CLng(Me.Range("B35"))
      .RuhezoneHöhe = CLng(Me.Range("B36"))
      .Balkenbreite = CLng(Me.Range("B37"))
      Set objDest = .CreateEAN13(strText)
      lngWidth = .GrößeX
      lngHeight = .GrößeY
   End With
   
   varSave = Application.GetSaveAsFilename( _
      FileFilter:="JPG Files (*.jpg), *.jpg")
   If varSave <> False Then
      If Dir(varSave) <> "" Then Kill varSave
      SavePicture objDest, varSave
   End If
   MsgBox "Bild in der Größe" & vbCrLf _
      & "x=" & lngWidth & "  y=" & lngHeight & vbCrLf _
      & "erzeugt"
End Sub

Private Sub cmdMove_Click()
   Worksheets("Barcode Auswerten").OLEObjects("Image1").Object.Picture = _
      Me.OLEObjects("Image1").Object.Picture
End Sub

Die Klickereignisse der Schaltflächen cmdEANExport und cmdCode39Export

In diesen Ereignisprozeduren wird erst einmal eine Instanz der Klasse clsCreateBarcode angelegt. Verschiedene Einstellungen werden aus dem Tabellenblatt ausgelesen und an die Eigenschaftsprozeduren der Klasse übergeben. Die Methoden CreateEAN13 und CreateCode39 liefern dann ein Bild vom Typ IPictureDisp mit dem gewünschten Barcode. Mit dem GetSaveAsFilename-Dialog der Applikation wird anschließend ein Zielpfad erfragt. Unter diesem wird das Bild als .jpg-Datei gespeichert. Möglich sind theoretisch auch andere Bildformate, das gewählte ist aber recht platzsparend.

Die Klickereignisse der Schaltflächen cmdCreateEAN13 und cmdCreateCode39

In diesen Ereignisprozeduren wird erst einmal eine Instanz der Klasse clsCreateBarcode angelegt. Verschiedene Einstellungen werden aus dem Tabellenblatt ausgelesen und an die Eigenschaftsprozeduren der Klasse übergeben. Die Methoden CreateEAN13 und CreateCode39 liefern dann ein Bild vom Typ IPictureDisp mit dem gewünschten Barcode. Dieses wird dann dem Bildsteuerelement zugewiesen.

Das Klickereignis der Schaltfläche cmdMove

In diesem Klickereignis wird das Bild im Bildsteuerelement dem obersten Bildsteuerelement auf dem Tabellenblatt "Barcode Auswerten" zugewiesen.

Das Klassenmodul clsCreateBarcode

Option Explicit
Private Const LF_FACESIZE     As Long = 32
Private Const DT_C
ENTER       As Long = &H1
Private Const DT_BOTTOM       As Long = &H8
Private Const DT_LEFT         As Long = &H0
Private Const DT_RIGHT        As Long = &H2
Private Const DT_TOP          As Long = &H0
Private Const SM_CXSCREEN     As Long = 0
Private Const PS_SOLID        As Long = 0
Private Const GW_CHILD        As Long = 5&
Private Const FW_DONTCARE     As Long = 0 ' Standard
Private Const FW_THIN         As Long = 100  ' super dünn
Private Const FW_EXTRALIGHT   As Long = 200 ' extra dünn
Private Const FW_LIGHT        As Long = 300 ' dünn
Private Const FW_NORMAL       As Long = 400 ' normal
Private Const FW_MEDIUM       As Long = 500 ' mittel
Private Const FW_SEMIBOLD     As Long = 600 ' etwas dicker
Private Const FW_BOLD         As Long = 700 ' fett
Private Const FW_EXTRABOLD    As Long = 800 ' extra fett
Private Const FW_HEAVY        As Long = 900 ' super fett
Private Const TRANSPARENT     As Long = 1
Private Const vbPicTypeBitmap As Long = 1

Private Type LOGFONT
   lfHeight                As Long
   lfWidth                 As Long
   lfEscapement            As Long
   lfOrientation           As Long
   lfWeight                As Long
   lfItalic                As Byte
   lfUnderline             As Byte
   lfStrikeOut             As Byte
   lfCharSet               As Byte
   lfOutPrecision          As Byte
   lfClipPrecision         As Byte
   lfQuality               As Byte
   lfPitchAndFamily        As Byte
   lfFaceName(LF_FACESIZE) As Byte
End Type
Private Type RECT
   Left           As Long
   Top            As Long
   Right          As Long
   Bottom         As Long
End Type
Private Type GUID
   Data1          As Long
   Data2          As Integer
   Data3          As Integer
   Data4(7)       As Byte
End Type
Private Type BITMAP
   bmType         As Long
   bmWidth        As Long
   bmHeight       As Long
   bmWidthBytes   As Long
   bmPlanes       As Integer
   bmBitsPixel    As Integer
   bmBits         As Long
End Type
Private Type PICTDESC
   cbSize         As Long
   picType        As Long
   hImage         As Long
   Data1          As Long
   Data2          As Long
End Type
Private Declare Function OleCreatePictureIndirect _
   Lib "olepro32.dll" ( _
   pPictDesc As PICTDESC, _
   RefIID As GUID, _
   ByVal fPictureOwnsHandle As Long, _
   ppvObj As IPicture _
   ) As Long
Private Declare Function DeleteDC _
   Lib "gdi32" ( _
   ByVal hdc As Long _
   ) As Long
Private Declare Function CreateCompatibleDC _
   Lib "gdi32" ( _
   ByVal hdc As Long _
   ) As Long
Private Declare Function SelectObject _
   Lib "gdi32" ( _
   ByVal hdc As Long, _
   ByVal hObject As Long _
   ) As Long
Private Declare Function CreateCompatibleBitmap _
   Lib "gdi32" ( _
   ByVal hdc As Long, _
   ByVal nWidth As Long, _
   ByVal nHeight As Long _
   ) As Long
Private Declare Function SetBkMode _
   Lib "gdi32" ( _
   ByVal hdc As Long, _
   ByVal nBkMode As Long _
   ) As Long
Private Declare Function DrawText _
   Lib "user32" Alias "DrawTextA" ( _
   ByVal hdc As Long, _
   ByVal lpStr As String, _
   ByVal nCount As Long, _
   lpRect As RECT, _
   ByVal wFormat As Long _
   ) As Long
Private Declare Function SetTextColor _
   Lib "gdi32" ( _
   ByVal hdc As Long, _
   ByVal crColor As Long _
   ) As Long
Private Declare Function CreateFontIndirect _
   Lib "gdi32" Alias "CreateFontIndirectA" ( _
   lpLogFont As LOGFONT _
   ) As Long
Private Declare Function CreateSolidBrush _
   Lib "gdi32.dll" ( _
   ByVal crColor As Long _
   ) As Long
Private Declare Function DeleteObject _
   Lib "gdi32.dll" ( _
   ByVal hObject As Long _
   ) As Long
Private Declare Function Rectangle _
   Lib "gdi32" ( _
   ByVal hdc As Long, _
   ByVal x1 As Long, _
   ByVal y1 As Long, _
   ByVal x2 As Long, _
   ByVal y2 As Long _
   ) As Long
   
Private mastr39(43, 1 To 2)  As String
Private mastrEAN13(9, 3)         As String
Private mlngWhiteZoneWidth       As Long
Private mlngWhiteZoneHeight      As Long
Private mlngWidth                As Long
Private mobjPicture              As IPictureDisp
Private mlngTextThickness        As Long
Private mlngTextColor            As Long
Private mstrFont                 As String
Private mlngLength               As Long
Private mlngResX                 As Long
Private mlngResY                 As Long
Private mlngLineColor            As Long
Private mlngBackColor            As Long


Public Function CreateCode39(strCode39 As StringOptional blnCheckChar As BooleanAs Variant
   Dim objPic              As IPictureDisp
   Dim i                   As Long
   Dim k                   As Long
   Dim m                   As Long
   Dim x                   As Long
   Dim y                   As Long
   Dim x1                  As Long
   Dim y1                  As Long
   Dim lngBrush            As Long
   Dim lngDestDC           As Long
   Dim lngObjOldDest       As Long
   Dim lngObjOldBrush      As Long
   Dim lngDestBMP          As Long
   Dim udtPicdesc          As PICTDESC
   Dim IID_IDispatch       As GUID
   Dim lngRet              As Long
   Dim strCodeTable        As String
   Dim strCode             As String
   Dim strChar           As String
   Dim lngDummyDC          As Long
   
   If Len(strCode39) < 1 Then
      MsgBox "zu wenig Zeichen)"
      Exit Function
   End If
   
   If blnCheckChar Then
      strCode39 = strCode39 & Code39CheckChar(strCode39)
   End If
   
   strCode = "*" & strCode39 & "*"
   
   ' Gesamte Größe berechnen.
Pro Zeichen 3 * Breit + 6 * Schmal
   ' + 1 * schmale Lücke. Alle Zeichen + Start- und Endzeichen
   x = (Len(strCode)) * 13 * mlngWidth + 2 * mlngWhiteZoneWidth
   y = 2 * mlngWhiteZoneHeight + mlngLength
   
   mlngResX = x
   mlngResY = y
   
   ' Einen DC erzeugen, der kompatibel zum Bildschirm ist
   lngDestDC = CreateCompatibleDC(0&)
   
   ' Reale 1*1 Bitmap mit 24 Bit Farbtiefe ins ZielDC stellen
   ' und altes Objekt merken. Damit erhält man eine DC, die
   ' auch 24 Bit Farbtiefe unterstützt. Stellt man eine leere
   ' Bitmap hinein, erhält man sonst nur 1 Bit Farbtiefe, egal
   ' mit welcher Farbtiefe die Bitmap erzeugt wurde
   lngObjOldDest = SelectObject(lngDestDC, mobjPicture.handle)
   
   ' Eine kompatible Bitmap in der gewünschten Größe erzeugen
   lngDestBMP = CreateCompatibleBitmap(lngDestDC, x, y)

   ' Das alte Objekt zurück ins DC
   SelectObject lngDestDC, lngObjOldDest
   
   ' Neue Bitmap ins ZielDC stellen, altes Objekt merken
   lngObjOldDest = SelectObject(lngDestDC, lngDestBMP)
   
   ' Einen soliden Pinsel in der Hintergrundfarbe erzeugen
   lngBrush = CreateSolidBrush(mlngBackColor)
   
   ' Den Pinsel in den DC stellen
   lngObjOldBrush = SelectObject(lngDestDC, lngBrush)
   
   ' Alle Pixel des Zielbilds auf Hintergrundfarbe setzen
   Rectangle lngDestDC, -1, -1, x + 1, y + 1
   
   ' Alten Pinsel zurück ins DC, erzeugten Pinsel löschen
   SelectObject lngDestDC, lngObjOldBrush
   DeleteObject lngBrush
   
   ' Text eintragen
   If blnCheckChar Then
      DrawMyText Left(strCode39, Len(strCode39) - 1), lngDestDC, x, y
   Else
      DrawMyText strCode39, lngDestDC, x, y
   End If
   
   ' Einen soliden Pinsel in der Balkenfarbe erzeugen
   lngBrush = CreateSolidBrush(mlngLineColor)
   
   ' Den Pinsel in den DC stellen
   lngObjOldBrush = SelectObject(lngDestDC, lngBrush)
   
   x1 = mlngWhiteZoneWidth
   
   For i = 1 To Len(strCode)
   
      ' Zeichen extrahieren
      strChar = Mid(strCode, i, 1)
      
      strCodeTable = ""
      
      
' Code des Zeichens aus Codetabelle holen
      For m = 0 To 43
         If UCase(strChar) = mastr39(m, 1) Then
            strCodeTable = mastr39(m, 2)
            Exit For
         End If
      Next
      
      If strCodeTable = "" Then strCodeTable = mastr39(38, 2)
      
      For k = 1 To 9
         If Mid(strCodeTable, k, 1) = "0" Then
            If (k Mod 2) = 1 Then
               ' dünnen Balken zeichnen
               Rectangle lngDestDC, x1, mlngWhiteZoneHeight, _
                  x1 + 1 * mlngWidth, y - mlngWhiteZoneHeight - mlngLength / 4
            End If
            x1 = x1 + 1 * mlngWidth
         Else
            If (k Mod 2) = 1 Then
               ' dicken Balken zeichnen
               Rectangle lngDestDC, x1, mlngWhiteZoneHeight, _
                  x1 + 2 * mlngWidth, y - mlngWhiteZoneHeight - mlngLength / 4
            End If
            x1 = x1 + 2 * mlngWidth
         End If
      Next
      x1 = x1 + 1 * mlngWidth
   Next
   
  
   ' Schnittstellenkennung kPictureIID (GUID)
   With IID_IDispatch
      .Data1 = &H20400
      .Data4(0) = &HC0
      .Data4(7) = &H46
   End With
   
   With udtPicdesc
      ' Struktur Picdesc ausfüllen
      .cbSize = Len(udtPicdesc)
      .picType = vbPicTypeBitmap
      .hImage = lngDestBMP
    End With

   ' Picture-Objekt erzeugen
   lngRet = OleCreatePictureIndirect( _
      udtPicdesc, IID_IDispatch, 1&, objPic)
      
   ' Picture-Objekt zurückgeben
   If lngRet = 0 Then Set CreateCode39 = objPic
   
   ' Alten Pinsel zurück ins DC, neuen Pinsel zerstören
   SelectObject lngDestDC, lngObjOldBrush
   DeleteObject lngBrush
   
   ' Alte Bitmap zurück ins DC, DC zerstören
   SelectObject lngDestDC, lngObjOldDest
   DeleteDC lngDestDC
   
End Function

Public Function CreateEAN13(strEAN As StringAs Variant
   Dim objPic              As IPictureDisp
   Dim i                   As Long
   Dim k                   As Long
   Dim x                   As Long
   Dim y                   As Long
   Dim x1                  As Long
   Dim y1                  As Long
   Dim lngBrush            As Long
   Dim lngDestDC           As Long
   Dim lngObjOldDest       As Long
   Dim lngObjOldBrush      As Long
   Dim lngDestBMP          As Long
   Dim udtPicdesc          As PICTDESC
   Dim IID_IDispatch       As GUID
   Dim lngRet              As Long
   Dim strCodeTables       As String
   Dim strCode             As String
   Dim strNumber           As String
   Dim lngDummyDC          As Long
   
   strEAN = Left(strEAN, 12)
   
   If Len(strEAN) < 12 Then
      MsgBox "zu wenig Ziffern)"
      Exit Function
   End If
   
   For i = 1 To 12
      If InStr(1, "0123456789", Mid(strEAN, i, 1)) = 0 Then
         MsgBox "'" & Mid(strEAN, i, 1) & "' ist keine Ziffer)"
         Exit Function
      End If
   Next
   
   ' Checksumme hinzu
   strEAN = strEAN & EANCheckNumber(strEAN)
   
   ' Gesamte Größe berechnen
   x = 95 * mlngWidth + 2 * mlngWhiteZoneWidth
   y = 2 * mlngWhiteZoneHeight + mlngLength
   
   mlngResX = x
   mlngResY = y
   
   ' Einen DC erzeugen, der kompatibel zum Bildschirm ist
   lngDestDC = CreateCompatibleDC(0&)
   
   ' Reale 1*1 Bitmap mit 24 Bit Farbtiefe ins ZielDC stellen
   ' und altes Objekt merken.
Damit erhält man eine DC, die
   ' auch 24 Bit Farbtiefe unterstützt. Stellt man eine leere
   ' Bitmap hinein, erhält man sonst nur 1 Bit Farbtiefe, egal
   ' mit welcher Farbtiefe die Bitmap erzeugt wurde
   lngObjOldDest = SelectObject(lngDestDC, mobjPicture.handle)
   
   ' Eine kompatible Bitmap in der gewünschten Größe erzeugen
   lngDestBMP = CreateCompatibleBitmap(lngDestDC, x, y)

   ' Das alte Objekt zurück ins DC
   SelectObject lngDestDC, lngObjOldDest
   
   ' Neue Bitmap ins ZielDC stellen, altes Objekt merken
   lngObjOldDest = SelectObject(lngDestDC, lngDestBMP)
   
   ' Einen soliden Pinsel in der Hintergrundfarbe erzeugen
   lngBrush = CreateSolidBrush(mlngBackColor)
   
   ' Den Pinsel in den DC stellen
   lngObjOldBrush = SelectObject(lngDestDC, lngBrush)
   
   ' Alle Pixel des Zielbilds auf Hintergrundfarbe setzen
   Rectangle lngDestDC, -1, -1, x + 1, y + 1
   
   ' Alten Pinsel zurück ins DC, erzeugten Pinsel löschen
   SelectObject lngDestDC, lngObjOldBrush
   DeleteObject lngBrush
   
   ' Text eintragen
   DrawNumbers strEAN, lngDestDC, x, y
   
   ' Einen soliden Pinsel in der Balkenfarbe erzeugen
   lngBrush = CreateSolidBrush(mlngLineColor)
   
   ' Den Pinsel in den DC stellen
   lngObjOldBrush = SelectObject(lngDestDC, lngBrush)
   
   ' Rand links erzeugen (2 Striche, eine Lücke) 3 Module
   x1 = mlngWhiteZoneWidth
   Rectangle lngDestDC, x1, mlngWhiteZoneHeight, x1 + mlngWidth, y - mlngWhiteZoneHeight
   x1 = mlngWhiteZoneWidth + 2 * mlngWidth
   Rectangle lngDestDC, x1, mlngWhiteZoneHeight, x1 + mlngWidth, y - mlngWhiteZoneHeight
   
   ' Mitte erzeugen (2 Striche, 3 Lücken) 5 Module
   x1 = mlngWhiteZoneWidth + 46 * mlngWidth
   Rectangle lngDestDC, x1, mlngWhiteZoneHeight, x1 + mlngWidth, y - mlngWhiteZoneHeight
   x1 = x1 + 2 * mlngWidth
   Rectangle lngDestDC, x1, mlngWhiteZoneHeight, x1 + mlngWidth, y - mlngWhiteZoneHeight
   
   ' Rand rechts erzeugen (2 Striche, eine Lücke) 3 Module
   x1 = mlngWhiteZoneWidth + 92 * mlngWidth
   Rectangle lngDestDC, x1, mlngWhiteZoneHeight, x1 + mlngWidth, y - mlngWhiteZoneHeight
   x1 = x1 + 2 * mlngWidth
   Rectangle lngDestDC, x1, mlngWhiteZoneHeight, x1 + mlngWidth, y - mlngWhiteZoneHeight
   
   ' Codetabellenfolge linke Hälfte für 1. Ziffer holen
   strCodeTables = mastrEAN13(CLng(Left(strEAN, 1)), 0)
   
   ' Zahlen 2-7 in linker Hälfte erzeugen
   For i = 2 To 7
   
      ' Codetabelle der aktuellen Ziffer ermitteln
      ' Der Metacode kodiert die erste Ziffer
      strNumber = Mid(strEAN, i, 1)
      
      If Mid(strCodeTables, i - 1, 1) = "A" Then
         ' Code der Ziffer aus Codetabelle A holen
         strCode = mastrEAN13(CLng(strNumber), 1)
      Else
         ' Code der Ziffer aus Codetabelle B holen
         strCode = mastrEAN13(CLng(strNumber), 2)
      End If
      For k = 1 To 7
         ' Alle 7 Module eines Zeichens durchlaufen
         If Mid(strCode, k, 1) = "B" Then
            ' Modul wird schwarz, X-Position berechnen
            x1 = (i - 2) * 7 * mlngWidth + _
               mlngWhiteZoneWidth + _
               3 * mlngWidth + _
               (k - 1) * mlngWidth
            ' schwarzen Balken zeichnen
            Rectangle lngDestDC, x1, mlngWhiteZoneHeight, _
               x1 + mlngWidth, y - mlngWhiteZoneHeight - mlngLength / 4
         End If
      Next
   Next
   
   ' Zahlen 8-13 in rechter Hälfte erzeugen
   For i = 8 To 13
      ' Ziffer extrahieren
      strNumber = Mid(strEAN, i, 1)
      ' Code der Ziffer aus Codetabelle C holen
      strCode = mastrEAN13(CLng(strNumber), 3)
      For k = 1 To 7
         If Mid(strCode, k, 1) = "B" Then
            ' Modul wird schwarz, X-Position berechnen
            x1 = mlngWhiteZoneWidth + _
               49 * mlngWidth + _
               (i - 8) * 7 * mlngWidth + _
               (k) * mlngWidth
            ' schwarzen Balken zeichnen
            Rectangle lngDestDC, x1, mlngWhiteZoneHeight, _
               x1 + mlngWidth, y - mlngWhiteZoneHeight - mlngLength / 4
         End If
      Next
   Next
   
  
   ' Schnittstellenkennung kPictureIID (GUID)
   With IID_IDispatch
      .Data1 = &H20400
      .Data4(0) = &HC0
      .Data4(7) = &H46
   End With
   
   With udtPicdesc
      ' Struktur Picdesc ausfüllen
      .cbSize = Len(udtPicdesc)
      .picType = vbPicTypeBitmap
      .hImage = lngDestBMP
    End With

   ' Picture-Objekt erzeugen
   lngRet = OleCreatePictureIndirect( _
      udtPicdesc, IID_IDispatch, 1&, objPic)
      
   ' Picture-Objekt zurückgeben
   If lngRet = 0 Then Set CreateEAN13 = objPic
   
   ' Alten Pinsel zurück ins DC, neuen Pinsel zerstören
   SelectObject lngDestDC, lngObjOldBrush
   DeleteObject lngBrush
   
   ' Alte Bitmap zurück ins DC, DC zerstören
   SelectObject lngDestDC, lngObjOldDest
   DeleteDC lngDestDC
   
End Function

Private Sub DrawNumbers( _
   strNumbers As String, lngDC As Long, _
   lngWidth As Long, lngHeight As Long _
   )
   Dim udtFont             As LOGFONT
   Dim lngFont             As Long
   Dim strFont             As String
   Dim abytFontname()      As Byte
   Dim bytOrientation      As Long
   Dim udtRectFrame        As RECT
   Dim strText             As String
   Dim lngTextSize         As Long
   Dim udtTextFrame        As RECT
   Dim lngTextWidth        As Long
   Dim i                   As Long
   Dim dblFrameWidth       As Double
   
   bytOrientation = DT_CENTER
   
   ' Schriftart Text
   abytFontname = StrConv(mstrFont & Chr$(0), vbFromUnicode)
   
   ' Textbreite
   lngTextWidth = (lngWidth - 30 * mlngWidth - mlngWhiteZoneWidth) / Len(strNumbers)
   
   ' Texthöhe
   lngTextSize = mlngLength / 4
   
   ' Eigenschaften Schriftart setzen
   With udtFont
      .lfHeight = lngTextSize * -1
      .lfWeight = mlngTextThickness
      .lfWidth = lngTextWidth
      For i = 0 To UBound(abytFontname)
         .lfFaceName(i) = abytFontname(i)
      Next
   End With
   
   ' Schrift mit eingestellten Eigenschaften erzeugen
   lngFont = CreateFontIndirect(udtFont)
   
   ' Schrifteigenschaften in den DC bringen
   SelectObject lngDC, lngFont
   
   ' Neue Schriftfarbe setzen
   SetTextColor lngDC, mlngTextColor
   
   ' Größe Textrahmen 1. Ziffer setzen
   With udtTextFrame
       .Left = 0
       .Top = lngHeight - mlngWhiteZoneHeight - mlngLength / 4
       .Right = mlngWhiteZoneWidth
       .Bottom = lngHeight - mlngWhiteZoneHeight
   End With
   
   ' Hintergrund Text auf Transparent
   SetBkMode lngDC, TRANSPARENT
   
   ' Text in den DC malen
   DrawText lngDC, Left(strNumbers, 1), 1, udtTextFrame, bytOrientation
   
   ' Größe Textrahmen linke Hälfte setzen
   With udtTextFrame
       .Left = mlngWhiteZoneWidth + 3 * mlngWidth
       .Right = lngWidth / 2 - 1.5 * mlngWidth
       .Top = lngHeight - mlngWhiteZoneHeight - mlngLength / 4
       .Bottom = lngHeight - mlngWhiteZoneHeight
   End With
   ' Text in den DC malen
   DrawText lngDC, Mid(strNumbers, 2, 6), 6, udtTextFrame, bytOrientation
   
   ' Größe Textrahmen rechte Hälfte setzen
   With udtTextFrame
       .Left = lngWidth / 2 + 1.5 * mlngWidth
       .Right = lngWidth - mlngWhiteZoneWidth - 3 * mlngWidth
       .Top = lngHeight - mlngWhiteZoneHeight - mlngLength / 4
       .Bottom = lngHeight - mlngWhiteZoneHeight
   End With
   ' Text in den DC malen
   DrawText lngDC, Mid(strNumbers, 8, 6), 6, udtTextFrame, bytOrientation
   
   ' Schrift mit eingestellten Eigenschaften löschen
   DeleteObject lngFont

End Sub

Private Sub DrawMyText( _
   strText As String, lngDC As Long, _
   lngWidth As Long, lngHeight As Long _
   )
   Dim udtFont             As LOGFONT
   Dim lngFont             As Long
   Dim strFont             As String
   Dim abytFo
ntname()      As Byte
   Dim bytOrientation      As Long
   Dim udtRectFrame        As RECT
   Dim lngTextSize         As Long
   Dim udtTextFrame        As RECT
   Dim lngTextWidth        As Long
   Dim i                   As Long
   
   bytOrientation = DT_CENTER
   
   With udtTextFrame
       .Left = mlngWhiteZoneWidth
       .Top = lngHeight - mlngWhiteZoneHeight - mlngLength / 4.5
       .Right = lngWidth - mlngWhiteZoneWidth
       .Bottom = lngHeight - mlngWhiteZoneHeight
       lngTextSize = .Bottom - .Top
   End With
  
   lngTextWidth = 0
   
   ' Schriftart Text
   abytFontname = StrConv(mstrFont & Chr$(0), vbFromUnicode)

   ' Eigenschaften Schriftart setzen
   With udtFont
      .lfHeight = lngTextSize * -1
      .lfWeight = mlngTextThickness
      .lfWidth = lngTextWidth
      For i = 0 To UBound(abytFontname)
         .lfFaceName(i) = abytFontname(i)
      Next
   End With
   
   lngFont = CreateFontIndirect(udtFont)
   
   SelectObject lngDC, lngFont
   
   ' Hintergrund Text auf Transparent
   SetBkMode lngDC, TRANSPARENT
   
   ' Neue Farbe setzen
   SetTextColor lngDC, mlngTextColor
   
   DrawText lngDC, strText, Len(strText), udtTextFrame, bytOrientation
   
   DeleteObject lngFont

End Sub

Private Function EANCheckNumber(strEAN As StringAs Long
   Dim i As Long
   
   For i = 1 To Len(strEAN)
      If (i Mod 2) = 0 Then
         EANCheckNumber = EANCheckNumber + CLng(Mid(strEAN, i, 1)) * 3
      Else
         EANCheckNumber = EANCheckNumber + CLng(Mid(strEAN, i, 1))
      End If
   Next
   
   ' Der Divisionsrest durch 10 wird ermittelt
   EANCheckNumber = 10 - EANCheckNumber Mod 10
   
   If EANCheckNumber = 10 Then EANCheckNumber = 0
End Function

Private Function Code39CheckChar(strCode39 As StringAs String
   Dim i          As Long
   Dim k          As Long
   Dim m          As Long
   Dim strChar    As String
   
   For i = 1 To Len(strCode39)
   
      ' Zeichen extrahieren
      strChar = Mid(strCode39, i, 1)
      
      ' Code des Zeichens aus Codetabelle holen
      For m = 0 To 43
         If UCase(strChar) = mastr39(m, 1) Then
            k = k + m
            Exit For
         End If
      Next
   
   Next
   
   ' Der Divisionsrest durch 43 wird ermittelt
   ' und das Zeichen extrahiert
   Code39CheckChar = mastr39(k Mod 43, 1)
   
End Function

Public Property Let Schriftdicke(ByVal vNewValue As Byte)
   'Schriftdicke Text
   Select Case vNewValue
      Case Is >= 9
         mlngTextThickness = FW_HEAVY
      Case 8
         mlngTextThickness = FW_EXTRABOLD
      Case 7
         mlngTextThickness = FW_BOLD
      Case 6
         mlngTextThickness = FW_SEMIBOLD
      Case 5
         mlngTextThickness = FW_MEDIUM
      Case 4
         mlngTextThickness = FW_NORMAL
      Case 3
         mlngTextThickness = FW_LIGHT
      Case 2
         mlngTextThickness = FW_EXTRALIGHT
      Case 1
         mlngTextThickness = FW_THIN
      Case Else
         mlngTextThickness = FW_DONTCARE
   End Select
End Property

Public Property Let Balkenbreite(ByVal vNewValue As Long)
   mlngLength = vNewValue
   If mlngLength < 60 Then mlngLength = 60
End Property

Public Property Let Balkendicke(ByVal vNewValue As Long)
   mlngWidth = vNewValue
End Property

Public Property Let Textfarbe(ByVal vNewValue As Long)
   mlngTextColor = vNewValue
End Property

Public Property Let Schriftart(ByVal vNewValue As String)
   mstrFont = vNewValue
End Property

Public Property Let Hintergrundfarbe(ByVal vNewValue As Long)
   mlngBackColor = vNewValue
End Property

Public Property Let RuhezoneBreite(ByVal vNewValue As Long)
   mlngWhiteZoneWidth = vNewValue
   If mlngWhiteZoneWidth < 20 Then mlngWhiteZoneWidth = 20
End Property
Public Property Let RuhezoneHöhe(ByVal vNewValue As Long)
   mlngWhiteZoneHeight = vNewValue
   If mlngWhiteZoneHeight < 20 Then mlngWhiteZoneHeight = 20
End Property

Public Property Get GrößeX() As Long
   GrößeX = mlngResX
End Property
Public Property Get GrößeY() As Long
   GrößeY = mlngResY
End Property

Private Sub Class_Initialize()
   mlngWhiteZoneWidth = 40
   mlngWhiteZoneHeight = 40
   mlngWidth = 5
   mlngLength = 60
   mlngTextThickness = FW_BOLD
   mlngTextColor = RGB(0, 0, 0)
   mstrFont = "Courier New"
   mlngBackColor = RGB(255, 255, 255)
   mlngLineColor = RGB(0, 0, 0)
   InitEAN
   InitCode39
   CreateDummyBMP
End Sub

Private Sub CreateDummyBMP()
   Dim varBMP     As Variant
   Dim abyteBMP() As Byte
   Dim i          As Long
   Dim FF         As Long
   Dim strDest    As String
   
   strDest = Environ("Temp") & "\Dummy.bmp"
   If Dir(strDest) <> "" Then Kill strDest
   
   varBMP = Array( _
      66, 77, 58, 0, 0, 0, 0, 0, 0, 0, _
      54, 0, 0, 0, 40, 0, 0, 0, 1, 0, _
      0, 0, 1, 0, 0, 0, 1, 0, 24, 0, _
      0, 0, 0, 0, 4, 0, 0, 0, 196, 14, _
      0, 0, 196, 14, 0, 0, 0, 0, 0, 0, _
      0, 0, 0, 0, 255, 255, 255, 0)
      
   ReDim abyteBMP(0 To UBound(varBMP))
   
   For i = 0 To UBound(varBMP)
      abyteBMP(i) = varBMP(i)
   Next
   
   FF = FreeFile
   Open strDest For Binary As FF
      Put #FF, , abyteBMP
   Close FF
   
   Set mobjPicture = LoadPicture(strDest)
   
End Sub

Private Sub InitEAN()

   mastrEAN13(0, 1) = "WWWBBWB" ' Code A
   mastrEAN13(0, 3) = "BBBWWBW" ' Code C
   mastrEAN13(0, 2) = "WBWWBBB" ' Code B
   
   mastrEAN13(1, 1) = "WWBBWWB"
   mastrEAN13(1, 3) = "BBWWBBW"
   mastrEAN13(1, 2) = "WBBWWBB"
      
   mastrEAN13(2, 1) = "WWBWWBB"
   mastrEAN13(2, 3) = "BBWBBWW"
   mastrEAN13(2, 2) = "WWBBWBB"
   
   mastrEAN13(3, 1) = "WBBBBWB"
   mastrEAN13(3, 3) = "BWWWWBW"
   mastrEAN13(3, 2) = "WBWWWWB"
   
   mastrEAN13(4, 1) = "WBWWWBB"
   mastrEAN13(4, 3) = "BWBBBWW"
   mastrEAN13(4, 2) = "WWBBBWB"
      
   mastrEAN13(5, 1) = "WBBWWWB"
   mastrEAN13(5, 3) = "BWWBBBW"
   mastrEAN13(5, 2) = "WBBBWWB"
   
   mastrEAN13(6, 1) = "WBWBBBB"
   mastrEAN13(6, 3) = "BWBWWWW"
   mastrEAN13(6, 2) = "WWWWBWB"
   
   mastrEAN13(7, 1) = "WBBBWBB"
   mastrEAN13(7, 3) = "BWWWBWW"
   mastrEAN13(7, 2) = "WWBWWWB"
   
   mastrEAN13(8, 1) = "WBBWBBB"
   mastrEAN13(8, 3) = "BWWBWWW"
   mastrEAN13(8, 2) = "WWWBWWB"
      
   mastrEAN13(9, 1) = "WWWBWBB"
   mastrEAN13(9, 3) = "BBBWBWW"
   mastrEAN13(9, 2) = "WWBWBBB"
   
   ' Metacode, Zugehörigkeit zu Code A oder B
   mastrEAN13(0, 0) = "AAAAAA"
   mastrEAN13(1, 0) = "AABABB"
   mastrEAN13(2, 0) = "AABBAB"
   mastrEAN13(3, 0) = "AABBBA"
   mastrEAN13(4, 0) = "ABAABB"
   mastrEAN13(5, 0) = "ABBAAB"
   mastrEAN13(6, 0) = "ABBBAA"
   mastrEAN13(7, 0) = "ABABAB"
   mastrEAN13(8, 0) = "ABABBA"
   mastrEAN13(9, 0) = "ABBABA"
   
End Sub

Private Sub InitCode39()

   mastr39(1, 1) = "1": mastr39(1, 2) = "100100001"
   mastr39(2, 1) = "2": mastr39(2, 2) = "001100001"
   mastr39(3, 1) = "3": mastr39(3, 2) = "101100000"
   mastr39(4, 1) = "4": mastr39(4, 2) = "000110001"
   mastr39(5, 1) = "5": mastr39(5, 2) = "100110000"
   mastr39(6, 1) = "6": mastr39(6, 2) = "001110000"
   mastr39(7, 1) = "7": mastr39(7, 2) = "000100101"
   mastr39(8, 1) = "8": mastr39(8, 2) = "100100100"
   mastr39(9, 1) = "9": mastr39(9, 2) = "001100100"
   mastr39(0, 1) = "0": mastr39(0, 2) = "000110100"
   mastr39(10, 1) = "A": mastr39(10, 2) = "100001001"
   mastr39(11, 1) = "B": mastr39(11, 2) = "001001001"
   mastr39(12, 1) = "C": mastr39(12, 2) = "101001000"
   mastr39(13, 1) = "D": mastr39(13, 2) = "000011001"
   mastr39(14, 1) = "E": mastr39(14, 2) = "100011000"
   mastr39(15, 1) = "F": mastr39(15, 2) = "001011000"
   mastr39(16, 1) = "G": mastr39(16, 2) = "000001101"
   mastr39(17, 1) = "H": mastr39(17, 2) = "100001100"
   mastr39(18, 1) = "I": mastr39(18, 2) = "001001100"
   mastr39(19, 1) = "J": mastr39(19, 2) = "000011100"
   mastr39(20, 1) = "K": mastr39(20, 2) = "100000011"
   mastr39(21, 1) = "L": mastr39(21, 2) = "001000011"
   mastr39(22, 1) = "M": mastr39(22, 2) = "101000010"
   mastr39(23, 1) = "N": mastr39(23, 2) = "000010011"
   mastr39(24, 1) = "O": mastr39(24, 2) = "100010010"
   mastr39(25, 1) = "P": mastr39(25, 2) = "001010010"
   mastr39(26, 1) = "Q": mastr39(26, 2) = "000000111"
   mastr39(27, 1) = "R": mastr39(27, 2) = "100000110"
   mastr39(28, 1) = "S": mastr39(28, 2) = "001000110"
   mastr39(29, 1) = "T": mastr39(29, 2) = "000010110"
   mastr39(30, 1) = "U": mastr39(30, 2) = "110000001"
   mastr39(31, 1) = "V": mastr39(31, 2) = "011000001"
   mastr39(32, 1) = "W": mastr39(32, 2) = "111000000"
   mastr39(33, 1) = "X": mastr39(33, 2) = "010010001"
   mastr39(34, 1) = "Y": mastr39(34, 2) = "110010000"
   mastr39(35, 1) = "Z": mastr39(35, 2) = "011010000"
   mastr39(36, 1) = "-": mastr39(36, 2) = "010000101"
   mastr39(37, 1) = ".": mastr39(37, 2) = "110000100"
   mastr39(38, 1) = " ": mastr39(38, 2) = "011000100"
   mastr39(39, 1) = "$": mastr39(39, 2) = "010101000"
   mastr39(40, 1) = "/": mastr39(40, 2) = "110100010"
   mastr39(41, 1) = "+": mastr39(41, 2) = "010001010"
   mastr39(42, 1) = "%": mastr39(42, 2) = "000101010"
   
   ' Anfangs- Endezeichen
   mastr39(43, 1) = "*": mastr39(43, 2) = "010010100"
   
End Sub

Die Pozedur CreateCode39

Diese Prozedur zeichnet in einem DC den Barcode vom Typ Code39. Übergeben wird dazu eine Stringvariable mit den zu zeichnenden Ziffern.

Ist eine Prüfziffer gewünscht, wird diese mit der Funktion Code39CheckChar erzeugt und der Ziffernfolge angehängt. Danach werden noch das Anfangs- und Endezeichen "*" an den String gehängt.

Anschließend wird die benötigte Größe des Bildes berechnet und ein DC angelegt, welcher kompatibel zum Screen ist. In diesen DC wird nun eine reale 1*1 Bitmap mit 24 Bit Farbtiefe gestellt, welche mit der Prozedur CreateDummyBMP beim Initialisieren der Klasse erzeugt wurde. Das alte Objekt wird in einer Variablen gespeichert. Damit erhält man eine DC, die auch 24 Bit Farbtiefe unterstützt. Stellt man sofort eine leere Bitmap hinein, erhält man nur 1 Bit Farbtiefe, egal mit welcher Farbtiefe die Bitmap erzeugt wurde.

Nun kann man mit der API CreateCompatibleBitmap eine Bitmap der gewünschten Größe erzeugen und in den DC stellen. Mit der API CreateSolidBrush wird nun ein solides Pinselobjekt in der gewünschten Hintergrundfarbe erstellt und auch in den DC gestellt. Mit der API Rectangle werden nun alle Pixel auf die gewünschte Hintergrundfarbe gesetzt.

Die Prozedur DrawMyText malt den Text, welcher unterhalb des Strichcodes erscheinen soll, in den DC. Mit der API CreateSolidBrush wird anschließend ein solides Pinselobjekt in der gewünschten Farbe der Balken (hier schwarz) erstellt und in den DC gestellt.

Die Abfolge der Balken, wobei eine Null einen dünnen Balken, eine 1 einen dicken Balken repräsentiert, wird dem Array mastr39 entnommen und in der Variablen strCodeTable gespeichert. Mit der API Rectangle werden nun nacheinander alle Balken gemalt.

Nachdem alle Balken, die Zeichen und der Hintergrund gemalt sind, kann man aus der Bitmap ein Bild vom Typ IPictureDisp machen. Benutzt wird dafür die API OleCreatePictureIndirect. Dieser übergibt man die ausgefüllte Struktur udtPicdesc vom Typ PICTDESC und die Schnittstellenkennung IID_IDispatch vom Typ GUID. Das ebenfalls übergebene Objekt vom Typ IPictureDisp gibt das Bild zurück, welches als Bitmaphandle in der Struktur udtPicdesc vom Typ PICTDESC steckt.

Den Erfolg der Aktion erkennt man daran, dass von der API als Funktionsergebnis der Wert Null zurückgegeben wurde. In diesem Fall wird das Objekt objPic als Funktionsergebnis zurückgegeben. Zum Schluss werden noch überflüssig gewordene Objekte zerstört und noch einige andere Aufräumarbeiten durchgeführt.

Die Pozedur CreateEAN13

Diese Prozedur zeichnet in einem DC den Barcode vom Typ EAN13. Übergeben wird dazu eine Stringvariable mit den zu zeichnenden Ziffern.

Zu Beginn wird überprüft, ob es sich auch tatsächlich um genau 12 Ziffern handelt und diese auch wirklich Ziffern sind. Mit der Funktion EANCheckNumber wird die Prüfziffer erzeugt und an die Ziffernfolge gehängt.

Anschließend wird die benötigte Größe des Bildes berechnet und ein DC angelegt, welcher kompatibel zum Screen ist. In diesen DC wird nun eine reale 1*1 Bitmap mit 24 Bit Farbtiefe gestellt, welche mit der Prozedur CreateDummyBMP beim Initialisieren der Klasse erzeugt wurde. Das alte Objekt wird in einer Variablen gespeichert. Damit erhält man eine DC, die auch 24 Bit Farbtiefe unterstützt. Stellt man sofort eine leere Bitmap hinein, erhält man nur 1 Bit Farbtiefe, egal mit welcher Farbtiefe die Bitmap erzeugt wurde.

Nun kann man mit der API CreateCompatibleBitmap eine Bitmap der gewünschten Größe erzeugen und in den DC stellen. Mit der API CreateSolidBrush wird nun ein solides Pinselobjekt in der gewünschten Hintergrundfarbe erstellt und auch in den DC gestellt. Mit der API Rectangle werden nun alle Pixel auf die gewünschte Hintergrundfarbe gesetzt.

Die Prozedur DrawNumbers malt den Text, welcher unterhalb des Strichcodes erscheinen soll, in den DC. Mit der API CreateSolidBrush wird anschließend ein solides Pinselobjekt in der gewünschten Farbe der Balken (hier schwarz) erstellt und in den DC gestellt.

Mit der API Rectangle werden nun nacheinander alle Balken gemalt. Erst kommen die längeren RandBalken links und rechts, sowie die mittleren Trennbalken an die Reihe. Die Ziffern 2 bis 7 werden nun als kürzere Balken in der linken Hälfte zwischen den längeren linken und mittleren Trennbalken gemalt. Man muss dabei beachten, dass die Zeichensätze der einzelnen Balkenfolgen passen, da die Folge der Zeichensätze A und B die 1. Ziffer codiert.

Danach werden die Ziffern 8 bis 13 als kürzere Balken in der rechten Hälfte zwischen den längeren rechten und mittleren Trennbalken gemalt. Benutzt wird die Codetabelle C.

Nachdem alle Balken, die Zeichen und der Hintergrund gemalt sind, kann man aus der Bitmap ein Bild vom Typ IPictureDisp machen. Benutzt wird dafür die API OleCreatePictureIndirect. Dieser übergibt man die ausgefüllte Struktur udtPicdesc vom Typ PICTDESC und die Schnittstellenkennung IID_IDispatch vom Typ GUID. Das ebenfalls übergebene Objekt vom Typ IPictureDisp gibt das Bild zurück, welches als Bitmaphandle in der Struktur udtPicdesc vom Typ PICTDESC steckt.

Den Erfolg der Aktion erkennt man daran, dass von der API als Funktionsergebnis der Wert Null zurückgegeben wurde. In diesem Fall wird das Objekt objPic als Funktionsergebnis zurückgegeben. Zum Schluss werden noch überflüssig gewordene Objekte zerstört und noch einige andere Aufräumarbeiten durchgeführt.

Die Pozedur DrawNumbers

Diese Prozedur zeichnet in einem DC einen Text. Übergeben wird dazu eine Stringvariable mit dem zu zeichnenden Text, den DC als Handle, sowie die Breite und Höhe des Bildes.

Die Schrifteigenschaften werden über die Struktur udtFont vom Typ LOGFONT gesetzt. Diese Struktur wird an die API-Funktion CreateFontIndirect übergeben, die ein Handle auf die erzeugte Schrift zurückliefert. Diese Schrift wird mit SelectObject in den DC gestellt. Mit der API SetBkMode wird der Hintergrundmodus für das Schreiben von Text auf Transparent gesetzt. Mit der API SetTextColor wird die Textfarbe festgelegt.

Für die linke Ziffer wird eine Struktur vom Typ RECT ausgefüllt, welche die Größe und Position des Textfeldes enthält, in welches der Text anschließend gezeichnet werden soll. Diese Ziffer soll unten links neben dem EAN Barcode gezeichnet werden. Mit der API-Funktion DrawText wird die 1. Ziffer in das virtuelle Textfeld gemalt und zwar in der Orientierung DT_CENTER, also zentriert.

Die nächsten sechs Ziffern sollen in der linken Hälfte unterhalb des Barcodes erscheinen, dafür wird eine Struktur vom Typ RECT ausgefüllt, welche die Größe und Position des Textfeldes enthält. Mit der API-Funktion DrawText werden die 6 Ziffer in das virtuelle Textfeld gemalt und zwar in der Orientierung DT_CENTER, also zentriert.

Die letzten sechs Ziffern sollen in der rechten Hälfte unterhalb des Barcodes erscheinen, dafür wird eine Struktur vom Typ RECT ausgefüllt, welche die Größe und Position des Textfeldes enthält. Mit der API-Funktion DrawText werden die 6 Ziffer in das virtuelle Textfeld gemalt und zwar in der Orientierung DT_CENTER, also zentriert.

Nun muss noch mit der API DeleteObject die erzeugte Schriftart gelöscht werden.

Die Pozedur DrawMyText

Diese Prozedur zeichnet in einem DC einen Text. Übergeben wird dazu eine Stringvariable mit dem zu zeichnenden Text, den DC als Handle, sowie die Breite und Höhe des Bildes. Zu Beginn wird eine Struktur vom Typ RECT ausgefüllt, welche die Größe und Position des Textfeldes enthält, in welches der Text anschließend gezeichnet werden soll.

Die Schrifteigenschaften werden über die Struktur udtFont vom Typ LOGFONT gesetzt. Diese Struktur wird an die API-Funktion CreateFontIndirect übergeben, die ein Handle auf die erzeugte Schrift zurückliefert. Diese Schrift wird mit SelectObject in den DC gestellt.

Mit der API SetBkMode wird der Hintergrundmodus für das Schreiben von Text auf Transparent gesetzt. Mit der API SetTextColor wird die Textfarbe festgelegt und mit der API-Funktion DrawText der Text in das virtuelle Textfeld gemalt und zwar in der Orientierung DT_CENTER, also zentriert. Nun muss noch mit der API DeleteObject die erzeugte Schriftart gelöscht werden.

Die Funktion CreateDummyBMP

Diese Funktion, welche bereits bei der Initialisierung der Klasse aufgerufen wird, erzeugt im Temp-Verzeichnis eine Farb-Bitmap mit 1 Pixel Größe. Die erhält den Namen Dummy.bmp, eine in diesem Verzeichnis befindliche mit gleichem Namen wird vorher gelöscht. Diese Bitmap ist äußerst wichtig, damit ein zum farbigen Desktop kompatibler DC, welche eine selbst erzeugte farbige Bitmap enthält, auch wirklich farbige Bilder zulässt. Diese Bitmap wird einmal kurz in den DC gestellt, bevor man seine selbst erzeugte hineinstellt.

Warum es so ist, dass eine farbige Bitmap in einem zum Desktop kompatiblen DC ohne solch einen Kniff nur schwarzweiße Bilder zulässt? Keine Ahnung, aber Windows geht manchmal seltsame Wege! Jedenfalls hat mich dieses Feature einige zermürbende Stunden gekostet.

Die Eigenschaftsprozeduren Schriftdicke, Balkenbreite, Balkendicke, Textfarbe, Schriftart, Hintergrundfarbe, RuhezoneBreite, RuhezoneHöhe, GrößeX, GrößeY

Die Eigenschaftsprozeduren nehmen Werte entgegen und speichern diese in Klassenweit gültigen Variablen. Die Eigenschaften GrößeX und GrößeY geben die Größe des erzeugten Bildes in Pixel zurück.

Die Funktion EANCheckNumber

Die Funktion erwartet eine Zeichenkette mit 12 Ziffern. Die Prüfziffer wird so berechnet, dass die Ziffern 1-12 addiert werden, wobei die Ziffern an einer geraden Position zuvor mit 3 multipliziert werden. Bei einer Division der Summe durch Zehn bleibt ein Rest, der von 10 abgezogen die Prüfziffer ergibt. Diese Ziffer wird anschließend als Funktionsergebnis vom Typ Long zurückgegeben.

Die Funktion Code39CheckChar

Diese Funktion erwartet eine Zeichenkette. Für alle Zeichen wird die Position in der Codetabelle ermittelt und die Summe dieser Positionen gebildet. Der Divisionsrest dieser Summe durch 43 wird ermittelt und das Zeichen, welches sich in der Codetabelle an dieser Position befindet, wird als Funktionsergebnis zurückgegeben.

Die Prozedur InitCode39

Diese Prozedur erzeugt ein modulweit gültiges Array, wobei das zweite Element der zweiten Dimension alle 43 möglichen Zeichen des Code39 als Strichcodefolge mit Trennzeichen zwischen den Strichcodefolgen enthält, das erste nimmt dabei die entsprechenden Zeichen im Klartext auf.

Ein schmaler Strich oder Lücke gilt dabei als 0, ein breiter Strich oder Lücke wird als 1 gewertet. Fünf Striche und die vier Lücken dazwischen repräsentieren ein Zeichen. Zwischen den einzelnen Zeichen im Barcode befindet sich immer eine Lücke. Am Anfang und am Ende eines Barcodes steht immer ein bestimmtes Zeichen, codiert als "010010100", dieses markiert somit den Anfang und das Ende.

Die Prozedur InitEAN

Diese Prozedur erzeugt ein modulweit gültiges Array, welches alle möglichen Ziffern als Folge von sieben schwarzen oder weißen Modulen enthält. Schwarz wird als ein großes “B“ dargestellt, der Hintergrund als ein großes “W“. Ein Zeichen besteht aus zwei Balken und zwei Lücken, die sich aus insgesamt sieben Modulen zusammensetzen. Die Zeichenfolge "WBWWBBB" stellt also eine weiße Lücke, bestehend aus einem Modul, einem schwarzen Balken mit einem Modul, eine weiße Lücke aus zwei Modulen und schließlich einem schwarzen Balken aus 3 Modulen dar. Es gibt beim EAN-Code vier verschiedene Zeichensätze, die Zeichensätze A, B, C und der Meta-Zeichensatz. Für jeden Zeichensatz gibt es in der zweiten Dimension ein eigenes Element.

Die Grundlage der einzelnen Zeichensätze ist dabei eine Folge schwarzer oder weißer Module des Zeichensatzes A. Der Zeichensatz B ist die gespiegelte Modulfolge A, wobei auch noch die einzelnen Module invertiert sind. Der Zeichensatz C ist der gespiegelte Zeichensatz B. Der Metazeichensatz wird aus der Folge der Zeichensätze der linken Hälfte (A und B) des Barcodes gebildet. In der linken Hälfte befinden sich ausschließlich Zeichen der Zeichensätze A und B, in der rechten Hälfte ausschließlich Zeichen des Zeichensatzes C.

Der Barcode beginnt und endet immer mit einem Randzeichen, welches aus drei Modulen (BWB) besteht und enthält ein Trennzeichen in der Mitte aus fünf Modulen (WBWBW). Die linke Hälfte beinhaltet die Ziffern 2 bis 7, die rechte Hälfte die Ziffern 8 bis 13, wobei die 13. Ziffer eine Prüfziffer ist. Das 1. Zeichen, das links vom Randzeichen stehende, wird aus der Folge der Zeichensätze der linken Hälfte codiert, besitzt also im eigentlichen Sinn gar keine Folge aus Strichen und Lücken.