Gurus; Please help!

[joey o.]

Is there a way to loop through the floodfill api to produce a gradient? If it can't be done this way, are there any other ideas? My killer app will instead be a sorry-assed wimpy piece of crap without it. I will definitely give credit on the app but no money though. But jeepers-creepers, if you know code like this you probably already have a Mazaratti anyway. Please help, I want to buy a Lexus soon.
Joey o

If you want to create a gradient, you can use this code.

Sub Dither(vForm As Form)

    Dim intLoop As Integer
    vForm.DrawStyle = vbInsideSolid
    vForm.DrawMode = vbCopyPen
    vForm.ScaleMode = vbPixels
    vForm.DrawWidth = 2
    vForm.ScaleHeight = 256
    For intLoop = 0 To 255
    vForm.Line (0, intLoop)-(Screen.Width, intLoop - 1), RGB(0, 0, 255 - intLoop), B
    Next intLoop

End Sub

Private Sub Form_Activate()

    Me.AutoRedraw = True
    Dither Me

End Sub

[joey o.]

No, No, No! You've misunderstood. I need a way to get into whatever makes up the floodfill API and replace the solid fill color with a gradient. I either need a way to capture and enter into the loop filling the bounded area or I need a way to save a picture of a gradient and make it into a color object that can fill as a floodfill "color". The latter seems less than likely or desirable.Any Gurus Know this or can volunteer some advice?

[PaulLewis]

I hope to be proven wrong, but I suspect the type of thing you are trying to do is very likely to be unsupported which would make your killer app a little scary. I mean, to override a core function like FillRect, you would need to find it in memory, change the pointer to point to your new function, and so on. Even if it were possible (which I doubt since that's the whole point about protected mode), it isn't likely that anyone will like your app fiddling about in memory etc.

So I think you should try to use Megatrons approach since it is fully supported. Perhaps in VB7 you will be able to subclass Shape properly or override some of it's methods. IN the meantime, I modified Megatrons example a bit to make it work generically on a Rectangle shape. I have a Button and a Shape control and the code below works fine.

I KNOW it will be much harder to make it work for other shapes, but maybe looking for this type of silution is the only way to get it to work? PLEASE prove me wrong as I would quite like the gradient fill ability on NORMAL shapes.

You can always make your own Shape control supporting all of the Shape methods plus your extra FillGradient...

Sub Dither(vForm As Form, vShape As Shape)

    Dim intLoop As Integer
    Dim stepVal As Integer
    vForm.DrawStyle = vbInsideSolid
    vForm.DrawMode = vbCopyPen
    vForm.ScaleMode = vbPixels
    vForm.DrawWidth = 1
    vForm.ScaleHeight = 256
    stepVal = (256 / vShape.Height)
    For intLoop = 0 To 255 Step stepVal
      vForm.Line (vShape.Left, vShape.Top + intLoop / stepVal)-(vShape.Left + vShape.Width, vShape.Top + intLoop / stepVal - 1), RGB(0, 0, 255 - intLoop), B
    Next intLoop

End Sub

Private Sub Command1_Click()
  Me.AutoRedraw = True
  Dither Me, Shape1
End Sub

Probably no help. good luck

Paul Lewis

[Edited by PaulLewis on 07-03-2000 at 09:54 AM]

[Judd]

I don't know if this is any good, but it might help.

PS - Don't give me credit for this, it isn't my code.
It came from someone called Alex Kaufman
(www.KaufmanSoft.com)

Option Explicit

Private Type RECT
    left As Long
    tOp As Long
    Right As Long
    Bottom As Long
End Type

Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long

Private Const LOGPIXELSX = 88    '  Logical pixels/inch in X
Private Const LOGPIXELSY = 90    '  Logical pixels/inch in Y

Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long

Private Const LF_FACESIZE = 32

Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As Byte
    lfUnderline As Byte
    lfStrikeOut As Byte
    lfCharSet As Byte
    lfOutPrecision As Byte
    lfClipPrecision As Byte
    lfQuality As Byte
    lfPitchAndFamily As Byte
    lfFaceName(LF_FACESIZE) As Byte
End Type

Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
Private Const FF_DONTCARE = 0
Private Const DEFAULT_QUALITY = 0
Private Const DEFAULT_PITCH = 0
Private Const DEFAULT_CHARSET = 1

Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long

Private Const CLR_INVALID = -1

Private m_picThis As PictureBox
Private m_sCaption As String
Private m_bRGBStart(1 To 3) As Integer
Private m_oStartColor As OLE_COLOR
Private m_bRGBEnd(1 To 3) As Integer
Private m_oEndColor As OLE_COLOR

Public Property Let Caption(ByVal sCaption As String)
    m_sCaption = sCaption
End Property

Public Property Get Caption() As String
    Caption = m_sCaption
End Property

Public Property Let DrawingObject(ByRef picThis As PictureBox)
    Set m_picThis = picThis
End Property

Public Property Get StartColor() As OLE_COLOR
    StartColor = m_oStartColor
End Property

Public Property Let StartColor(ByVal oColor As OLE_COLOR)
Dim lColor As Long
    If (m_oStartColor <> oColor) Then
        m_oStartColor = oColor
        OleTranslateColor oColor, 0, lColor
        m_bRGBStart(1) = lColor And &HFF&
        m_bRGBStart(2) = ((lColor And &HFF00&) \ &H100)
        m_bRGBStart(3) = ((lColor And &HFF0000) \ &H10000)
        If Not (m_picThis Is Nothing) Then
            Draw
        End If
    End If
End Property

Public Property Get EndColor() As OLE_COLOR
    EndColor = m_oEndColor
End Property

Public Property Let EndColor(ByVal oColor As OLE_COLOR)
Dim lColor As Long
    If (m_oEndColor <> oColor) Then
        m_oEndColor = oColor
        OleTranslateColor oColor, 0, lColor
        m_bRGBEnd(1) = lColor And &HFF&
        m_bRGBEnd(2) = ((lColor And &HFF00&) \ &H100)
        m_bRGBEnd(3) = ((lColor And &HFF0000) \ &H10000)
        If Not (m_picThis Is Nothing) Then
            Draw
        End If
    End If
End Property

Public Sub Draw()
Dim lHeight As Long, lWidth As Long
Dim lYStep As Long
Dim lY As Long
Dim bRGB(1 To 3) As Integer
Dim tLF As LOGFONT
Dim hFnt As Long
Dim hFntOld As Long
Dim lR As Long
Dim rct As RECT
Dim hBr As Long
Dim hDC As Long
Dim dR(1 To 3) As Double
On Error GoTo DrawError

    hDC = m_picThis.hDC
    lHeight = m_picThis.Height \ Screen.TwipsPerPixelY
    rct.Right = m_picThis.Width \ Screen.TwipsPerPixelY
    ' Set a graduation of 255 pixels:
    lYStep = lHeight \ 255
    If (lYStep = 0) Then
        lYStep = 1
    End If
    rct.Bottom = lHeight
    
    bRGB(1) = m_bRGBStart(1)
    bRGB(2) = m_bRGBStart(2)
    bRGB(3) = m_bRGBStart(3)
    dR(1) = m_bRGBEnd(1) - m_bRGBStart(1)
    dR(2) = m_bRGBEnd(2) - m_bRGBStart(2)
    dR(3) = m_bRGBEnd(3) - m_bRGBStart(3)
        
    For lY = lHeight To 0 Step -lYStep
        ' Draw bar:
        rct.tOp = rct.Bottom - lYStep
        hBr = CreateSolidBrush((bRGB(3) * &H10000 + bRGB(2) * &H100& + bRGB(1)))
        FillRect hDC, rct, hBr
        DeleteObject hBr
        rct.Bottom = rct.tOp
        ' Adjust colour:
        bRGB(1) = m_bRGBStart(1) + dR(1) * (lHeight - lY) / lHeight
        bRGB(2) = m_bRGBStart(2) + dR(2) * (lHeight - lY) / lHeight
        bRGB(3) = m_bRGBStart(3) + dR(3) * (lHeight - lY) / lHeight
        'Debug.Print bRGB(1), (lHeight - lY) / lHeight
    Next lY
    
    pOLEFontToLogFont m_picThis.Font, hDC, tLF
    tLF.lfEscapement = 900
    hFnt = CreateFontIndirect(tLF)
    If (hFnt <> 0) Then
        hFntOld = SelectObject(hDC, hFnt)
        lR = TextOut(hDC, 0, lHeight - 16, m_sCaption, Len(m_sCaption))
        SelectObject hDC, hFntOld
        DeleteObject hFnt
    End If
    
    m_picThis.Refresh
    Exit Sub
DrawError:
    Debug.Print "Problem: " & Err.description
End Sub

Private Sub pOLEFontToLogFont(fntThis As StdFont, hDC As Long, tLF As LOGFONT)
Dim sFont As String
Dim iChar As Integer
    ' Convert an OLE StdFont to a LOGFONT structure:
    With tLF
        sFont = fntThis.Name
        ' There is a quicker way involving StrConv and CopyMemory, but
        ' this is simpler!:
        For iChar = 1 To Len(sFont)
            .lfFaceName(iChar - 1) = CByte(Asc(Mid$(sFont, iChar, 1)))
        Next iChar
        ' Based on the Win32SDK documentation:
        .lfHeight = -MulDiv((fntThis.Size), (GetDeviceCaps(hDC, LOGPIXELSY)), 72)
        .lfItalic = fntThis.Italic
        If (fntThis.Bold) Then
            .lfWeight = FW_BOLD
        Else
            .lfWeight = FW_NORMAL
        End If
        .lfUnderline = fntThis.Underline
        .lfStrikeOut = fntThis.Strikethrough
    End With
End Sub

Private Sub Class_Initialize()
    'StartColor = &H0
    StartColor = RGB(10, 36, 106)
    'EndColor = vbButtonFace
    EndColor = RGB(166, 202, 240)
End Sub

Judd, there were a couple Smilies showing up in your code, so if you want, you can choose to disable them.

[Judd]

All gone!

[kedaman]

Well i'm sure floodfill api isn't alone there, if you possibly could get a region of the are youre trying to make gradient, you could fill the rest with black on another DC and then make a mask an just blitt the premade gradient image.

[PaulLewis]

I think bitblt would yeild a poor result since the height of the control would not be fully appreciated. Bitblt would happily copy the gradient up to the edge and if there wasn't enough source image to blt then you have a poor result...

So you're back to havin to do the gradient fill at paint time.

The only alternative is to perhaps use stretchblt and SetStretchBltMode to DELETESCANS. This is probably what kedaman meant anyhow...

I'm too busy at present otherwise I'd give it a serious try...

Paul Lewis