cimageprocessdib.cls

Visual Basic image processing. Mainly it occupies some filters to detect some prperties of image. Re

    RaiseEvent InitProgress(xMax)
    
    For x = rgbOffset To xMax Step 3
        For y = m_iOffset To yMax
            'Debug.Print X, Y
            'Debug.Print pict(X + i, Y + j), pict(X + 1 + i, Y + j), pict(X + 2 + i, Y + j)
            r = 0: g = 0: b = 0
            For i = -m_iOffset To m_iOffset
                xOffset = i * 3
                For j = -m_iOffset To m_iOffset
                    r = r + m_iFilt(i, j) * pict(x + xOffset, y + j)
                    g = g + m_iFilt(i, j) * pict(x + 1 + xOffset, y + j)
                    b = b + m_iFilt(i, j) * pict(x + 2 + xOffset, y + j)
                Next j
            Next i
            rR = r \ m_iWeight: rG = g \ m_iWeight: rB = b \ m_iWeight
                If (rR < 0) Then rR = 0
                If (rG < 0) Then rG = 0
                If (rB < 0) Then rB = 0
                If (rR > 255) Then rR = 255
                If (rG > 255) Then rG = 255
                If (rB > 255) Then rB = 255
            'Debug.Print rR, rG, rB, vbCrLf
            pict2(x, y) = rR: pict2(x + 1, y) = rG: pict2(x + 2, y) = rB
        Next y
        RaiseEvent Progress(x)
    Next x
         
    ' clear the temporary array descriptor
    ' without destroying the local temporary array
    CopyMemory ByVal VarPtrArray(pict), 0&, 4
    CopyMemory ByVal VarPtrArray(pict2), 0&, 4
        
    RaiseEvent Complete(timeGetTime - lTIme)
    
    pbStandardFilter = True
    
End Function
Public Function AddLightest( _
      ByRef cFrom As cDIBSection, _
      ByRef cTo As cDIBSection _
   )
' these are used to address the pixel using matrices
Dim pict() As Byte
Dim pict2() As Byte
Dim sa As SAFEARRAY2D
Dim sa2 As SAFEARRAY2D
Dim x As Long, y As Long
Dim i As Long, j As Long, yMax As Long, lTIme As Long
Dim lGray1 As Long, lGray2 As Long

    lTIme = timeGetTime()
       
    ' have the local matrix point to bitmap pixels
    With sa
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cTo.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cTo.BytesPerScanLine
        .pvData = cTo.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(pict), VarPtr(sa), 4
    ' Pict now stores the To buffer
        
    ' have the local matrix point to bitmap pixels
    With sa2
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cFrom.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cFrom.BytesPerScanLine
        .pvData = cFrom.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(pict2), VarPtr(sa2), 4
    ' Pict2 now stores the From buffer

    yMax = cTo.Height - 1
    
    For x = 0 To (cTo.Width - 1) * 3 Step 3
        For y = 0 To yMax
            lGray1 = (222& * pict(x + 1, y) + 707& * pict(x + 1, y) + 71& * pict(x, y))
            lGray2 = (222& * pict2(x + 1, y) + 707& * pict2(x + 1, y) + 71& * pict2(x, y))
            If (lGray2 < lGray1) Then
               pict(x, y) = pict2(x, y)
               pict(x + 1, y) = pict2(x + 1, y)
               pict(x + 2, y) = pict2(x + 2, y)
            End If
        Next y
        'prgMain.Value = x
    Next x
    
    ' clear the temporary array descriptor
    ' without destroying the local temporary array
    CopyMemory ByVal VarPtrArray(pict), 0&, 4
    CopyMemory ByVal VarPtrArray(pict2), 0&, 4
   
End Function

Public Function AddDarkest( _
      ByRef cFrom As cDIBSection, _
      ByRef cTo As cDIBSection _
   )
' these are used to address the pixel using matrices
Dim pict() As Byte
Dim pict2() As Byte
Dim sa As SAFEARRAY2D
Dim sa2 As SAFEARRAY2D
Dim x As Long, y As Long
Dim i As Long, j As Long, yMax As Long, lTIme As Long
Dim lGray1 As Long, lGray2 As Long

    lTIme = timeGetTime()
       
    ' have the local matrix point to bitmap pixels
    With sa
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cTo.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cTo.BytesPerScanLine
        .pvData = cTo.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(pict), VarPtr(sa), 4
    ' Pict now stores the To buffer
        
    ' have the local matrix point to bitmap pixels
    With sa2
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cFrom.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cFrom.BytesPerScanLine
        .pvData = cFrom.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(pict2), VarPtr(sa2), 4
    ' Pict2 now stores the From buffer

    yMax = cTo.Height - 1
    
    For x = 0 To (cTo.Width - 1) * 3 Step 3
        For y = 0 To yMax
            lGray1 = (222& * pict(x + 1, y) + 707& * pict(x + 1, y) + 71& * pict(x, y))
            lGray2 = (222& * pict2(x + 1, y) + 707& * pict2(x + 1, y) + 71& * pict2(x, y))
            If (lGray1 < lGray2) Then
               pict(x, y) = pict2(x, y)
               pict(x + 1, y) = pict2(x + 1, y)
               pict(x + 2, y) = pict2(x + 2, y)
            End If
        Next y
        'prgMain.Value = x
    Next x
    
    ' clear the temporary array descriptor
    ' without destroying the local temporary array
    CopyMemory ByVal VarPtrArray(pict), 0&, 4
    CopyMemory ByVal VarPtrArray(pict2), 0&, 4
   
End Function
Public Function AddImages( _
        ByRef cFrom As cDIBSection, _
        ByRef cTo As cDIBSection, _
        ByVal lFromMultiplier As Long, _
        ByVal lFromOffsetR As Long, ByVal lFromOffsetG As Long, ByVal lFromOffsetB As Long, _
        ByVal lToMultiplier As Long, _
        ByVal lToOffsetR As Long, ByVal lToOffsetG As Long, ByVal lToOffsetB As Long _
    ) As Boolean
' these are used to address the pixel using matrices
Dim pict() As Byte
Dim pict2() As Byte
Dim sa As SAFEARRAY2D
Dim sa2 As SAFEARRAY2D
Dim x As Long, y As Long
Dim i As Long, j As Long, yMax As Long, lTIme As Long
Dim rR As Long, rG As Long, rB As Long

    lTIme = timeGetTime()
       
    ' have the local matrix point to bitmap pixels
    With sa
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cTo.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cTo.BytesPerScanLine
        .pvData = cTo.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(pict), VarPtr(sa), 4
    ' Pict now stores the To buffer
        
    ' have the local matrix point to bitmap pixels
    With sa2
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cFrom.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cFrom.BytesPerScanLine
        .pvData = cFrom.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(pict2), VarPtr(sa2), 4
    ' Pict2 now stores the From buffer

    yMax = cTo.Height - 1
    
    For x = 0 To (cTo.Width - 1) * 3 Step 3
        For y = 0 To yMax
            rR = (pict(x, y) + lToOffsetR) * lToMultiplier + (pict2(x, y) + lFromOffsetR) * lFromMultiplier
            rG = (pict(x + 1, y) + lToOffsetG) * lToMultiplier + (pict2(x + 1, y) + lFromOffsetG) * lFromMultiplier
            rB = (pict(x + 2, y) + lToOffsetB) * lToMultiplier + (pict2(x + 2, y) + lFromOffsetG) * lFromMultiplier
                If (rR < 0) Then rR = 0
                If (rG < 0) Then rG = 0
                If (rB < 0) Then rB = 0
                If (rR > 255) Then rR = 255
                If (rG > 255) Then rG = 255
                If (rB > 255) Then rB = 255
            
            pict(x, y) = rR
            pict(x + 1, y) = rG
            pict(x + 2, y) = rB
        Next y
        'prgMain.Value = x
    Next x
    
    ' clear the temporary array descriptor
    ' without destroying the local temporary array
    CopyMemory ByVal VarPtrArray(pict), 0&, 4
    CopyMemory ByVal VarPtrArray(pict2), 0&, 4
        
End Function

Public Sub BlackAndWhite( _
        ByRef cFrom As cDIBSection, _
        ByRef cTo As cDIBSection _
    )
' Converts to Black and WHite using Floyd-Steinberg error diffusion
' process.
' see http://www.dcs.ed.ac.uk/~mxr/gfx/faqs/colourspace.faq for details.
'
Dim pict() As Byte
Dim pict2() As Byte
Dim sa As SAFEARRAY2D
Dim sa2 As SAFEARRAY2D
Dim x As Long, y As Long
Dim i As Long, iCoeff As Long
Dim lTIme As Long
Dim xMax As Long, yMax As Long
Dim lError As Long
Dim lNew As Long
Dim iC As Long, iC2 As Long

    lTIme = timeGetTime()
       
    GrayScale cFrom
       
    ' have the local matrix point to bitmap pixels
    With sa
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cTo.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cTo.BytesPerScanLine
        .pvData = cTo.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(pict), VarPtr(sa), 4
    ' Pict now stores the To buffer
        
    ' have the local matrix point to bitmap pixels
    With sa2
        .cbElements = 1
        .cDims = 2
        .Bounds(0).lLbound = 0
        .Bounds(0).cElements = cFrom.Height
        .Bounds(1).lLbound = 0
        .Bounds(1).cElements = cFrom.BytesPerScanLine
        .pvData = cFrom.DIBSectionBitsPtr
    End With
    CopyMemory ByVal VarPtrArray(pict2), VarPtr(sa2), 4
    ' Pict2 now stores the From buffer


    yMax = cTo.Height - 1
    xMax = (cTo.Width - 1) * 3
    
    RaiseEvent InitProgress(xMax)
    For x = 0 To xMax Step 3
        For y = 0 To yMax
            ' Apply a simple threshold:
            If (pict2(x, y) > 128) Then
                iC = iC + 1
                pict(x, y) = 255
                pict(x + 1, y) = 255
                pict(x + 2, y) = 255
                lError = (255 - pict2(x, y)) - 128
            Else
                iC2 = iC2 + 1
                pict(x, y) = 0
                pict(x + 1, y) = 0
                pict(x + 2, y) = 0
                ' Black tolerance:
                If (pict2(x, y) > 16) Then
                    lError = pict2(x, y)
                Else
                    lError = 0
                End If
            End If
            
            ' Diffuse the error:
            If (x < xMax - 3) Then
                lNew = pict2(x + 3, y) + (lError * 7) \ 16
                If (lNew > 255) Then lNew = 255
                If (lNew < 0) Then lNew = 0
                pict2(x + 3, y) = lNew
                pict2(x + 4, y) = lNew
                pict2(x + 5, y) = lNew
            End If
            If (y < yMax) Then
                For i = -3 To 3 Step 3
                    If (x + i) > 0 And (x + i) < xMax Then
                        Select Case i
                        Case -3
                            iCoeff = 3
                        Case 0
                            iCoeff = 5
                        Case 3
                            iCoeff = 1
                        End Select
                        lNew = pict2(x + i, y + 1) + (lError * iCoeff) \ 16
                        If (lNew > 255) Then lNew = 255
                        If (lNew < 0) Then lNew = 0
                        pict2(x + i, y + 1) = lNew
                        pict2(x + i + 1, y + 1) = lNew
                        pict2(x + i + 2, y + 1) = lNew
                    End If
                Next i
            End If
        Next y
        RaiseEvent Progress(x)
    Next x
    
    Debug.Print iC, iC2
    cFrom.LoadPictureBlt cTo.hdc
    RaiseEvent Complete(timeGetTime - lTIme)
    
    
End Sub

Public Sub ApplyPalette( _
      ByRef cFrom As cDIBSection, _
      ByRef cTo As cDIBSection, _
      ByRef cPal As cPalette _
   )
'
Dim pict() As Byte
Dim pict2() As Byte
Dim sa As SAFEARRAY2D
Dim sa2 As SAFEARRAY2D
Dim x As Long, y As Long
Dim i As Long, iCoeff As Long
Dim lTIme As Long
Dim xMax As Long, yMax As Long
Dim lErrorRed As Long, lErrorBlue As Long, lErrorGreen As Long
Dim lNewRed As Long, lNewBlue As Long, lNewGreen As Long
Dim lIndex As Long
Dim iC As Long, iC2 As Long

    lTIme = timeGetTime()
       
    ' have the local matrix point to bitmap pixels