Attribute VB_Name = "GraphicsEffects"
Option Explicit

Private Type BITMAP
   bmType As Long
   bmWidth As Long
   bmHeight As Long
   bmWidthBytes As Long
   bmPlanes As Integer
   bmBitsPixel As Integer
   bmBits As Long
End Type

Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long

Private Type RGBQUAD
   rgbBlue As Byte
   rgbGreen As Byte
   rgbRed As Byte
   rgbAlpha As Byte
End Type

Private Type BITMAPINFOHEADER
   bmSize As Long
   bmWidth As Long
   bmHeight As Long
   bmPlanes As Integer
   bmBitCount As Integer
   bmCompression As Long
   bmSizeImage As Long
   bmXPelsPerMeter As Long
   bmYPelsPerMeter As Long
   bmClrUsed As Long
   bmClrImportant As Long
End Type

Private Type BITMAPINFO
   bmHeader As BITMAPINFOHEADER
   bmColors(0 To 255) As RGBQUAD
End Type

Private Declare Function GetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long

Private Declare Function StretchDIBits Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal dWidth As Long, ByVal dHeight As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal SrcWidth As Long, ByVal SrcHeight As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long, ByVal RasterOp As Long) As Long
Private Declare Function GetBitmapDimensionEx Lib "gdi32" (ByVal hBitmap As Long, lpDimension As Size) As Long
Public Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Public Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Public Declare Function TransparentBlt Lib "msimg32.dll" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal crTransparent As Long) As Boolean
Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function AlphaBlend Lib "msimg32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal widthSrc As Long, ByVal heightSrc As Long, ByVal blendFunct As Long) As Boolean
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

Private Type Size
        cx As Long
        cy As Long
End Type

Dim bitmapsize As Size

Private Type Color
    Red As Long
    Green As Long
    Blue As Long
End Type

Dim bmLen As Long
Dim bm As BITMAP
Dim bmi As BITMAPINFO
Dim RGBColor As Color

Private Function GrayScale(ByVal lColor As Long) As Long
  GrayScale = ((77& * (lColor And &HFF&) + _
                 152& * (lColor And &HFF00&) \ &H100& + _
                  28& * (lColor \ &H10000)) \ 256&) * &H10101
End Function

' added this function I use to word align any bitmap bit depth
Private Function ByteAlignOnWord(ByVal bitDepth As Byte, ByVal Width As Long) As Long
    ' function to align any bit depth on dWord boundaries
    ByteAlignOnWord = (((Width * bitDepth) + &H1F&) And Not &H1F&) \ &H8&
End Function


Private Function RGBValues(Color As Long) As Color 'find the rgb color values of a color
    Dim ReturnColor As Color
    With ReturnColor
        .Red = Fix(Color And 255)
        .Green = Fix((Color And 65535) / 256)
        .Blue = Fix(Color / 65536)
    End With
    RGBValues = ReturnColor
End Function

Public Sub ChangeImageColor(ByRef SrcPictureBox As Control, ByRef DstPictureBox As Control, ByRef OldColor As Long, ByRef NewColor As Long)
    Dim ImageData() As Byte
    Dim X As Long, Y As Long
    
    DstPictureBox.Picture = Nothing
    'Now we fill up the bmi (Bitmap information variable) with all of the appropriate data
    bmi.bmHeader.bmSize = 40 'Size, in bytes, of the header (always 40)
    bmi.bmHeader.bmPlanes = 1 'Number of planes (always one)
    bmi.bmHeader.bmBitCount = 24 'Bits per pixel (always 24 for image processing)
    bmi.bmHeader.bmCompression = 0 'Compression: none or RLE (always zero)

    'Calculate the size of the bitmap type (in bytes)
    
    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.
    ReDim ImageData(0 To ByteAlignOnWord(24, bm.bmWidth) - 1, 0 To bm.bmHeight - 1)

    'Finish building the 'bmi' variable we want to pass to the GetDIBits call (the same variable we used above)
    bmi.bmHeader.bmWidth = bm.bmWidth
    bmi.bmHeader.bmHeight = 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, 0), bmi, 0
    
    RGBColor = RGBValues(NewColor)
    For X = 0 To ByteAlignOnWord(bmi.bmHeader.bmBitCount, bm.bmWidth) - 3 Step 3
        For Y = 0 To bm.bmHeight - 1
            If OldColor = RGB(ImageData(X + 2, Y), ImageData(X + 1, Y), ImageData(X, Y)) Then
                ImageData(X + 2, Y) = RGBColor.Red
                ImageData(X + 1, Y) = RGBColor.Green
                ImageData(X, Y) = RGBColor.Blue
            End If
        Next Y
    Next X

    '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, 0), bmi, 0, vbSrcCopy

    'Since this doesn't automatically initialize AutoRedraw, we have to do it manually
    'Note: always keep AutoRedraw as 'True' when using DIB sections. Otherwise, you WILL get unpredictable results.
    If DstPictureBox.AutoRedraw = True Then
        DstPictureBox.Picture = DstPictureBox.Image
        DstPictureBox.Refresh
    End If
End Sub

Public Sub BlackandWhite(ByRef SrcPictureBox As Control, ByRef DstPictureBox As Control)
    Dim ImageData() As Byte
    Dim X As Long, Y As Long
    Dim OldColor As Long
    Dim BlackWhiteColor As Long
    
    DstPictureBox.Picture = Nothing
    'Now we fill up the bmi (Bitmap information variable) with all of the appropriate data
    bmi.bmHeader.bmSize = 40 'Size, in bytes, of the header (always 40)
    bmi.bmHeader.bmPlanes = 1 'Number of planes (always one)
    bmi.bmHeader.bmBitCount = 24 'Bits per pixel (always 24 for image processing)
    bmi.bmHeader.bmCompression = 0 'Compression: none or RLE (always zero)

    'Calculate the size of the bitmap type (in bytes)
    
    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.
    ReDim ImageData(0 To ByteAlignOnWord(24, bm.bmWidth) - 1, 0 To bm.bmHeight - 1)

    'Finish building the 'bmi' variable we want to pass to the GetDIBits call (the same variable we used above)
    bmi.bmHeader.bmWidth = bm.bmWidth
    bmi.bmHeader.bmHeight = 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, 0), bmi, 0
    
    For X = 0 To ByteAlignOnWord(bmi.bmHeader.bmBitCount, bm.bmWidth) - 3 Step 3
        For Y = 0 To bm.bmHeight - 1
            OldColor = RGB(ImageData(X + 2, Y), ImageData(X + 1, Y), ImageData(X, Y))
            BlackWhiteColor = GrayScale(OldColor)
            RGBColor = RGBValues(BlackWhiteColor)
            ImageData(X + 2, Y) = RGBColor.Red
            ImageData(X + 1, Y) = RGBColor.Green
            ImageData(X, Y) = RGBColor.Blue
        Next Y
    Next X

    '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, 0), bmi, 0, vbSrcCopy

    'Since this doesn't automatically initialize AutoRedraw, we have to do it manually
    'Note: always keep AutoRedraw as 'True' when using DIB sections. Otherwise, you WILL get unpredictable results.
    If DstPictureBox.AutoRedraw = True Then
        DstPictureBox.Picture = DstPictureBox.Image
        DstPictureBox.Refresh
    End If
End Sub

Public Sub Shadow(ByRef SrcPictureBox As Control, ByRef DstPictureBox As Control, Optional ByRef ShadowX As Long = 0, Optional ByRef ShadowY As Long = 0, Optional ByRef ShadowColor As Long = 0)
    Dim ImageData() As Byte
    Dim X As Long, Y As Long
    Dim OldColor As Long
    Dim lngBackColor As Long
    
    DstPictureBox.Picture = Nothing
    'Now we fill up the bmi (Bitmap information variable) with all of the appropriate data
    bmi.bmHeader.bmSize = 40 'Size, in bytes, of the header (always 40)
    bmi.bmHeader.bmPlanes = 1 'Number of planes (always one)
    bmi.bmHeader.bmBitCount = 24 'Bits per pixel (always 24 for image processing)
    bmi.bmHeader.bmCompression = 0 'Compression: none or RLE (always zero)

    'Calculate the size of the bitmap type (in bytes)
    
    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.
    ReDim ImageData(0 To ByteAlignOnWord(24, bm.bmWidth) - 1, 0 To bm.bmHeight - 1)

    'Finish building the 'bmi' variable we want to pass to the GetDIBits call (the same variable we used above)
    bmi.bmHeader.bmWidth = bm.bmWidth
    bmi.bmHeader.bmHeight = 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, 0), bmi, 0
    
    
    lngBackColor = RGB(ImageData(0 + 2, 0), ImageData(0 + 1, 0), ImageData(0, 0))
    For X = 0 To ByteAlignOnWord(bmi.bmHeader.bmBitCount, bm.bmWidth) - 3 Step 3
        For Y = 0 To bm.bmHeight - 1
            OldColor = RGB(ImageData(X + 2, Y), ImageData(X + 1, Y), ImageData(X, Y))
            If OldColor <> RGB(ImageData(0 + 2, 0), ImageData(0 + 1, 0), ImageData(0, 0)) Then
                RGBColor = RGBValues(ShadowColor)
                ImageData(X + 2, Y) = RGBColor.Red
                ImageData(X + 1, Y) = RGBColor.Green
                ImageData(X, Y) = RGBColor.Blue
            End If
        Next Y
    Next X

    '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, ShadowX, ShadowY, bm.bmWidth, bm.bmHeight, 0, 0, bm.bmWidth, bm.bmHeight, ImageData(0, 0), bmi, 0, vbSrcCopy
    TransparentBlt DstPictureBox.hdc, 0, 0, bm.bmWidth, bm.bmHeight, SrcPictureBox.hdc, 0, 0, bm.bmWidth, bm.bmHeight, lngBackColor
    
    'Since this doesn't automatically initialize AutoRedraw, we have to do it manually
    'Note: always keep AutoRedraw as 'True' when using DIB sections. Otherwise, you WILL get unpredictable results.
    If DstPictureBox.AutoRedraw = True Then
        DstPictureBox.Picture = DstPictureBox.Image
        DstPictureBox.Refresh
    End If
End Sub

Public Sub Bright(ByRef SrcPictureBox As PictureBox, ByRef DstPictureBox As PictureBox, ByRef lngBright As Long)
    Dim ImageData() As Byte
    Dim X As Long, Y As Long
        
    'Now we fill up the bmi (Bitmap information variable) with all of the appropriate data
    bmi.bmHeader.bmSize = 40 'Size, in bytes, of the header (always 40)
    bmi.bmHeader.bmPlanes = 1 'Number of planes (always one)
    bmi.bmHeader.bmBitCount = 24 'Bits per pixel (always 24 for image processing)
    bmi.bmHeader.bmCompression = 0 'Compression: none or RLE (always zero)

    'Calculate the size of the bitmap type (in bytes)
    
    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.
    ReDim ImageData(0 To ByteAlignOnWord(24, bm.bmWidth) - 1, 0 To bm.bmHeight - 1)

    'Finish building the 'bmi' variable we want to pass to the GetDIBits call (the same variable we used above)
    bmi.bmHeader.bmWidth = bm.bmWidth
    bmi.bmHeader.bmHeight = 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, 0), bmi, 0
    
    For X = 0 To ByteAlignOnWord(bmi.bmHeader.bmBitCount, bm.bmWidth) - 3 Step 3
        For Y = 0 To bm.bmHeight - 1
            ImageData(X + 2, Y) = ImageData(X + 2, Y) + lngBright
            ImageData(X + 1, Y) = ImageData(X + 1, Y) + lngBright
            ImageData(X, Y) = ImageData(X, Y) + lngBright
        Next Y
    Next X

    '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, 0), bmi, 0, vbSrcCopy
        
    'Since this doesn't automatically initialize AutoRedraw, we have to do it manually
    'Note: always keep AutoRedraw as 'True' when using DIB sections. Otherwise, you WILL get unpredictable results.
    If DstPictureBox.AutoRedraw = True Then
        DstPictureBox.Picture = DstPictureBox.Image
        DstPictureBox.Refresh
    End If
End Sub

Public Sub ImageSize(ByRef Picture As Control)
    GetBitmapDimensionEx Picture.Picture.Handle, bitmapsize
    Debug.Print bitmapsize.cx
End Sub

'Rotate an image
Public Sub RotateImage(picDestiny As Control, picSource As Control, ByVal Angle As Single, Optional ByVal PosX As Long = 0, Optional ByVal PosY As Long = 0)
    Dim X1 As Long, Y1 As Long
    Dim X2 As Long, Y2 As Long
    Dim X As Long, Y As Long
    Dim CosA As Single, SinA As Single
    Dim Wdth As Long, Hght As Long
    Dim SrcOffX As Long, SrcOffY As Long
    Dim SrcHdc As Long, TgtHdc As Long
   
    picDestiny.Cls
    'calculate negative angle in radians, negative because mapping from destination to source
    Angle = Angle * 1.74532925199433E-02 'same as Angle * (pi/180) * -1
   
    CosA = Cos(Angle)
    SinA = Sin(Angle)
    Set picDestiny.Picture = Nothing
    picDestiny.Cls
    If picSource.Height > picSource.Width Then
        picSource.Width = picSource.Height
    Else
        picSource.Height = picSource.Width
    End If
    With picSource 'Get the width and height in pixels
        Wdth = .ScaleX(.ScaleWidth, .ScaleMode, vbPixels)
        Hght = .ScaleY(.ScaleHeight, .ScaleMode, vbPixels)
        'Make the target picturebox the same size as the source
        picDestiny.ScaleMode = .ScaleMode
        picDestiny.BorderStyle = .BorderStyle
        picDestiny.Width = .Width
        picDestiny.Height = .Height
    End With
   
    SrcOffX = (Wdth \ 2)
    SrcOffY = (Hght \ 2)
   
    SrcHdc = picSource.hdc
    TgtHdc = picDestiny.hdc
   
    For Y2 = 0 To Hght
        For X2 = 0 To Wdth
            X = X2 - SrcOffX
            Y = Y2 - SrcOffY
            X1 = (X * CosA - Y * SinA) + SrcOffX
            If X1 >= 0 Then
                If X1 < Wdth Then 'the pixel is within the horizontal range
                    Y1 = (X * SinA + Y * CosA) + SrcOffY
                    If Y1 >= 0 Then
                        If Y1 < Hght Then 'the pixel is within range
                            SetPixel TgtHdc, X2 + PosX, Y2 + PosY, GetPixel(SrcHdc, X1, Y1)
                        End If
                    End If
                End If
            End If
        Next X2
    Next Y2
    picDestiny.Picture = picDestiny.Image
End Sub