cdib.cls

UPC-EA 类型条形码生成和读取示例

'and return True
CreateFromPackedDIBPointer = True

End Function

Public Function WriteToFile(ByVal filename As String) As Boolean
Dim hFile As Integer
On Error Resume Next
gray
DoEvents
hFile = FreeFile()
Open filename For Binary As hFile
    Put hFile, 1, m_bfh
    Put hFile, Len(m_bfh) + 1, m_memBitmapInfo
    Put hFile, , m_memBits
Close hFile
WriteToFile = True
End Function
Private Function gray()
    Dim i As Long, temp As Long
    For i = 0 To m_bih.biSizeImage - 1 Step 3
        temp = m_memBits(i)
        temp = temp + m_memBits(i + 1)
        temp = temp + m_memBits(i + 2)
        temp = temp \ 3
        m_memBits(i) = temp: m_memBits(i + 1) = temp: m_memBits(i + 2) = temp
    Next
End Function
Public Function allocGray(ByRef tmparry() As Byte, ByVal frame As Long)
' before using this u must first redim the tmparry
' give the current frame number, and total frames

Dim i As Long, temp As Long, j As Long
Dim tmpheight As Long, tmpwidth As Long
Dim y As Long, x As Long

tmpwidth = m_bih.biWidth - 1
tmpheight = m_bih.biHeight - 1

    For i = 0 To m_bih.biSizeImage - 1 Step 3
        temp = m_memBits(i)
        temp = temp + m_memBits(i + 1)
        temp = temp + m_memBits(i + 2)
        temp = temp \ 3
        m_memBits(i) = temp
    Next


  

i = m_bih.biSizeImage - 1
'i = 0
For y = 0 To tmpheight
    For x = 0 To tmpwidth
    
    'tmparry(frame, x, tmpheight - y) = m_memBits(y * (tmpwidth + 1) + (x * 3))
    tmparry(frame, tmpwidth - x, tmpheight - y) = m_memBits(i)
    i = i - 3
    Next
Next

    
End Function
Private Function ExistFile(ByVal sSpec As String) As Boolean
    On Error Resume Next
    Call FileLen(sSpec)
    ExistFile = (Err = 0)
End Function

Public Property Get BitCount() As Long
    BitCount = m_bih.biBitCount

End Property

Public Property Get Height() As Long
    Height = m_bih.biHeight
End Property

Public Property Get Width() As Long
    Width = m_bih.biWidth
End Property

Public Property Get Compression() As Long
    Compression = m_bih.biCompression
End Property

Public Property Get SizeInfoHeader() As Long
    SizeInfoHeader = m_bih.biSize
End Property

Public Property Get SizeImage() As Long
    SizeImage = m_bih.biSizeImage
End Property

Public Property Get Planes() As Long
    Planes = m_bih.biPlanes
End Property

Public Property Get ClrImportant() As Long
    ClrImportant = m_bih.biClrImportant
End Property

Public Property Get ClrUsed() As Long
    ClrUsed = m_bih.biClrUsed
End Property

Public Property Get XPPM() As Long
    XPPM = m_bih.biXPelsPerMeter
End Property

Public Property Get YPPM() As Long
    YPPM = m_bih.biYPelsPerMeter
End Property

Public Property Get FileType() As Long
    FileType = m_bfh.bfType
End Property

Public Property Get SizeFileHeader() As Long
    SizeFileHeader = m_bfh.bfSize
End Property

Public Property Get BitOffset() As Long
    BitOffset = m_bfh.bfOffBits
End Property

Public Property Get PointerToBits() As Long
    PointerToBits = VarPtr(m_memBits(0))
End Property

Public Property Get PointerToBitmapInfo() As Long
    PointerToBitmapInfo = VarPtr(m_memBitmapInfo(0))
End Property

Public Property Get SizeBitmapInfo() As Long
    SizeBitmapInfo = UBound(m_memBitmapInfo()) + 1
End Property

Public Function GetImageDataStream(ByRef SrcPictureBox As PictureBox, ByRef imagedata() As Byte)
'Declare us some variables of the necessary bitmap types
    Dim bm As BITMAP
    Dim bmi As BITMAPINFO
    Dim arrayLen As Long
    'Now we fill up the bmi (Bitmap information variable) with all of the appropriate data
    bmi.bmHeader.biSize = 40 'Size, in bytes, of the header (always 40)
    bmi.bmHeader.biPlanes = 1 'Number of planes (always one for this instance)
    bmi.bmHeader.biBitCount = 24 'Bits per pixel (always 24 for this instance)
    bmi.bmHeader.biCompression = 0 'Compression: standard/none or RLE
    'Calculate the size of the bitmap type (in bytes)
    Dim bmLen As Long
    bmLen = Len(bm)
    'Get the picture box information from SrcPictureBox and put it into our 'bm' variable
    GetObject SrcPictureBox.Image, bmLen, bm
   
    'Build a correctly sized array
    'align the width so it wud be in times four..:)
    '------------------------------------------------
    arrayLen = bm.bmWidth * bm.bmHeight
    arrayLen = arrayLen * 4
   
    ReDim imagedata(0 To arrayLen)
    '------------------------------------------------
    'Finish building the 'bmi' variable we want to pass to the GetDIBits call (the same one we used above)
    bmi.bmHeader.biWidth = bm.bmWidth
    bmi.bmHeader.biHeight = bm.bmHeight
    'Now that we've completely filled up the 'bmi' variable, we use GetDIBits to take the data from
    'SrcPictureBox and put it into the ImageData() array using the settings we specified in 'bmi'
    GetDIBits SrcPictureBox.hdc, SrcPictureBox.Image, 0, bm.bmHeight, imagedata(0), bmi, 0
End Function

Public Function SetImageDataStream(ByRef DstPictureBox As PictureBox, ByRef imagedata() As Byte)
  'Declare us some variables of the necessary bitmap types
    Dim bm As BITMAP
    Dim bmi As BITMAPINFO
    
    'Now we fill up the bmi (Bitmap information variable) with all of the appropriate data
    bmi.bmHeader.biSize = 40  'Size, in bytes, of the header (always 40)
    bmi.bmHeader.biPlanes = 1  'Number of planes (always one for this instance)
    bmi.bmHeader.biBitCount = 24  'Bits per pixel (always 24 for this instance)
    bmi.bmHeader.biCompression = 0  'Compression: standard/none or RLE
    'Calculate the size of the bitmap type (in bytes)
    Dim bmLen As Long
    bmLen = Len(bm)
    'Get the picture box information from DstPictureBox and put it into our 'bm' variable
    GetObject DstPictureBox.Image, bmLen, bm
    'Now that we know the object's size, finish building the temporary header to pass to the StretchDIBits call
    '(continuing to use the 'bmi' we used above)
    bmi.bmHeader.biWidth = bm.bmWidth
    bmi.bmHeader.biHeight = bm.bmHeight
    'Now that we've built the temporary header, we use StretchDIBits to take the data from the
    'ImageData() array and put it into SrcPictureBox using the settings specified in 'bmi' (the
    'StretchDIBits call should be on one continuous line)
    StretchDIBits DstPictureBox.hdc, 0, 0, bm.bmWidth, bm.bmHeight, 0, 0, bm.bmWidth, bm.bmHeight, imagedata(0), bmi, 0, vbSrcCopy
    'Since this doesn't automatically initialize AutoRedraw, we have to do it manually
    'Note: Always set AutoRedraw to true when using DIB sections; when AutoRedraw is false
    'you will get unpredictable results.
    
    DstPictureBox.Picture = DstPictureBox.Image
    DstPictureBox.Refresh
   
End Function



Public Function CropImData(ByRef DstPictureBox As PictureBox, ByRef SrcPictureBox As PictureBox, ByRef imagedata() As Byte, _
                           ByVal xmin As Long, ByVal xmax As Long, ByVal ymin As Long, ByVal ymax As Long)

   StretchBlt DstPictureBox.hdc, 0, 0, DstPictureBox.ScaleWidth, DstPictureBox.ScaleHeight, SrcPictureBox.hdc, xmin, ymin, xmax - xmin, ymax - ymin, vbSrcCopy
   GetImageData DstPictureBox, imagedata
   SetImageData DstPictureBox, imagedata

End Function

Public Function fgray(ByRef srcPic As PictureBox, ByRef dstPic As PictureBox, ByRef imagedata() As Byte)
'fast grayscaling..but not very accurate
    Dim DeskWnd As Long, DeskDC As Long
    Dim MyDC As Long
    Dim MyDIB As Long, OldDIB As Long
    Dim DIBInf As BITMAPINFO
    Dim MakePal As Long

    ' Persist drawing
   

    ' Create DC based on desktop DC
    DeskWnd = GetDesktopWindow()
    DeskDC = GetDC(DeskWnd)
    MyDC = CreateCompatibleDC(DeskDC)
    ReleaseDC DeskWnd, DeskDC

    ' Validate DC
    If (MyDC = 0) Then Exit Function

    ' Set DIB information
    With DIBInf
        With .bmHeader ' Same size as picture
            .biWidth = srcPic.ScaleX( _
                srcPic.ScaleWidth, srcPic.ScaleMode, vbPixels)
            .biHeight = srcPic.ScaleY( _
                srcPic.ScaleHeight, srcPic.ScaleMode, vbPixels)
            .biBitCount = 8
            .biPlanes = 1
            .biClrUsed = 256
            .biClrImportant = 256
            .biSize = Len(DIBInf.bmHeader)
        End With

        ' Palette is Greyscale
        Dim r As Long, g As Long, b As Long
        For MakePal = 0 To 255
            
            With .bmColors(MakePal)
                .Red = MakePal
                .Green = MakePal
                .Blue = MakePal
            End With
            
        Next MakePal
    End With

    ' Create the DIBSection
    MyDIB = CreateDIBSection8(MyDC, DIBInf, 0, ByVal 0&, 0, 0)

    If (MyDIB) Then ' Validate and select DIB
        OldDIB = SelectObject(MyDC, MyDIB)
        
        dstPic.Picture = srcPic.Picture 'if i commented this line it wont work _
                                            if i wanted the result to b shown in picture2
                                            
        ' Draw original picture to the greyscale DIB
        BitBlt MyDC, 0, 0, DIBInf.bmHeader.biWidth, _
            DIBInf.bmHeader.biHeight, srcPic.hdc, 0, 0, vbSrcCopy
        
        ' Draw the greyscale image back to the picture box
        BitBlt dstPic.hdc, 0, 0, DIBInf.bmHeader.biWidth, _
            DIBInf.bmHeader.biHeight, MyDC, 0, 0, vbSrcCopy

        ' Clean up DIB
        SelectObject MyDC, OldDIB
        DeleteObject MyDIB
    End If

    ' Clean up DC
    DeleteDC MyDC

    ' Redraw on screen
    dstPic.Refresh
    
    'set the image so it stick on the picturebox and can b save
    GetImageData dstPic, imagedata
    SetImageData dstPic, imagedata
End Function

Public Function nGray(ByRef srcPic As PictureBox, ByRef dstPic As PictureBox, ByRef imageArray() As Byte)
'not very fast...but more accurate grayscaling
    Dim tmpwid As Long, tmphgt As Long, y As Long, x As Long, xy() As Long, yx() As Long
    Dim temp As Long, temp2 As Long, r As Long, g As Long, b As Long, tempcolor As Long
    
    tmpwid = srcPic.ScaleWidth
    tmphgt = srcPic.ScaleHeight
    temp = 3 * tmpwid
    temp2 = tmpwid Mod 4
    
    ReDim xy(0 To tmphgt)
    For y = 1 To tmphgt
        xy(y) = y * temp
        xy(y) = xy(y) + temp2 * y
    Next
    
    ReDim yx(0 To tmpwid)
    For x = 0 To tmpwid
        yx(x) = 3 * x
    Next
    
    GetImageDataStream srcPic, imageArray()
    
    For x = 0 To tmpwid - 1
    DoEvents
        For y = 0 To tmphgt - 1
           'DoEvents
            r = imageArray(xy(y) + yx(x)) ' get the red value at x,y ; after aligning imagearray for pixel red is at cordinate ( x*3,y )
            g = imageArray(xy(y) + yx(x) + 1) ' get the green value at x,y ; pixel green is at ( (x*3) + 1 , y )
            b = imageArray(xy(y) + yx(x) + 2) ' get the blue value at x,y ; pixel blue is at ( (x*3) + 2 , y )
    
           tempcolor = (r + g + b) \ 3 'get the average value of red green & blue
     
            imageArray(xy(y) + yx(x)) = tempcolor 'set all red green and blue channel
            imageArray(xy(y) + yx(x) + 1) = tempcolor 'to the average color we get
            imageArray(xy(y) + yx(x) + 2) = tempcolor
        Next
    Next
    dstPic.Width = srcPic.Width
    dstPic.Height = srcPic.Height
    SetImageDataStream dstPic, imageArray()
    
End Function

Public Function BW(ByRef srcPic As PictureBox, ByRef dstPic As PictureBox, ByRef imageArray() As Byte, ByVal TH As Long)
fgray srcPic, srcPic, imageArray()
GetImageData srcPic, imageArray()

Dim tmpwid, tmphgt As Long
tmpwid = srcPic.ScaleWidth
tmphgt = srcPic.ScaleHeight

Dim x, y As Long
Dim xy() As Long
ReDim xy(0 To tmpwid * 3)
For x = 0 To tmpwid * 3
    xy(x) = x * 3
Next

For x = 0 To tmpwid - 1
    For y = 0 To tmphgt - 1
        If imageArray(xy(x), y) < TH Then
            imageArray(xy(x), y) = 0
            imageArray(xy(x) + 1, y) = 0
            imageArray(xy(x) + 2, y) = 0
        Else
            imageArray(xy(x), y) = 255
            imageArray(xy(x) + 1, y) = 255
            imageArray(xy(x) + 2, y) = 255
        End If
    Next
Next
SetImageData dstPic, imageArray()
End Function