Temat: Kod EAN - generowanie

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