Przemysław Ernestowicz

Kierownik Działu IT, Profil Sp.J.

Wypowiedzi

• Wszystko
• Tylko fora

• 
  Wpis na grupie Ms Access w temacie Kod EAN - generowanie

  25.04.2017, 14:16

  Witam, kodu do generowania kodu kreskowego w Access.
  Kod działa idealnie, ale przy Accessie 64-bitowym wywala błąd w momencie wykonywania linii:
  CopyMemory aPictData(MY_BMIH_SIZE), ByVal lpByteImg, bmih.biSizeImage
  
  Co mogę zrobić, aby kod zaczął działać?
  Poniżej zamieszczam cały kod.
  
  Option Compare Database
  Option Explicit
  '|===============================================================================|
  '| 3.1 Kod kreskowy EAN -8 |
  '| *********************************** |
  '| Pobrano z : |
  '| http://www.bratki.w.v1.pl/accesspseudofaq/32a_ImgCodaF... |
  '|_______________________________________________________________________________|
  '| Kod możesz dowolnie modyfikować, ale proszę nie usuwać tej ramki |
  '| • autor: Zbigniew Bratko • 07.01.2005 r. • status: FREE |
  '|===============================================================================|
  
  Private Const ERR_FAIL_CHECK_DIGIT As Long = vbObjectError + 1000 + 2
  Private Const ERR_FAIL_SCALE_MODE As Long = vbObjectError + 1000 + 3
  Private Const ERR_NO_NUMERIC As Long = vbObjectError + 1000 + 4
  Private Const ERR_FAIL_LEN_CODE As Long = vbObjectError + 1000 + 5
  
  Private ctlMyImg As Access.Image
  Private lMyModW As Long 'szerokość modułu (linii) w pikselach => 2^lScale
  Private lMyLineH As Long 'względna wysokość właściwej kreski kodu
  
  Private lHDC As Long 'uchwyt kontekstu urządzenia
  Private lDpiX As Long 'rozdzielczość pozioma X
  Private lDpiY As Long 'rozdzielczość pionowa Y
  Private snPixToTwipsX As Single 'przelicznik Pikseli na Twipsy - poziomo
  Private snPixToTwipsY As Single 'przelicznik Pikseli na Twipsy - pionowo
  Private lEanH As Long 'przewidywana wysokość bitmapy EAN
  Private lExtraEanH As Long 'dodatkowa ilość linii wydłużająca dolny margines
  '===============================================================================================
  
  Private Const MY_CHARS_IN_PART As Long = 4 'ilość cyfr w częściach kodu EAN 8
  Private Const MY_CHARS_IN_CODE As Long = 8 'ilość cyfr kodu - EAN 8
  
  Private Type ENCODINGPART
  L1 As Long
  W1 As Long
  L2 As Long
  W2 As Long
  End Type
  
  Private EanA(0 To 9) As ENCODINGPART 'kodowanie kresek zbioru A
  Private EanC(0 To 9) As ENCODINGPART 'kodowanie kresek zbioru C
  Private aCodeNo(MY_CHARS_IN_CODE - 1) As Byte 'wszystkie cyfry kodu kreskowego
  Private lMyEanAngle As Long 'kąt obrotu kodu EAN; 0, 90, 180, 270 stopni
  Private fMyResize As Boolean 'czy dopasować rozmiar ctlMyImg do bitmapy kodu EAN
  
  'Uchwyty, pędzle, pióra, kolory, font
  Private hBkgBrush As Long
  Private hLineBrush As Long
  Private hPen As Long
  Private hFont As Long
  Private hOldBrush As Long
  Private hOldPen As Long
  Private hOldFont As Long
  
  Private lMyBkgCol As Long
  Private lMyLineCol As Long
  Private lMyFontCol As Long
  Private lOldFontCol As Long
  Private lOldBkgMode As Long
  
  Private Const MY_BKG_COL As Long = vbWhite
  Private Const MY_LINE_COL As Long = vbBlack
  Private Const MY_FONT_COL As Long = vbBlack
  Private Const MY_PEN_COL As Long = vbBlack
  Private Const MY_DEF_FONT_NAME As String = "Arial"
  Private Const MY_DEF_FONT_SIZE As Long = 8
  
  Private lFontH As Long
  Private lgf As LOGFONT
  '=======================================================================================
  'rozmiary i położenie elementów kodu EAN
  Private Const MY_MARG_LEFT As Long = 11 'margines lewy = 11 modułów
  Private Const MY_MARG_RIGHT As Long = 7 'margines prawy = 7 modułów
  Private Const MY_MARG_TOP As Long = 2 'margines górny = 2 moduły
  Private Const MY_MARG_BOTTOM As Long = 2 'margines dolny = 2 moduły
  
  Private Const MY_WIDTH_CHARS As Long = 7 'ilość modułów na znak
  Private Const MY_WIDTH_START As Long = 3 'ilość modułów na znak Start
  Private Const MY_WIDTH_SEP As Long = 5 'ilość modułów na znak Separacji
  Private Const MY_WIDTH_END As Long = 3 'ilość modułów na znak Stop
  Private Const MY_EXTRALENGTH As Long = 5 'ilość modułów wydłużająca w/w znaki
  Private Const MY_HEIGHT_LINE_MM As Long = 6 'wysokość właściwej kreski kodu w mm
  'bitmapa
  Private Const MY_BMIH_SIZE As Long = 40 'wielkośc nagłówka BitmapInfoHeader
  Private Const MY_MIN_SIZE_BMP As Long = 10240 'minimalna wielkość bitmapy, przy mniejszych
  'wielkościach czasami bitmapa jest niestabilna
  
  Private Sub Class_Initialize()
  Dim hdcAcc As Long
  
  hdcAcc = GetDC(Application.hWndAccessApp)
  lHDC = CreateCompatibleDC(hdcAcc)
  Call ReleaseDC(Application.hWndAccessApp, hdcAcc)
  
  lDpiX = GetDeviceCaps(lHDC, LOGPIXELSX)
  lDpiY = GetDeviceCaps(lHDC, LOGPIXELSY)
  snPixToTwipsX = 1440 / lDpiX
  snPixToTwipsY = 1440 / lDpiY
  
  EanScale = 0 '=> tworzy odpowiedniej wielkości FONT
  fMyResize = True
  EanHeightLineMm = MY_HEIGHT_LINE_MM
  
  EanA(0).L1 = 3: EanA(0).W1 = 2: EanA(0).L2 = 6: EanA(0).W2 = 1
  EanA(1).L1 = 2: EanA(1).W1 = 2: EanA(1).L2 = 6: EanA(1).W2 = 1
  EanA(2).L1 = 2: EanA(2).W1 = 1: EanA(2).L2 = 5: EanA(2).W2 = 2
  EanA(3).L1 = 1: EanA(3).W1 = 4: EanA(3).L2 = 6: EanA(3).W2 = 1
  EanA(4).L1 = 1: EanA(4).W1 = 1: EanA(4).L2 = 5: EanA(4).W2 = 2
  EanA(5).L1 = 1: EanA(5).W1 = 2: EanA(5).L2 = 6: EanA(5).W2 = 1
  EanA(6).L1 = 1: EanA(6).W1 = 1: EanA(6).L2 = 3: EanA(6).W2 = 4
  EanA(7).L1 = 1: EanA(7).W1 = 3: EanA(7).L2 = 5: EanA(7).W2 = 2
  EanA(8).L1 = 1: EanA(8).W1 = 2: EanA(8).L2 = 4: EanA(8).W2 = 3
  EanA(9).L1 = 3: EanA(9).W1 = 1: EanA(9).L2 = 5: EanA(9).W2 = 2
  
  EanC(0).L1 = 0: EanC(0).W1 = 3: EanC(0).L2 = 5: EanC(0).W2 = 1
  EanC(1).L1 = 0: EanC(1).W1 = 2: EanC(1).L2 = 4: EanC(1).W2 = 2
  EanC(2).L1 = 0: EanC(2).W1 = 2: EanC(2).L2 = 3: EanC(2).W2 = 2
  EanC(3).L1 = 0: EanC(3).W1 = 1: EanC(3).L2 = 5: EanC(3).W2 = 1
  EanC(4).L1 = 0: EanC(4).W1 = 1: EanC(4).L2 = 2: EanC(4).W2 = 3
  EanC(5).L1 = 0: EanC(5).W1 = 1: EanC(5).L2 = 3: EanC(5).W2 = 3
  EanC(6).L1 = 0: EanC(6).W1 = 1: EanC(6).L2 = 2: EanC(6).W2 = 1
  EanC(7).L1 = 0: EanC(7).W1 = 1: EanC(7).L2 = 4: EanC(7).W2 = 1
  EanC(8).L1 = 0: EanC(8).W1 = 1: EanC(8).L2 = 3: EanC(8).W2 = 1
  EanC(9).L1 = 0: EanC(9).W1 = 3: EanC(9).L2 = 4: EanC(9).W2 = 1
  
  hPen = CreatePen(PS_SOLID, 1, MY_PEN_COL)
  hOldPen = SelectObject(lHDC, hPen)
  
  lMyBkgCol = MY_BKG_COL
  hBkgBrush = CreateSolidBrush(MY_BKG_COL)
  hOldBrush = SelectObject(lHDC, hBkgBrush)
  
  lMyLineCol = MY_LINE_COL
  hLineBrush = CreateSolidBrush(MY_LINE_COL)
  
  lOldFontCol = SetTextColor(lHDC, vbBlue)
  lOldBkgMode = SetBkMode(lHDC, TRANSPARENT)
  
  End Sub
  Private Sub Class_Terminate()
  
  Set ctlMyImg = Nothing
  
  'przywróć stare pióro
  Call SelectObject(lHDC, hOldPen)
  'zniszcz używane pióro
  Call DeleteObject(hPen)
  'wybierz stary pędzel
  Call SelectObject(lHDC, hOldBrush)
  'usuń nieużywane pędzle
  Call DeleteObject(hBkgBrush)
  Call DeleteObject(hLineBrush)
  'przywróć kolor tekstu i styl tła
  Call SetTextColor(lHDC, lOldFontCol)
  Call SetBkMode(lHDC, lOldBkgMode)
  'przywróć stary font
  Call SelectObject(lHDC, hOldFont)
  'zniszcz używany font
  Call DeleteObject(hFont)
  'usuń kontekst urządzenia
  Call DeleteDC(lHDC)
  
  End Sub
  'kolor tła bitmapy
  Public Property Let EanColorBkg(lBkgCol As Long)
  lMyBkgCol = lBkgCol
  
  SelectObject lHDC, hOldBrush
  DeleteObject hBkgBrush
  hBkgBrush = CreateSolidBrush(lMyBkgCol)
  'SelectObject lHDC, hBkgBrush
  
  End Property
  Public Property Get EanColorBkg() As Long
  EanColorBkg = lMyBkgCol
  End Property
  'kolor linii kodu
  Public Property Let EanColorLine(lLineCol As Long)
  lMyLineCol = lLineCol
  
  SelectObject lHDC, hOldBrush
  DeleteObject hLineBrush
  hLineBrush = CreateSolidBrush(lMyLineCol)
  'SelectObject lHDC, hLineBrush
  
  End Property
  Public Property Get EanColorLine() As Long
  EanColorLine = lMyLineCol
  End Property
  'kolor czcionki
  Public Property Let EanColorFont(lCol As Long)
  lMyFontCol = lCol
  SetTextColor lHDC, lCol
  End Property
  Public Property Get EanColorFont() As Long
  EanColorFont = lMyFontCol
  End Property
  'kąt obrotu kodu EAN; 0, 90, 180, 270 stopni
  Public Property Let EanAngle(lAng As Integer)
  Dim lAngle As Integer
  lAngle = lAng - (lAng \ 360) * 360
  
  If lAngle < 0 Then lAngle = lAngle + 359
  lAngle = (((Abs(lAngle)) + 45) \ 90) * 90
  If lAngle >= 360 Then lAngle = 0
  lMyEanAngle = lAngle
  
  End Property
  Public Property Get EanAngle() As Integer
  EanAngle = lMyEanAngle
  End Property
  'współczynnik skalowania bitmapy
  'szerokość modułu (linii) w pikselach => 2^lScale
  'zmiana współczynnika wymusza utworzenie nowego fontu
  Public Property Let EanScale(ByVal lScale As Long)
  
  If lScale > 3 Then
  zbRaiseErrCls ERR_FAIL_SCALE_MODE
  End If
  
  If lMyModW <> 2 ^ lScale Then
  lMyModW = 2 ^ lScale
  If lMyModW <= 0 Then lMyModW = 1
  Call zbCreateFont
  End If
  
  End Property
  'przelicza wysokość właściwych linii kodu z milimetrów na piksele
  'z uwzględnieniem współczynnika skalowania
  Public Property Let EanHeightLineMm(lHeight As Long)
  lMyLineH = (lHeight) * lDpiY / 25.4
  If lMyLineH <= 0 Then lMyLineH = 1 * lDpiY / 25.4
  lMyLineH = lMyLineH * lMyModW
  End Property
  'formant Image wyświetlający kod EAN-8
  Public Sub zbSetImgEan8(ctlImg As Access.Image)
  Set ctlMyImg = ctlImg
  End Sub
  'czy dopasować rozmiar ctlMyImg do bitmapy kodu
  Public Property Let EanResizeImg(fResize As Boolean)
  fMyResize = fResize
  End Property
  'funkcja wywołująca tworzenie kodu EAN-8, zwraca liczbę kontrolną lub ""
  Public Function DrawCodeBarEan8(sCode As String) As String
  Dim lChkDig As Long
  
  lChkDig = zbCheckDigitExamine(sCode)
  If lChkDig > -1 Then
  DrawCodeBarEan8 = lChkDig
  Call zbBmpCreate
  Else
  DrawCodeBarEan8 = ""
  End If
  
  End Function
  'zwraca liczbę kontrolną dla potrzeb formularza (OnChange)- lokalnie używa aNo()
  'TUTAJ NIE JEST STOSOWANA - wewnątrz klasy stosowana jest zbCheckDigitExamine
  Public Function zbCheckDigitCalculateEAN(sCode As String) As String
  Dim aNo(0 To MY_CHARS_IN_CODE - 2) As Byte
  Dim lChkDig As Long
  Dim fOddEv As Boolean
  Dim i As Integer
  
  'sprawdź poprawność stringu wejściowego
  If Len(sCode) <> MY_CHARS_IN_CODE - 1 Or IsNumeric(sCode) = False Then
  If IsNull(ctlMyImg.PictureData) = False Then ctlMyImg.Picture = ""
  zbCheckDigitCalculateEAN = ""
  Exit Function
  End If
  
  CopyMemory aNo(0), ByVal sCode, MY_CHARS_IN_CODE - 1
  
  fOddEv = True
  For i = 0 To MY_CHARS_IN_CODE - 2
  aNo(i) = Chr$(aNo(i))
  
  If fOddEv = True Then
  lChkDig = lChkDig + 3 * aNo(i)
  Else
  lChkDig = lChkDig + aNo(i)
  End If
  fOddEv = Not fOddEv
  Next
  
  lChkDig = lChkDig Mod 10
  If lChkDig > 0 Then lChkDig = 10 - lChkDig
  
  zbCheckDigitCalculateEAN = lChkDig
  
  End Function
  'tworzy bitmapę, przemalowuje ją kolorem tła i wywołuje funkcję:
  'rysująca kod i obracającą bitmapę kodu kreskowego
  Private Sub zbBmpCreate()
  
  Dim bmih As BITMAPINFOHEADER
  Dim aPictData() As Byte 'bajty bitmapy - odpowiednik img.PictureData
  Dim lBmpWidth As Long 'całkowita szerkośc bitmapy
  Dim lpByteImg As Long 'wskaźnik do bajtów obrazu
  Dim lLenLine As Long 'ilość bajtów linii bitmapy
  Dim hBmp As Long 'uchwyt Bmp
  Dim hMyOldBitmap As Long ' ""
  
  'szerokość bitmapy - orientacja pozioma
  lBmpWidth = (MY_MARG_LEFT + _
  MY_WIDTH_START + MY_CHARS_IN_PART * MY_WIDTH_CHARS + _
  MY_WIDTH_SEP + _
  MY_CHARS_IN_PART * MY_WIDTH_CHARS + MY_WIDTH_END + _
  MY_MARG_RIGHT) * lMyModW
  
  'szerokość linii w bajtach
  lLenLine = ((lBmpWidth * 3 + 3) \ 4) * 4
  'przewidywana wysokość bitmapy
  lEanH = (MY_MARG_TOP + MY_MARG_BOTTOM) * lMyModW + lFontH + lMyLineH
  
  'zwiększaj margines dolny, aż do przekroczenia granicy MY_MIN_SIZE_BMP
  'zbyt małe bitmapy nie zawsze są właściwie odmalowywane.
  'Access Bug ???
  lExtraEanH = 0
  Do While (lEanH + lExtraEanH) * lLenLine < MY_MIN_SIZE_BMP
  lExtraEanH = lExtraEanH + 1
  Loop
  
  'Utwórz nagłówek BitmapInfoHeader
  With bmih
  .biSize = MY_BMIH_SIZE
  .biWidth = lBmpWidth
  .biHeight = lEanH + lExtraEanH
  .biPlanes = 1
  .biBitCount = 24
  .biCompression = 0
  .biSizeImage = ((.biHeight * lLenLine))
  .biXPelsPerMeter = 0
  .biYPelsPerMeter = 0
  .biClrUsed = 0
  .biClrImportant = 0
  End With
  
  'utwórz bitmapę
  hBmp = CreateDIBSection(lHDC, bmih, DIB_RGB_COLORS, lpByteImg, 0&, 0&)
  hMyOldBitmap = SelectObject(lHDC, hBmp)
  
  ReDim aPictData(0 To MY_BMIH_SIZE + bmih.biSizeImage - 1)
  'kopiuj nagłówek bitmapy do tablicy
  CopyMemory aPictData(0), bmih, MY_BMIH_SIZE
  
  'przemaluj bitmapę
  SelectObject lHDC, hBkgBrush
  Call ExtFloodFill(lHDC, 0, 0, lMyBkgCol, FLOODFILLBORDER)
  
  Call zbBmpPaint
  
  CopyMemory aPictData(MY_BMIH_SIZE), ByVal lpByteImg, bmih.biSizeImage
  
  SelectObject lHDC, hMyOldBitmap
  DeleteObject hBmp
  'DeleteDC lHDC
  
  Call zbBmpRotate(aPictData())
  
  End Sub
  Private Sub zbBmpPaint()
  Dim rct As RECT
  Dim sde(0 To 5) As POINTAPI 'wspólrzędne znaków: Start, Sep, Stop
  Dim i As Byte
  Dim sText As String
  Dim papi As POINTAPI
  Dim bNumer As Byte
  
  'współrzędne znaków Start
  sde(0).x = MY_MARG_LEFT: sde(0).Y = sde(0).x + 1
  sde(1).x = sde(0).Y + 1: sde(1).Y = sde(1).x + 1
  'współrzędne znaków Separatora
  sde(2).x = sde(1).Y + MY_WIDTH_CHARS * MY_CHARS_IN_PART
  sde(2).x = sde(2).x + 1: sde(2).Y = sde(2).x + 1
  sde(3).x = sde(2).Y + 1: sde(3).Y = sde(3).x + 1
  'współrzędne znaków Stop
  sde(4).x = sde(3).Y + MY_WIDTH_CHARS * MY_CHARS_IN_PART
  sde(4).x = sde(4).x + 1: sde(4).Y = sde(4).x + 1
  sde(5).x = sde(4).Y + 1: sde(5).Y = sde(5).x + 1
  
  'TEXT - cyfry lewej części kodu
  rct.Top = lEanH - lFontH - MY_MARG_BOTTOM * lMyModW '- lExtraEanH
  rct.Bottom = rct.Top + lFontH
  
  For i = 0 To MY_CHARS_IN_PART - 1
  rct.Left = (sde(1).Y + i * MY_WIDTH_CHARS) * lMyModW + lMyModW
  rct.Right = rct.Left + MY_WIDTH_CHARS * lMyModW + lMyModW
  sText = CStr(aCodeNo(i))
  DrawText lHDC, sText, Len(sText), rct, DT_CENTER
  Next
  
  'TEXT - cyfry prawej części kodu
  For i = 0 To MY_CHARS_IN_PART - 1
  rct.Left = (sde(3).Y + i * MY_WIDTH_CHARS) * lMyModW + lMyModW
  rct.Right = rct.Left + MY_WIDTH_CHARS * lMyModW + lMyModW
  sText = CStr(aCodeNo(i + MY_CHARS_IN_PART))
  DrawText lHDC, sText, Len(sText), rct, DT_CENTER
  Next
  
  'KOD - znaki Startu, Separacji i Stopu
  rct.Top = MY_MARG_TOP * lMyModW
  rct.Bottom = rct.Top + lMyLineH + MY_EXTRALENGTH * lMyModW
  
  For i = 0 To 5
  rct.Left = sde(i).x * lMyModW
  rct.Right = sde(i).Y * lMyModW
  FillRect lHDC, rct, hLineBrush
  Next
  
  'KOD - lewa część kodu
  rct.Bottom = rct.Top + lMyLineH
  
  For i = 0 To MY_CHARS_IN_PART - 1
  rct.Left = (sde(1).Y + i * MY_WIDTH_CHARS + EanA(aCodeNo(i)).L1) * lMyModW
  rct.Right = rct.Left + (EanA(aCodeNo(i)).W1) * lMyModW
  FillRect lHDC, rct, hLineBrush
  
  rct.Left = (sde(1).Y + i * MY_WIDTH_CHARS + EanA(aCodeNo(i)).L2) * lMyModW
  rct.Right = rct.Left + EanA(aCodeNo(i)).W2 * lMyModW
  FillRect lHDC, rct, hLineBrush
  Next
  
  'KOD - prawa część kodu
  For i = 0 To MY_CHARS_IN_PART - 1
  bNumer = aCodeNo(i + MY_CHARS_IN_PART)
  rct.Left = (sde(3).Y + 1 + i * MY_WIDTH_CHARS) * lMyModW
  rct.Right = rct.Left + EanC(bNumer).W1 * lMyModW
  FillRect lHDC, rct, hLineBrush
  
  rct.Left = rct.Left + EanC(bNumer).L2 * lMyModW
  rct.Right = rct.Left + EanC(bNumer).W2 * lMyModW
  FillRect lHDC, rct, hLineBrush
  Next
  
  End Sub
  'sprawdza liczbę kontrolną dla potrzeb klasy - pobiera tekst
  'przy powodzeniu zwraca liczbę kontrolną i ustawia tablicę aCodeNo()
  'przy niepowodzeniu zwraca -1, tablica aCodeNo() jest zerowana
  Private Function zbCheckDigitExamine(sCode As String, _
  Optional fRaiseErr As Boolean = True) As Long
  Dim lChkDig As Long
  Dim fOddEv As Boolean
  Dim i As Integer
  
  Erase aCodeNo()
  
  If Len(sCode) <> MY_CHARS_IN_CODE Then
  zbCheckDigitExamine = -1
  If fRaiseErr = True Then zbRaiseErrCls ERR_FAIL_LEN_CODE
  End If
  
  If IsNumeric(sCode) = False Then
  zbCheckDigitExamine = -1
  If fRaiseErr = True Then zbRaiseErrCls ERR_NO_NUMERIC
  End If
  
  CopyMemory aCodeNo(0), ByVal sCode, MY_CHARS_IN_CODE
  
  fOddEv = True
  For i = 0 To MY_CHARS_IN_CODE - 2
  aCodeNo(i) = Chr$(aCodeNo(i))
  
  If fOddEv = True Then
  lChkDig = lChkDig + 3 * aCodeNo(i)
  Else
  lChkDig = lChkDig + aCodeNo(i)
  End If
  fOddEv = Not fOddEv
  Next
  
  'konwertuj ostatni znak
  aCodeNo(MY_CHARS_IN_CODE - 1) = Chr$(aCodeNo(MY_CHARS_IN_CODE - 1))
  
  lChkDig = lChkDig Mod 10
  If lChkDig > 0 Then lChkDig = 10 - lChkDig
  
  If lChkDig = aCodeNo(MY_CHARS_IN_CODE - 1) Then
  zbCheckDigitExamine = aCodeNo(MY_CHARS_IN_CODE - 1)
  Else
  zbCheckDigitExamine = -1
  If fRaiseErr = True Then zbRaiseErrCls ERR_FAIL_CHECK_DIGIT
  End If
  
  End Function
  'tworzy nowy font przy zmianie skali odwzorowania
  Private Sub zbCreateFont()
  Dim fnWH As POINTAPI
  Dim f As Boolean
  
  With lgf
  .lfHeight = MY_DEF_FONT_SIZE * lMyModW * -lDpiY / 72
  .lfWidth = 0
  .lfEscapement = 0
  .lfOrientation = 0
  .lfWeight = FW_NORMAL
  .lfItalic = False
  .lfUnderline = False
  .lfStrikeOut = False
  .lfCharSet = EASTEUROPE_CHARSET
  .lfOutPrecision = OUT_DEFAULT_PRECIS
  .lfClipPrecision = CLIP_DEFAULT_PRECIS
  .lfQuality = DEFAULT_QUALITY
  .lfPitchAndFamily = DEFAULT_PITCH
  .lfFaceName = MY_DEF_FONT_NAME & vbNullChar
  End With
  
  If hOldFont <> 0 Then
  SelectObject lHDC, hOldFont
  DeleteObject hFont
  End If
  
  Do
  hFont = CreateFontIndirect(lgf)
  hOldFont = SelectObject(lHDC, hFont)
  
  GetTextExtentPoint32 lHDC, "8", 1&, fnWH
  
  If (fnWH.x + 1 * lMyModW) <= MY_WIDTH_CHARS * lMyModW Then
  f = True
  lFontH = fnWH.Y
  Else
  SelectObject lHDC, hOldFont
  DeleteObject hFont
  lgf.lfHeight = lgf.lfHeight + 1
  End If
  Loop While f = False
  
  End Sub
  Private Sub zbBmpRotate(aPData() As Byte)
  Dim bmih As BITMAPINFOHEADER 'nagłówek bitmapy
  Dim aTmp() As Byte 'robocza tablica bajtów PictureData
  Dim aLine() As Byte 'tablica bajtów jednej linii bitmapy
  Dim lLenLine As Long 'aktualna ilość bajtów linii bitmapy
  Dim lOrigLenLine As Long 'oryginalna ilość bajtów linii bitmapy
  Dim lOrig_X As Long, lOrig_Y As Long 'oryginalna szerokość/wysokość bitmapy
  Dim lNew_X As Long, lNew_Y As Long 'aktualna szerokość/wysokość bitmapy
  Dim i As Long, j As Long, k As Long 'liczniki
  Dim lMaxY As Long, lMaxX As Long 'wartość obliczeniowa
  Dim lTmp1 As Long, lTmp2 As Long 'wartość obliczeniowa
  Dim lByte_X As Long 'wartość obliczeniowa
  
  CopyMemory bmih, aPData(0), MY_BMIH_SIZE
  
  lOrig_X = bmih.biWidth
  lOrig_Y = bmih.biHeight
  
  'bez obrotu
  If lMyEanAngle = 0 Then
  With ctlMyImg
  .PictureData = aPData()
  If fMyResize = True Then
  .Width = snPixToTwipsX * lOrig_X
  .Height = snPixToTwipsY * lOrig_Y
  End If
  End With
  Exit Sub
  End If
  
  'te same wymiary bitmapy
  If lMyEanAngle = 180 Then
  lNew_X = lOrig_X
  lNew_Y = lOrig_Y
  Else
  lNew_X = lOrig_Y
  lNew_Y = lOrig_X
  'zmiana orientacji, zapamiętaj oryginalną długość linii
  lOrigLenLine = ((lOrig_X * 3 + 3) \ 4) * 4 '-----------------------------------------------------------------
  End If
  
  lMaxY = lOrig_Y - 1
  lMaxX = 3 * lNew_X - 3
  
  lLenLine = ((lNew_X * 3 + 3) \ 4) * 4 '----------------------------------------------------------------------------
  
  'Utwórz nagłówek BitmapInfoHeader
  With bmih
  .biSize = MY_BMIH_SIZE
  .biWidth = lNew_X
  .biHeight = lNew_Y
  .biPlanes = 1
  .biBitCount = 24
  .biCompression = 0
  .biSizeImage = lNew_Y * lLenLine
  .biXPelsPerMeter = 0
  .biYPelsPerMeter = 0
  .biClrUsed = 0
  .biClrImportant = 0
  End With
  Erase aTmp
  
  ReDim aTmp(0 To MY_BMIH_SIZE + bmih.biSizeImage - 1)
  CopyMemory aTmp(0), bmih, MY_BMIH_SIZE
  
  
  lByte_X = 3 * lOrig_X
  'zainicjuj tablicę bajtów jednej linii
  ReDim aLine(0 To lByte_X - 1)
  
  Select Case lMyEanAngle
  Case 180
  For j = 0 To lMaxY
  CopyMemory aLine(0), aPData(MY_BMIH_SIZE + j * lLenLine), lByte_X
  lTmp1 = MY_BMIH_SIZE + (lMaxY - j) * lLenLine
  For i = 0 To lMaxX Step 3
  aTmp(lTmp1 + i + 0) = aLine(lMaxX - i + 0)
  aTmp(lTmp1 + i + 1) = aLine(lMaxX - i + 1)
  aTmp(lTmp1 + i + 2) = aLine(lMaxX - i + 2)
  Next
  Next
  Case 90
  lTmp2 = lByte_X - 3
  
  For j = 0 To lMaxY
  CopyMemory aLine(0), aPData(MY_BMIH_SIZE + j * lOrigLenLine), lByte_X
  lTmp1 = MY_BMIH_SIZE + j * 3
  For i = 0 To lByte_X - 3 Step 3
  '===================== obrót o 90 stopni =============
  aTmp(k * lLenLine + 0 + lTmp1) = aLine(lTmp2 - i + 0)
  aTmp(k * lLenLine + 1 + lTmp1) = aLine(lTmp2 - i + 1)
  aTmp(k * lLenLine + 2 + lTmp1) = aLine(lTmp2 - i + 2)
  '=====================================================
  'obrót o 90 stopni i Flip Vertical
  'aTmp(MY_BMIH_SIZE + (k) * lLenLine + 0 + j * 3) = aLine(i + 0)
  'aTmp(MY_BMIH_SIZE + (k) * lLenLine + 1 + j * 3) = aLine(i + 1)
  'aTmp(MY_BMIH_SIZE + (k) * lLenLine + 2 + j * 3) = aLine(i + 2)
  k = k + 1
  Next
  k = 0
  Next
  Case 270
  For j = 0 To lMaxY
  CopyMemory aLine(0), aPData(MY_BMIH_SIZE + j * lOrigLenLine), lByte_X
  lTmp1 = MY_BMIH_SIZE + (lMaxY - j) * 3
  For i = 0 To lByte_X - 3 Step 3
  '================= obrót o 270 stopni =================
  aTmp(k * lLenLine + 0 + lTmp1) = aLine(i + 0)
  aTmp(k * lLenLine + 1 + lTmp1) = aLine(i + 1)
  aTmp(k * lLenLine + 2 + lTmp1) = aLine(i + 2)
  '=======================================================
  '======== obrót o 90 stopni i Flip Horizontal ========
  'aTmp(MY_BMIH_SIZE + (k) * lLenLine + 0 + j * 3) = aLine(i + 0)
  'aTmp(MY_BMIH_SIZE + (k) * lLenLine + 1 + j * 3) = aLine(i + 1)
  'aTmp(MY_BMIH_SIZE + (k) * lLenLine + 2 + j * 3) = aLine(i + 2)
  k = k + 1
  Next
  k = 0
  Next
  Case Else
  ctlMyImg.Picture = ""
  Exit Sub
  End Select
  
  With ctlMyImg
  .PictureData = aTmp()
  'przeskaluj formant Image
  If fMyResize = True Then
  .Width = snPixToTwipsX * lNew_X
  .Height = snPixToTwipsY * lNew_Y
  End If
  End With
  
  End Sub
  Private Sub zbRaiseErrCls(lMyErr As Long, Optional sInfo As String = "", _
  Optional fRaise As Boolean = True)
  Dim sDescr As String
  Dim sSource As String
  
  Select Case lMyErr
  Case ERR_FAIL_CHECK_DIGIT
  sDescr = "Nieprawidłowa liczba kontrolna kodu EAN !"
  Case ERR_FAIL_SCALE_MODE
  sDescr = "Największa dopuszczalna wartośc współczynnika" & vbNewLine & _
  "skalowania kodu EAN nie może być większa niż 3 !"
  Case ERR_NO_NUMERIC
  sDescr = "Nieprawidłowy kod EAN " & vbNewLine & _
  "Oczekiwano wartości numerycznej."
  Case ERR_FAIL_LEN_CODE
  sDescr = "Nieprawidłowa długość kodu EAN !"
  Case Else
  sDescr = "Nieprzewidziany błąd." & vbNewLine & _
  " Proszę zanotować nr błędu i okoliczności jego wystąpienia" & vbNewLine & _
  "i skontaktować się z Administratorem Bazy !"
  End Select
  
  If Len(sInfo) > 0 Then sDescr = sDescr & vbNewLine & sInfo
  'wygeneruj błąd
  Err.Raise lMyErr, "", sDescr
  
  End Sub

• 
  Wpis na grupie ACCESS w praktyce w temacie Kod EAN - generowanie

  25.04.2017, 14:16

  Witam, kodu do generowania kodu kreskowego w Access.
  Kod działa idealnie, ale przy Accessie 64-bitowym wywala błąd w momencie wykonywania linii:
  CopyMemory aPictData(MY_BMIH_SIZE), ByVal lpByteImg, bmih.biSizeImage
  
  Co mogę zrobić, aby kod zaczął działać?
  Poniżej zamieszczam cały kod.
  
  Option Compare Database
  Option Explicit
  '|===============================================================================|
  '| 3.1 Kod kreskowy EAN -8 |
  '| *********************************** |
  '| Pobrano z : |
  '| http://www.bratki.w.v1.pl/accesspseudofaq/32a_ImgCodaF... |
  '|_______________________________________________________________________________|
  '| Kod możesz dowolnie modyfikować, ale proszę nie usuwać tej ramki |
  '| • autor: Zbigniew Bratko • 07.01.2005 r. • status: FREE |
  '|===============================================================================|
  
  Private Const ERR_FAIL_CHECK_DIGIT As Long = vbObjectError + 1000 + 2
  Private Const ERR_FAIL_SCALE_MODE As Long = vbObjectError + 1000 + 3
  Private Const ERR_NO_NUMERIC As Long = vbObjectError + 1000 + 4
  Private Const ERR_FAIL_LEN_CODE As Long = vbObjectError + 1000 + 5
  
  Private ctlMyImg As Access.Image
  Private lMyModW As Long 'szerokość modułu (linii) w pikselach => 2^lScale
  Private lMyLineH As Long 'względna wysokość właściwej kreski kodu
  
  Private lHDC As Long 'uchwyt kontekstu urządzenia
  Private lDpiX As Long 'rozdzielczość pozioma X
  Private lDpiY As Long 'rozdzielczość pionowa Y
  Private snPixToTwipsX As Single 'przelicznik Pikseli na Twipsy - poziomo
  Private snPixToTwipsY As Single 'przelicznik Pikseli na Twipsy - pionowo
  Private lEanH As Long 'przewidywana wysokość bitmapy EAN
  Private lExtraEanH As Long 'dodatkowa ilość linii wydłużająca dolny margines
  '===============================================================================================
  
  Private Const MY_CHARS_IN_PART As Long = 4 'ilość cyfr w częściach kodu EAN 8
  Private Const MY_CHARS_IN_CODE As Long = 8 'ilość cyfr kodu - EAN 8
  
  Private Type ENCODINGPART
  L1 As Long
  W1 As Long
  L2 As Long
  W2 As Long
  End Type
  
  Private EanA(0 To 9) As ENCODINGPART 'kodowanie kresek zbioru A
  Private EanC(0 To 9) As ENCODINGPART 'kodowanie kresek zbioru C
  Private aCodeNo(MY_CHARS_IN_CODE - 1) As Byte 'wszystkie cyfry kodu kreskowego
  Private lMyEanAngle As Long 'kąt obrotu kodu EAN; 0, 90, 180, 270 stopni
  Private fMyResize As Boolean 'czy dopasować rozmiar ctlMyImg do bitmapy kodu EAN
  
  'Uchwyty, pędzle, pióra, kolory, font
  Private hBkgBrush As Long
  Private hLineBrush As Long
  Private hPen As Long
  Private hFont As Long
  Private hOldBrush As Long
  Private hOldPen As Long
  Private hOldFont As Long
  
  Private lMyBkgCol As Long
  Private lMyLineCol As Long
  Private lMyFontCol As Long
  Private lOldFontCol As Long
  Private lOldBkgMode As Long
  
  Private Const MY_BKG_COL As Long = vbWhite
  Private Const MY_LINE_COL As Long = vbBlack
  Private Const MY_FONT_COL As Long = vbBlack
  Private Const MY_PEN_COL As Long = vbBlack
  Private Const MY_DEF_FONT_NAME As String = "Arial"
  Private Const MY_DEF_FONT_SIZE As Long = 8
  
  Private lFontH As Long
  Private lgf As LOGFONT
  '=======================================================================================
  'rozmiary i położenie elementów kodu EAN
  Private Const MY_MARG_LEFT As Long = 11 'margines lewy = 11 modułów
  Private Const MY_MARG_RIGHT As Long = 7 'margines prawy = 7 modułów
  Private Const MY_MARG_TOP As Long = 2 'margines górny = 2 moduły
  Private Const MY_MARG_BOTTOM As Long = 2 'margines dolny = 2 moduły
  
  Private Const MY_WIDTH_CHARS As Long = 7 'ilość modułów na znak
  Private Const MY_WIDTH_START As Long = 3 'ilość modułów na znak Start
  Private Const MY_WIDTH_SEP As Long = 5 'ilość modułów na znak Separacji
  Private Const MY_WIDTH_END As Long = 3 'ilość modułów na znak Stop
  Private Const MY_EXTRALENGTH As Long = 5 'ilość modułów wydłużająca w/w znaki
  Private Const MY_HEIGHT_LINE_MM As Long = 6 'wysokość właściwej kreski kodu w mm
  'bitmapa
  Private Const MY_BMIH_SIZE As Long = 40 'wielkośc nagłówka BitmapInfoHeader
  Private Const MY_MIN_SIZE_BMP As Long = 10240 'minimalna wielkość bitmapy, przy mniejszych
  'wielkościach czasami bitmapa jest niestabilna
  
  Private Sub Class_Initialize()
  Dim hdcAcc As Long
  
  hdcAcc = GetDC(Application.hWndAccessApp)
  lHDC = CreateCompatibleDC(hdcAcc)
  Call ReleaseDC(Application.hWndAccessApp, hdcAcc)
  
  lDpiX = GetDeviceCaps(lHDC, LOGPIXELSX)
  lDpiY = GetDeviceCaps(lHDC, LOGPIXELSY)
  snPixToTwipsX = 1440 / lDpiX
  snPixToTwipsY = 1440 / lDpiY
  
  EanScale = 0 '=> tworzy odpowiedniej wielkości FONT
  fMyResize = True
  EanHeightLineMm = MY_HEIGHT_LINE_MM
  
  EanA(0).L1 = 3: EanA(0).W1 = 2: EanA(0).L2 = 6: EanA(0).W2 = 1
  EanA(1).L1 = 2: EanA(1).W1 = 2: EanA(1).L2 = 6: EanA(1).W2 = 1
  EanA(2).L1 = 2: EanA(2).W1 = 1: EanA(2).L2 = 5: EanA(2).W2 = 2
  EanA(3).L1 = 1: EanA(3).W1 = 4: EanA(3).L2 = 6: EanA(3).W2 = 1
  EanA(4).L1 = 1: EanA(4).W1 = 1: EanA(4).L2 = 5: EanA(4).W2 = 2
  EanA(5).L1 = 1: EanA(5).W1 = 2: EanA(5).L2 = 6: EanA(5).W2 = 1
  EanA(6).L1 = 1: EanA(6).W1 = 1: EanA(6).L2 = 3: EanA(6).W2 = 4
  EanA(7).L1 = 1: EanA(7).W1 = 3: EanA(7).L2 = 5: EanA(7).W2 = 2
  EanA(8).L1 = 1: EanA(8).W1 = 2: EanA(8).L2 = 4: EanA(8).W2 = 3
  EanA(9).L1 = 3: EanA(9).W1 = 1: EanA(9).L2 = 5: EanA(9).W2 = 2
  
  EanC(0).L1 = 0: EanC(0).W1 = 3: EanC(0).L2 = 5: EanC(0).W2 = 1
  EanC(1).L1 = 0: EanC(1).W1 = 2: EanC(1).L2 = 4: EanC(1).W2 = 2
  EanC(2).L1 = 0: EanC(2).W1 = 2: EanC(2).L2 = 3: EanC(2).W2 = 2
  EanC(3).L1 = 0: EanC(3).W1 = 1: EanC(3).L2 = 5: EanC(3).W2 = 1
  EanC(4).L1 = 0: EanC(4).W1 = 1: EanC(4).L2 = 2: EanC(4).W2 = 3
  EanC(5).L1 = 0: EanC(5).W1 = 1: EanC(5).L2 = 3: EanC(5).W2 = 3
  EanC(6).L1 = 0: EanC(6).W1 = 1: EanC(6).L2 = 2: EanC(6).W2 = 1
  EanC(7).L1 = 0: EanC(7).W1 = 1: EanC(7).L2 = 4: EanC(7).W2 = 1
  EanC(8).L1 = 0: EanC(8).W1 = 1: EanC(8).L2 = 3: EanC(8).W2 = 1
  EanC(9).L1 = 0: EanC(9).W1 = 3: EanC(9).L2 = 4: EanC(9).W2 = 1
  
  hPen = CreatePen(PS_SOLID, 1, MY_PEN_COL)
  hOldPen = SelectObject(lHDC, hPen)
  
  lMyBkgCol = MY_BKG_COL
  hBkgBrush = CreateSolidBrush(MY_BKG_COL)
  hOldBrush = SelectObject(lHDC, hBkgBrush)
  
  lMyLineCol = MY_LINE_COL
  hLineBrush = CreateSolidBrush(MY_LINE_COL)
  
  lOldFontCol = SetTextColor(lHDC, vbBlue)
  lOldBkgMode = SetBkMode(lHDC, TRANSPARENT)
  
  End Sub
  Private Sub Class_Terminate()
  
  Set ctlMyImg = Nothing
  
  'przywróć stare pióro
  Call SelectObject(lHDC, hOldPen)
  'zniszcz używane pióro
  Call DeleteObject(hPen)
  'wybierz stary pędzel
  Call SelectObject(lHDC, hOldBrush)
  'usuń nieużywane pędzle
  Call DeleteObject(hBkgBrush)
  Call DeleteObject(hLineBrush)
  'przywróć kolor tekstu i styl tła
  Call SetTextColor(lHDC, lOldFontCol)
  Call SetBkMode(lHDC, lOldBkgMode)
  'przywróć stary font
  Call SelectObject(lHDC, hOldFont)
  'zniszcz używany font
  Call DeleteObject(hFont)
  'usuń kontekst urządzenia
  Call DeleteDC(lHDC)
  
  End Sub
  'kolor tła bitmapy
  Public Property Let EanColorBkg(lBkgCol As Long)
  lMyBkgCol = lBkgCol
  
  SelectObject lHDC, hOldBrush
  DeleteObject hBkgBrush
  hBkgBrush = CreateSolidBrush(lMyBkgCol)
  'SelectObject lHDC, hBkgBrush
  
  End Property
  Public Property Get EanColorBkg() As Long
  EanColorBkg = lMyBkgCol
  End Property
  'kolor linii kodu
  Public Property Let EanColorLine(lLineCol As Long)
  lMyLineCol = lLineCol
  
  SelectObject lHDC, hOldBrush
  DeleteObject hLineBrush
  hLineBrush = CreateSolidBrush(lMyLineCol)
  'SelectObject lHDC, hLineBrush
  
  End Property
  Public Property Get EanColorLine() As Long
  EanColorLine = lMyLineCol
  End Property
  'kolor czcionki
  Public Property Let EanColorFont(lCol As Long)
  lMyFontCol = lCol
  SetTextColor lHDC, lCol
  End Property
  Public Property Get EanColorFont() As Long
  EanColorFont = lMyFontCol
  End Property
  'kąt obrotu kodu EAN; 0, 90, 180, 270 stopni
  Public Property Let EanAngle(lAng As Integer)
  Dim lAngle As Integer
  lAngle = lAng - (lAng \ 360) * 360
  
  If lAngle < 0 Then lAngle = lAngle + 359
  lAngle = (((Abs(lAngle)) + 45) \ 90) * 90
  If lAngle >= 360 Then lAngle = 0
  lMyEanAngle = lAngle
  
  End Property
  Public Property Get EanAngle() As Integer
  EanAngle = lMyEanAngle
  End Property
  'współczynnik skalowania bitmapy
  'szerokość modułu (linii) w pikselach => 2^lScale
  'zmiana współczynnika wymusza utworzenie nowego fontu
  Public Property Let EanScale(ByVal lScale As Long)
  
  If lScale > 3 Then
  zbRaiseErrCls ERR_FAIL_SCALE_MODE
  End If
  
  If lMyModW <> 2 ^ lScale Then
  lMyModW = 2 ^ lScale
  If lMyModW <= 0 Then lMyModW = 1
  Call zbCreateFont
  End If
  
  End Property
  'przelicza wysokość właściwych linii kodu z milimetrów na piksele
  'z uwzględnieniem współczynnika skalowania
  Public Property Let EanHeightLineMm(lHeight As Long)
  lMyLineH = (lHeight) * lDpiY / 25.4
  If lMyLineH <= 0 Then lMyLineH = 1 * lDpiY / 25.4
  lMyLineH = lMyLineH * lMyModW
  End Property
  'formant Image wyświetlający kod EAN-8
  Public Sub zbSetImgEan8(ctlImg As Access.Image)
  Set ctlMyImg = ctlImg
  End Sub
  'czy dopasować rozmiar ctlMyImg do bitmapy kodu
  Public Property Let EanResizeImg(fResize As Boolean)
  fMyResize = fResize
  End Property
  'funkcja wywołująca tworzenie kodu EAN-8, zwraca liczbę kontrolną lub ""
  Public Function DrawCodeBarEan8(sCode As String) As String
  Dim lChkDig As Long
  
  lChkDig = zbCheckDigitExamine(sCode)
  If lChkDig > -1 Then
  DrawCodeBarEan8 = lChkDig
  Call zbBmpCreate
  Else
  DrawCodeBarEan8 = ""
  End If
  
  End Function
  'zwraca liczbę kontrolną dla potrzeb formularza (OnChange)- lokalnie używa aNo()
  'TUTAJ NIE JEST STOSOWANA - wewnątrz klasy stosowana jest zbCheckDigitExamine
  Public Function zbCheckDigitCalculateEAN(sCode As String) As String
  Dim aNo(0 To MY_CHARS_IN_CODE - 2) As Byte
  Dim lChkDig As Long
  Dim fOddEv As Boolean
  Dim i As Integer
  
  'sprawdź poprawność stringu wejściowego
  If Len(sCode) <> MY_CHARS_IN_CODE - 1 Or IsNumeric(sCode) = False Then
  If IsNull(ctlMyImg.PictureData) = False Then ctlMyImg.Picture = ""
  zbCheckDigitCalculateEAN = ""
  Exit Function
  End If
  
  CopyMemory aNo(0), ByVal sCode, MY_CHARS_IN_CODE - 1
  
  fOddEv = True
  For i = 0 To MY_CHARS_IN_CODE - 2
  aNo(i) = Chr$(aNo(i))
  
  If fOddEv = True Then
  lChkDig = lChkDig + 3 * aNo(i)
  Else
  lChkDig = lChkDig + aNo(i)
  End If
  fOddEv = Not fOddEv
  Next
  
  lChkDig = lChkDig Mod 10
  If lChkDig > 0 Then lChkDig = 10 - lChkDig
  
  zbCheckDigitCalculateEAN = lChkDig
  
  End Function
  'tworzy bitmapę, przemalowuje ją kolorem tła i wywołuje funkcję:
  'rysująca kod i obracającą bitmapę kodu kreskowego
  Private Sub zbBmpCreate()
  
  Dim bmih As BITMAPINFOHEADER
  Dim aPictData() As Byte 'bajty bitmapy - odpowiednik img.PictureData
  Dim lBmpWidth As Long 'całkowita szerkośc bitmapy
  Dim lpByteImg As Long 'wskaźnik do bajtów obrazu
  Dim lLenLine As Long 'ilość bajtów linii bitmapy
  Dim hBmp As Long 'uchwyt Bmp
  Dim hMyOldBitmap As Long ' ""
  
  'szerokość bitmapy - orientacja pozioma
  lBmpWidth = (MY_MARG_LEFT + _
  MY_WIDTH_START + MY_CHARS_IN_PART * MY_WIDTH_CHARS + _
  MY_WIDTH_SEP + _
  MY_CHARS_IN_PART * MY_WIDTH_CHARS + MY_WIDTH_END + _
  MY_MARG_RIGHT) * lMyModW
  
  'szerokość linii w bajtach
  lLenLine = ((lBmpWidth * 3 + 3) \ 4) * 4
  'przewidywana wysokość bitmapy
  lEanH = (MY_MARG_TOP + MY_MARG_BOTTOM) * lMyModW + lFontH + lMyLineH
  
  'zwiększaj margines dolny, aż do przekroczenia granicy MY_MIN_SIZE_BMP
  'zbyt małe bitmapy nie zawsze są właściwie odmalowywane.
  'Access Bug ???
  lExtraEanH = 0
  Do While (lEanH + lExtraEanH) * lLenLine < MY_MIN_SIZE_BMP
  lExtraEanH = lExtraEanH + 1
  Loop
  
  'Utwórz nagłówek BitmapInfoHeader
  With bmih
  .biSize = MY_BMIH_SIZE
  .biWidth = lBmpWidth
  .biHeight = lEanH + lExtraEanH
  .biPlanes = 1
  .biBitCount = 24
  .biCompression = 0
  .biSizeImage = ((.biHeight * lLenLine))
  .biXPelsPerMeter = 0
  .biYPelsPerMeter = 0
  .biClrUsed = 0
  .biClrImportant = 0
  End With
  
  'utwórz bitmapę
  hBmp = CreateDIBSection(lHDC, bmih, DIB_RGB_COLORS, lpByteImg, 0&, 0&)
  hMyOldBitmap = SelectObject(lHDC, hBmp)
  
  ReDim aPictData(0 To MY_BMIH_SIZE + bmih.biSizeImage - 1)
  'kopiuj nagłówek bitmapy do tablicy
  CopyMemory aPictData(0), bmih, MY_BMIH_SIZE
  
  'przemaluj bitmapę
  SelectObject lHDC, hBkgBrush
  Call ExtFloodFill(lHDC, 0, 0, lMyBkgCol, FLOODFILLBORDER)
  
  Call zbBmpPaint
  
  CopyMemory aPictData(MY_BMIH_SIZE), ByVal lpByteImg, bmih.biSizeImage
  
  SelectObject lHDC, hMyOldBitmap
  DeleteObject hBmp
  'DeleteDC lHDC
  
  Call zbBmpRotate(aPictData())
  
  End Sub
  Private Sub zbBmpPaint()
  Dim rct As RECT
  Dim sde(0 To 5) As POINTAPI 'wspólrzędne znaków: Start, Sep, Stop
  Dim i As Byte
  Dim sText As String
  Dim papi As POINTAPI
  Dim bNumer As Byte
  
  'współrzędne znaków Start
  sde(0).x = MY_MARG_LEFT: sde(0).Y = sde(0).x + 1
  sde(1).x = sde(0).Y + 1: sde(1).Y = sde(1).x + 1
  'współrzędne znaków Separatora
  sde(2).x = sde(1).Y + MY_WIDTH_CHARS * MY_CHARS_IN_PART
  sde(2).x = sde(2).x + 1: sde(2).Y = sde(2).x + 1
  sde(3).x = sde(2).Y + 1: sde(3).Y = sde(3).x + 1
  'współrzędne znaków Stop
  sde(4).x = sde(3).Y + MY_WIDTH_CHARS * MY_CHARS_IN_PART
  sde(4).x = sde(4).x + 1: sde(4).Y = sde(4).x + 1
  sde(5).x = sde(4).Y + 1: sde(5).Y = sde(5).x + 1
  
  'TEXT - cyfry lewej części kodu
  rct.Top = lEanH - lFontH - MY_MARG_BOTTOM * lMyModW '- lExtraEanH
  rct.Bottom = rct.Top + lFontH
  
  For i = 0 To MY_CHARS_IN_PART - 1
  rct.Left = (sde(1).Y + i * MY_WIDTH_CHARS) * lMyModW + lMyModW
  rct.Right = rct.Left + MY_WIDTH_CHARS * lMyModW + lMyModW
  sText = CStr(aCodeNo(i))
  DrawText lHDC, sText, Len(sText), rct, DT_CENTER
  Next
  
  'TEXT - cyfry prawej części kodu
  For i = 0 To MY_CHARS_IN_PART - 1
  rct.Left = (sde(3).Y + i * MY_WIDTH_CHARS) * lMyModW + lMyModW
  rct.Right = rct.Left + MY_WIDTH_CHARS * lMyModW + lMyModW
  sText = CStr(aCodeNo(i + MY_CHARS_IN_PART))
  DrawText lHDC, sText, Len(sText), rct, DT_CENTER
  Next
  
  'KOD - znaki Startu, Separacji i Stopu
  rct.Top = MY_MARG_TOP * lMyModW
  rct.Bottom = rct.Top + lMyLineH + MY_EXTRALENGTH * lMyModW
  
  For i = 0 To 5
  rct.Left = sde(i).x * lMyModW
  rct.Right = sde(i).Y * lMyModW
  FillRect lHDC, rct, hLineBrush
  Next
  
  'KOD - lewa część kodu
  rct.Bottom = rct.Top + lMyLineH
  
  For i = 0 To MY_CHARS_IN_PART - 1
  rct.Left = (sde(1).Y + i * MY_WIDTH_CHARS + EanA(aCodeNo(i)).L1) * lMyModW
  rct.Right = rct.Left + (EanA(aCodeNo(i)).W1) * lMyModW
  FillRect lHDC, rct, hLineBrush
  
  rct.Left = (sde(1).Y + i * MY_WIDTH_CHARS + EanA(aCodeNo(i)).L2) * lMyModW
  rct.Right = rct.Left + EanA(aCodeNo(i)).W2 * lMyModW
  FillRect lHDC, rct, hLineBrush
  Next
  
  'KOD - prawa część kodu
  For i = 0 To MY_CHARS_IN_PART - 1
  bNumer = aCodeNo(i + MY_CHARS_IN_PART)
  rct.Left = (sde(3).Y + 1 + i * MY_WIDTH_CHARS) * lMyModW
  rct.Right = rct.Left + EanC(bNumer).W1 * lMyModW
  FillRect lHDC, rct, hLineBrush
  
  rct.Left = rct.Left + EanC(bNumer).L2 * lMyModW
  rct.Right = rct.Left + EanC(bNumer).W2 * lMyModW
  FillRect lHDC, rct, hLineBrush
  Next
  
  End Sub
  'sprawdza liczbę kontrolną dla potrzeb klasy - pobiera tekst
  'przy powodzeniu zwraca liczbę kontrolną i ustawia tablicę aCodeNo()
  'przy niepowodzeniu zwraca -1, tablica aCodeNo() jest zerowana
  Private Function zbCheckDigitExamine(sCode As String, _
  Optional fRaiseErr As Boolean = True) As Long
  Dim lChkDig As Long
  Dim fOddEv As Boolean
  Dim i As Integer
  
  Erase aCodeNo()
  
  If Len(sCode) <> MY_CHARS_IN_CODE Then
  zbCheckDigitExamine = -1
  If fRaiseErr = True Then zbRaiseErrCls ERR_FAIL_LEN_CODE
  End If
  
  If IsNumeric(sCode) = False Then
  zbCheckDigitExamine = -1
  If fRaiseErr = True Then zbRaiseErrCls ERR_NO_NUMERIC
  End If
  
  CopyMemory aCodeNo(0), ByVal sCode, MY_CHARS_IN_CODE
  
  fOddEv = True
  For i = 0 To MY_CHARS_IN_CODE - 2
  aCodeNo(i) = Chr$(aCodeNo(i))
  
  If fOddEv = True Then
  lChkDig = lChkDig + 3 * aCodeNo(i)
  Else
  lChkDig = lChkDig + aCodeNo(i)
  End If
  fOddEv = Not fOddEv
  Next
  
  'konwertuj ostatni znak
  aCodeNo(MY_CHARS_IN_CODE - 1) = Chr$(aCodeNo(MY_CHARS_IN_CODE - 1))
  
  lChkDig = lChkDig Mod 10
  If lChkDig > 0 Then lChkDig = 10 - lChkDig
  
  If lChkDig = aCodeNo(MY_CHARS_IN_CODE - 1) Then
  zbCheckDigitExamine = aCodeNo(MY_CHARS_IN_CODE - 1)
  Else
  zbCheckDigitExamine = -1
  If fRaiseErr = True Then zbRaiseErrCls ERR_FAIL_CHECK_DIGIT
  End If
  
  End Function
  'tworzy nowy font przy zmianie skali odwzorowania
  Private Sub zbCreateFont()
  Dim fnWH As POINTAPI
  Dim f As Boolean
  
  With lgf
  .lfHeight = MY_DEF_FONT_SIZE * lMyModW * -lDpiY / 72
  .lfWidth = 0
  .lfEscapement = 0
  .lfOrientation = 0
  .lfWeight = FW_NORMAL
  .lfItalic = False
  .lfUnderline = False
  .lfStrikeOut = False
  .lfCharSet = EASTEUROPE_CHARSET
  .lfOutPrecision = OUT_DEFAULT_PRECIS
  .lfClipPrecision = CLIP_DEFAULT_PRECIS
  .lfQuality = DEFAULT_QUALITY
  .lfPitchAndFamily = DEFAULT_PITCH
  .lfFaceName = MY_DEF_FONT_NAME & vbNullChar
  End With
  
  If hOldFont <> 0 Then
  SelectObject lHDC, hOldFont
  DeleteObject hFont
  End If
  
  Do
  hFont = CreateFontIndirect(lgf)
  hOldFont = SelectObject(lHDC, hFont)
  
  GetTextExtentPoint32 lHDC, "8", 1&, fnWH
  
  If (fnWH.x + 1 * lMyModW) <= MY_WIDTH_CHARS * lMyModW Then
  f = True
  lFontH = fnWH.Y
  Else
  SelectObject lHDC, hOldFont
  DeleteObject hFont
  lgf.lfHeight = lgf.lfHeight + 1
  End If
  Loop While f = False
  
  End Sub
  Private Sub zbBmpRotate(aPData() As Byte)
  Dim bmih As BITMAPINFOHEADER 'nagłówek bitmapy
  Dim aTmp() As Byte 'robocza tablica bajtów PictureData
  Dim aLine() As Byte 'tablica bajtów jednej linii bitmapy
  Dim lLenLine As Long 'aktualna ilość bajtów linii bitmapy
  Dim lOrigLenLine As Long 'oryginalna ilość bajtów linii bitmapy
  Dim lOrig_X As Long, lOrig_Y As Long 'oryginalna szerokość/wysokość bitmapy
  Dim lNew_X As Long, lNew_Y As Long 'aktualna szerokość/wysokość bitmapy
  Dim i As Long, j As Long, k As Long 'liczniki
  Dim lMaxY As Long, lMaxX As Long 'wartość obliczeniowa
  Dim lTmp1 As Long, lTmp2 As Long 'wartość obliczeniowa
  Dim lByte_X As Long 'wartość obliczeniowa
  
  CopyMemory bmih, aPData(0), MY_BMIH_SIZE
  
  lOrig_X = bmih.biWidth
  lOrig_Y = bmih.biHeight
  
  'bez obrotu
  If lMyEanAngle = 0 Then
  With ctlMyImg
  .PictureData = aPData()
  If fMyResize = True Then
  .Width = snPixToTwipsX * lOrig_X
  .Height = snPixToTwipsY * lOrig_Y
  End If
  End With
  Exit Sub
  End If
  
  'te same wymiary bitmapy
  If lMyEanAngle = 180 Then
  lNew_X = lOrig_X
  lNew_Y = lOrig_Y
  Else
  lNew_X = lOrig_Y
  lNew_Y = lOrig_X
  'zmiana orientacji, zapamiętaj oryginalną długość linii
  lOrigLenLine = ((lOrig_X * 3 + 3) \ 4) * 4 '-----------------------------------------------------------------
  End If
  
  lMaxY = lOrig_Y - 1
  lMaxX = 3 * lNew_X - 3
  
  lLenLine = ((lNew_X * 3 + 3) \ 4) * 4 '----------------------------------------------------------------------------
  
  'Utwórz nagłówek BitmapInfoHeader
  With bmih
  .biSize = MY_BMIH_SIZE
  .biWidth = lNew_X
  .biHeight = lNew_Y
  .biPlanes = 1
  .biBitCount = 24
  .biCompression = 0
  .biSizeImage = lNew_Y * lLenLine
  .biXPelsPerMeter = 0
  .biYPelsPerMeter = 0
  .biClrUsed = 0
  .biClrImportant = 0
  End With
  Erase aTmp
  
  ReDim aTmp(0 To MY_BMIH_SIZE + bmih.biSizeImage - 1)
  CopyMemory aTmp(0), bmih, MY_BMIH_SIZE
  
  
  lByte_X = 3 * lOrig_X
  'zainicjuj tablicę bajtów jednej linii
  ReDim aLine(0 To lByte_X - 1)
  
  Select Case lMyEanAngle
  Case 180
  For j = 0 To lMaxY
  CopyMemory aLine(0), aPData(MY_BMIH_SIZE + j * lLenLine), lByte_X
  lTmp1 = MY_BMIH_SIZE + (lMaxY - j) * lLenLine
  For i = 0 To lMaxX Step 3
  aTmp(lTmp1 + i + 0) = aLine(lMaxX - i + 0)
  aTmp(lTmp1 + i + 1) = aLine(lMaxX - i + 1)
  aTmp(lTmp1 + i + 2) = aLine(lMaxX - i + 2)
  Next
  Next
  Case 90
  lTmp2 = lByte_X - 3
  
  For j = 0 To lMaxY
  CopyMemory aLine(0), aPData(MY_BMIH_SIZE + j * lOrigLenLine), lByte_X
  lTmp1 = MY_BMIH_SIZE + j * 3
  For i = 0 To lByte_X - 3 Step 3
  '===================== obrót o 90 stopni =============
  aTmp(k * lLenLine + 0 + lTmp1) = aLine(lTmp2 - i + 0)
  aTmp(k * lLenLine + 1 + lTmp1) = aLine(lTmp2 - i + 1)
  aTmp(k * lLenLine + 2 + lTmp1) = aLine(lTmp2 - i + 2)
  '=====================================================
  'obrót o 90 stopni i Flip Vertical
  'aTmp(MY_BMIH_SIZE + (k) * lLenLine + 0 + j * 3) = aLine(i + 0)
  'aTmp(MY_BMIH_SIZE + (k) * lLenLine + 1 + j * 3) = aLine(i + 1)
  'aTmp(MY_BMIH_SIZE + (k) * lLenLine + 2 + j * 3) = aLine(i + 2)
  k = k + 1
  Next
  k = 0
  Next
  Case 270
  For j = 0 To lMaxY
  CopyMemory aLine(0), aPData(MY_BMIH_SIZE + j * lOrigLenLine), lByte_X
  lTmp1 = MY_BMIH_SIZE + (lMaxY - j) * 3
  For i = 0 To lByte_X - 3 Step 3
  '================= obrót o 270 stopni =================
  aTmp(k * lLenLine + 0 + lTmp1) = aLine(i + 0)
  aTmp(k * lLenLine + 1 + lTmp1) = aLine(i + 1)
  aTmp(k * lLenLine + 2 + lTmp1) = aLine(i + 2)
  '=======================================================
  '======== obrót o 90 stopni i Flip Horizontal ========
  'aTmp(MY_BMIH_SIZE + (k) * lLenLine + 0 + j * 3) = aLine(i + 0)
  'aTmp(MY_BMIH_SIZE + (k) * lLenLine + 1 + j * 3) = aLine(i + 1)
  'aTmp(MY_BMIH_SIZE + (k) * lLenLine + 2 + j * 3) = aLine(i + 2)
  k = k + 1
  Next
  k = 0
  Next
  Case Else
  ctlMyImg.Picture = ""
  Exit Sub
  End Select
  
  With ctlMyImg
  .PictureData = aTmp()
  'przeskaluj formant Image
  If fMyResize = True Then
  .Width = snPixToTwipsX * lNew_X
  .Height = snPixToTwipsY * lNew_Y
  End If
  End With
  
  End Sub
  Private Sub zbRaiseErrCls(lMyErr As Long, Optional sInfo As String = "", _
  Optional fRaise As Boolean = True)
  Dim sDescr As String
  Dim sSource As String
  
  Select Case lMyErr
  Case ERR_FAIL_CHECK_DIGIT
  sDescr = "Nieprawidłowa liczba kontrolna kodu EAN !"
  Case ERR_FAIL_SCALE_MODE
  sDescr = "Największa dopuszczalna wartośc współczynnika" & vbNewLine & _
  "skalowania kodu EAN nie może być większa niż 3 !"
  Case ERR_NO_NUMERIC
  sDescr = "Nieprawidłowy kod EAN " & vbNewLine & _
  "Oczekiwano wartości numerycznej."
  Case ERR_FAIL_LEN_CODE
  sDescr = "Nieprawidłowa długość kodu EAN !"
  Case Else
  sDescr = "Nieprzewidziany błąd." & vbNewLine & _
  " Proszę zanotować nr błędu i okoliczności jego wystąpienia" & vbNewLine & _
  "i skontaktować się z Administratorem Bazy !"
  End Select
  
  If Len(sInfo) > 0 Then sDescr = sDescr & vbNewLine & sInfo
  'wygeneruj błąd
  Err.Raise lMyErr, "", sDescr
  
  End Sub

• 
  Wpis na grupie Access VBA w temacie Kod wywala aplikację przy Access 64-bit

  Aby mieć możliwość przeczytania tego posta musisz być członkiem grupy Access VBA