cimageprocessdib.cls

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

    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
            ' Get nearest colour:
            lIndex = cPal.ClosestIndex(pict2(x + 2, y), pict2(x + 1, y), pict2(x, y))
                        
            pict(x + 2, y) = cPal.Red(lIndex)
            pict(x + 1, y) = cPal.Green(lIndex)
            pict(x, y) = cPal.Blue(lIndex)
                        
            lErrorRed = -1 * (CLng(pict(x + 2, y)) - pict2(x + 2, y))
            lErrorGreen = -1 * (CLng(pict(x + 1, y)) - pict2(x + 1, y))
            lErrorBlue = -1 * (CLng(pict(x, y)) - pict2(x, y))
            
            ' Diffuse the error:
            'Debug.Print lErrorRed, lErrorGreen, lErrorBlue
            If Abs(lErrorRed) + Abs(lErrorGreen) + Abs(lErrorBlue) > 3 Then
            If (x < xMax - 3) Then
                lNewBlue = pict2(x + 3, y) + (lErrorBlue * 7) \ 16
                lNewGreen = pict2(x + 4, y) + (lErrorGreen * 7) \ 16
                lNewRed = pict2(x + 5, y) + (lErrorRed * 7) \ 16
                Range lNewBlue, 0, 255
                Range lNewGreen, 0, 255
                Range lNewRed, 0, 255
                pict2(x + 3, y) = lNewBlue
                pict2(x + 4, y) = lNewGreen
                pict2(x + 5, y) = lNewRed
            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 = 0
                        Case 0
                            iCoeff = 4
                        Case 3
                            iCoeff = 0
                        End Select
                        lNewBlue = pict2(x + i, y + 1) + (lErrorBlue * iCoeff) \ 16
                        lNewGreen = pict2(x + i + 1, y + 1) + (lErrorGreen * iCoeff) \ 16
                        lNewRed = pict2(x + i + 2, y + 1) + (lErrorRed * iCoeff) \ 16
                        Range lNewBlue, 0, 255
                        Range lNewGreen, 0, 255
                        Range lNewRed, 0, 255
                        pict2(x + i, y + 1) = lNewBlue
                        pict2(x + i + 1, y + 1) = lNewGreen
                        pict2(x + i + 2, y + 1) = lNewRed
                    End If
                Next i
            End If
            End If
        Next y
        RaiseEvent Progress(x)
    Next x
    
    Debug.Print iC, iC2
    cFrom.LoadPictureBlt cTo.hdc
    RaiseEvent Complete(timeGetTime - lTIme)
    
    
End Sub
   
Private Sub Range( _
      ByRef lIn As Long, _
      ByVal lMin As Long, _
      ByVal lMax As Long _
   )
   If (lIn < lMin) Then
      lIn = lMin
   ElseIf (lIn > lMax) Then
      lIn = lMax
   End If
End Sub

Public Sub GrayScale( _
        ByRef cTo As cDIBSection _
    )
' Gray scale using standard intensity components.
' see http://www.dcs.ed.ac.uk/~mxr/gfx/faqs/colourspace.faq for details.
'
Dim bDib() As Byte
Dim x As Long, y As Long
Dim xMax As Long, yMax As Long
Dim bContinue As Boolean
Dim lB As Long, lG As Long, lR As Long
Dim lGray As Long
Dim lTIme As Long
Dim tSA As SAFEARRAY2D

    lTIme = timeGetTime()
        
    ' have the local matrix point to bitmap pixels
    With tSA
        .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(bDib), VarPtr(tSA), 4
        
    yMax = cTo.Height - 1
    xMax = cTo.Width - 1
    
    RaiseEvent InitProgress(xMax)
    For x = 0 To (xMax * 3) Step 3
        For y = 0 To yMax
            lB = bDib(x, y)
            lG = bDib(x + 1, y)
            lR = bDib(x + 2, y)
                
            'But now all people *should* use the most accurate, it means ITU standard:
            lGray = (222 * lR + 707 * lG + 71 * lB) / 1000
            
            bDib(x, y) = lGray
            bDib(x + 1, y) = lGray
            bDib(x + 2, y) = lGray
        Next y
        RaiseEvent Progress(x)
    Next x
    
    RaiseEvent Complete(timeGetTime - lTIme)
    
End Sub

Public Sub AddNoise( _
        ByRef cTo As cDIBSection, _
        ByVal lPercent As Long, _
        Optional ByVal bRandom = False _
    )
Dim bDib() As Byte
Dim x As Long, y As Long
Dim xMax As Long, yMax As Long
Dim bContinue As Boolean
Dim lB As Long, lG As Long, lR As Long
Dim lA As Long, lA2 As Long
Dim lTIme As Long
Dim tSA As SAFEARRAY2D

    lTIme = timeGetTime()
    
    lA = 128 * lPercent \ 100
    lA2 = lA \ 2
       
    
    ' have the local matrix point to bitmap pixels
    With tSA
        .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(bDib), VarPtr(tSA), 4
        
    yMax = cTo.Height - 1
    xMax = cTo.Width - 1
    
    RaiseEvent InitProgress(xMax)
    For x = 0 To (xMax * 3) Step 3
        For y = 0 To yMax
            If (bRandom) Then
                bContinue = False
                If (Rnd * 100 > lPercent) Then
                    bContinue = True
                End If
            End If
            If Not (bRandom) Or bContinue Then
                lB = bDib(x, y)
                lG = bDib(x + 1, y)
                lR = bDib(x + 2, y)
                
                lB = lB - lA2 + (Rnd * lA)
                lG = lG - lA2 + (Rnd * lA)
                lR = lR - lA2 + (Rnd * lA)
                
                If (lB < 0) Then lB = 0
                If (lG < 0) Then lG = 0
                If (lR < 0) Then lR = 0
                If (lR > 255) Then lR = 255
                If (lG > 255) Then lG = 255
                If (lB > 255) Then lB = 255
                
                bDib(x, y) = lB
                bDib(x + 1, y) = lG
                bDib(x + 2, y) = lR
            End If
        Next y
        RaiseEvent Progress(x)
    Next x
    RaiseEvent Complete(timeGetTime - lTIme)
        
End Sub

Public Sub Fade( _
      ByRef cTo As cDIBSection, _
      ByVal lAmount As Long _
   )
Dim bDib() As Byte
Dim x As Long, y As Long
Dim xMax As Long, yMax As Long
Dim bContinue As Boolean
Dim lB As Long, lG As Long, lR As Long
Dim lA As Long, lA2 As Long
Dim lTIme As Long
Dim tSA As SAFEARRAY2D
    
    ' have the local matrix point to bitmap pixels
    With tSA
        .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(bDib), VarPtr(tSA), 4
        
    yMax = cTo.Height - 1
    xMax = cTo.Width - 1
    
    RaiseEvent InitProgress(xMax)
    For x = 0 To (xMax * 3) Step 3
        For y = 0 To yMax
            lB = lAmount * bDib(x, y) \ 255
            lG = lAmount * bDib(x + 1, y) \ 255
            lR = lAmount * bDib(x + 2, y) \ 255
            bDib(x, y) = lB
            bDib(x + 1, y) = lG
            bDib(x + 2, y) = lR
        Next y
        RaiseEvent Progress(x)
    Next x
    RaiseEvent Complete(timeGetTime - lTIme)
    
End Sub

Public Sub Lighten( _
      ByRef cTo As cDIBSection, _
      ByVal lAmount As Long _
   )
Dim bDib() As Byte
Dim x As Long, y As Long
Dim xMax As Long, yMax As Long
Dim bContinue As Boolean
Dim lB As Long, lG As Long, lR As Long
Dim h As Single, s As Single, l As Single
Dim lTIme As Long
Dim tSA As SAFEARRAY2D
    
    ' have the local matrix point to bitmap pixels
    With tSA
        .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(bDib), VarPtr(tSA), 4
        
    yMax = cTo.Height - 1
    xMax = cTo.Width - 1
    
    RaiseEvent InitProgress(xMax)
    For x = 0 To (xMax * 3) Step 3
        For y = 0 To yMax
            RGBToHLS bDib(x + 2, y), bDib(x + 1, y), bDib(x, y), h, s, l
            l = l * (1 + (lAmount / 100))
            If (l > 1) Then l = 1
            HLSToRGB h, s, l, lR, lG, lB
            bDib(x, y) = lB
            bDib(x + 1, y) = lG
            bDib(x + 2, y) = lR
        Next y
        RaiseEvent Progress(x)
    Next x
    RaiseEvent Complete(timeGetTime - lTIme)
    
End Sub
Public Sub Colourise( _
      ByRef cTo As cDIBSection, _
      ByVal fHue As Single, _
      ByVal fSaturation As Single _
   )
' Saturation only applies to grey scale images.  Otherwise saturation
' is taken from the colour.
Dim bDib() As Byte
Dim x As Long, y As Long
Dim xMax As Long, yMax As Long
Dim bContinue As Boolean
Dim lB As Long, lG As Long, lR As Long
Dim h As Single, s As Single, l As Single
Dim lTIme As Long
Dim tSA As SAFEARRAY2D
    
    ' fHue runs from -1 to 5...
    
    ' have the local matrix point to bitmap pixels
    With tSA
        .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(bDib), VarPtr(tSA), 4
        
    yMax = cTo.Height - 1
    xMax = cTo.Width - 1
    
    RaiseEvent InitProgress(xMax)
    For x = 0 To (xMax * 3) Step 3
        For y = 0 To yMax
            RGBToHLS bDib(x + 2, y), bDib(x + 1, y), bDib(x, y), h, s, l
            If (h = 0) Then
               ' Set saturation (should allow user to choose...)
               s = 0.5
               h = fHue
            Else
               h = fHue
            End If
            HLSToRGB h, s, l, lR, lG, lB
            bDib(x, y) = lB
            bDib(x + 1, y) = lG
            bDib(x + 2, y) = lR
        Next y
        RaiseEvent Progress(x)
    Next x
    RaiseEvent Complete(timeGetTime - lTIme)
    

End Sub