CodeGuru Home VC++ / MFC / C++ .NET / C# Visual Basic VB Forums Developer.com
Results 1 to 4 of 4
  1. #1
    Join Date
    Jan 2014
    Posts
    9

    Flat Combo with custom button, border & nose color

    1. Place combo1 and picture1 to Form1

    [code'in Form

    Private Sub Form_Load()

    Combo1.AddItem "PP1"
    Combo1.AddItem "PP2"
    Combo1.AddItem "PP3"
    Combo1.AddItem "PP4"

    picPositionColor Combo1, Picture1, vbGreen, &H404040, vbBlack, Me, True '&HFFC0C0
    End Sub

    Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    m_Down Picture1
    End Sub

    Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    m_Up Picture1, Combo1
    End Sub[/code]



    Code:
    'in BAS Module
    Option Explicit
    
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Private Const CB_SHOWDROPDOWN = &H14F
    
    Private Declare Function SetParent Lib "user32.dll" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
    
    Public Const BS_LEFT    As Long = &H100&
    Public Const BS_RIGHT   As Long = &H200&
    Public Const BS_CENTER  As Long = &H300&
    Public Const BS_TOP     As Long = &H400&
    Public Const BS_BOTTOM  As Long = &H800&
    Public Const BS_vCENTER As Long = &HC00
    
    Private Const GWL_STYLE  As Long = (-16)
    
    Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    
    Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    
    Public Sub ShowDropDownCombo(cmb As ComboBox)
    SendMessage cmb.hwnd, CB_SHOWDROPDOWN, 1, 0
    End Sub
    
    Public Function picPositionColor(ByRef cmb As ComboBox, ByRef oPic As PictureBox, btnColor As Long, borderColor As Long, noseColor As Long, frm As Form, flat As Boolean)
        With oPic
                        .Visible = True
                        .Appearance = 0
                        .AutoRedraw = True
                        .BorderStyle = 0
                        .Tag = noseColor & ";" & flat
                        .BackColor = btnColor
                        .ScaleMode = vbTwips
                        .Height = cmb.Height - 60
                        .Width = 255
        
        End With
    
        SetParent oPic.hwnd, cmb.hwnd
            oPic.Move (cmb.Width - oPic.Width) - 30, (cmb.Height / 2) - (oPic.Height / 2)
            oPic.Refresh
        
        If flat = True Then
        Dim oControl(1 To 4) As Control
        Dim i As Integer
        ' add control to controls collection
        Set oControl(1) = frm.Controls.Add("VB.PictureBox", oPic.Name & "x1")
        Set oControl(2) = frm.Controls.Add("VB.PictureBox", oPic.Name & "x2")
        Set oControl(3) = frm.Controls.Add("VB.PictureBox", oPic.Name & "x3")
        Set oControl(4) = frm.Controls.Add("VB.PictureBox", oPic.Name & "x4")
        ' set whatever properties
        For i = 1 To 4
        With oControl(i)
                        .Visible = True
                        .Appearance = 0
                        .AutoRedraw = True
                        .BorderStyle = 0
                        .BackColor = borderColor
        End With
        Next i
        SetParent oControl(1).hwnd, cmb.hwnd
        oControl(1).Move 0, 0, cmb.Width, 30
        
        SetParent oControl(2).hwnd, cmb.hwnd
        oControl(2).Move 0, cmb.Height - 30, cmb.Width, 30
        
        SetParent oControl(3).hwnd, cmb.hwnd
        oControl(3).Move 0, 0, 30, cmb.Height
        
        SetParent oControl(4).hwnd, cmb.hwnd
        oControl(4).Move cmb.Width - 30, 0, 30, cmb.Height
    
        
        oControl(1).DrawWidth = 1
        oControl(1).Line (0, 0)-(oControl(1).Width, 0), frm.BackColor
        oControl(2).Line (0, 15)-(oControl(2).Width, 15), frm.BackColor
        oControl(3).Line (0, 0)-(0, oControl(3).Height), frm.BackColor
        oControl(3).Line (0, 0)-(oControl(3).Width, 0), frm.BackColor
        oControl(3).Line (0, oControl(3).Height - 15)-(oControl(3).Width, oControl(3).Height - 15), frm.BackColor
        oControl(4).Line (15, 0)-(15, oControl(4).Height), frm.BackColor
        oControl(4).Line (0, 0)-(oControl(3).Width, 0), frm.BackColor
        oControl(4).Line (0, oControl(3).Height - 15)-(oControl(3).Width, oControl(3).Height - 15), frm.BackColor
        End If
        
        m_UpLoading oPic
    End Function
    
    Public Function m_Down(pic1 As PictureBox)
    pic1.BorderStyle = 1
    btnNose pic1, True
    End Function
    
    Public Function m_Up(pic1 As PictureBox, cmb As ComboBox)
    Dim flatStyle As Boolean
    
    pic1.BorderStyle = 0
    
    Dim k As String
    k = Right(pic1.Tag, 4)
    
    If UCase(k) = "TRUE" Then flatStyle = True Else flatStyle = False
    
    btnNose pic1, False
    DrawShades pic1, flatStyle
    
    If Not cmb Is Nothing Then
    ShowDropDownCombo cmb
    End If
    
    End Function
    
    Public Function m_UpLoading(pic1 As PictureBox)
    Dim flatStyle As Boolean
    
    pic1.BorderStyle = 0
    Dim k As String
    k = Right(pic1.Tag, 4)
    
    If UCase(k) = "TRUE" Then flatStyle = True Else flatStyle = False
    
    btnNose pic1, False
    DrawShades pic1, flatStyle
    End Function
    
    Public Function DrawShades(p1 As PictureBox, FlatStylex As Boolean)
    
    Dim bColor As Long
    bColor = p1.BackColor
    Dim dfaultColor1 As Long, dfaultColor2 As Long, dfaultColor3 As Long, dfaultColor4 As Long
    Dim xR As Integer, xG As Integer, xB As Integer, xH As Integer, xS As Integer, xL As Integer
    
    If bColor < 1 Then
    dfaultColor1 = RGB(255, 255, 255)
    dfaultColor2 = RGB(227, 227, 227)
    dfaultColor3 = RGB(160, 160, 160)
    dfaultColor4 = RGB(105, 105, 105)
        If FlatStylex = True Then
            dfaultColor4 = dfaultColor1
        End If
    Else
    SplitRGB bColor, xR, xG, xB
    RGBtoHSL xR, xG, xB, xH, xS, xL
    
    Dim gL1, gL2, gL3, gL4 As Integer
    gL1 = xL + 45
    If gL1 < 210 Then gL1 = 210
    If gL1 > 240 Then gL1 = 240
    
    gL2 = xL + 30
    If gL2 < 180 Then gL2 = 180
    If gL2 > 240 Then gL2 = 240
    
    gL3 = xL - 30
    If gL3 > 150 Then gL3 = 150
    If gL3 < 1 Then gL3 = 0
    
    gL4 = xL - 45
    If gL3 > 135 Then gL3 = 135
    If gL4 < 0 Then gL4 = 0
    
    
    HSLtoRGB xH, xS, gL1, xR, xG, xB
    dfaultColor1 = RGB(xR, xG, xB)
    
    HSLtoRGB xH, xS, gL2, xR, xG, xB
    dfaultColor2 = RGB(xR, xG, xB)
    
    HSLtoRGB xH, xS, gL3, xR, xG, xB
    dfaultColor3 = RGB(xR, xG, xB)
    
    HSLtoRGB xH, xS, gL4, xR, xG, xB
    dfaultColor4 = RGB(xR, xG, xB)
    
        If FlatStylex = True Then
            dfaultColor4 = dfaultColor1
        End If
    End If
    
    p1.DrawWidth = 1
    p1.Line (0, 0)-(p1.Width - 15, 0), dfaultColor1
    p1.Line (0, 0)-(0, p1.Height - 15), dfaultColor1
    
    p1.Line (15, 15)-(p1.Width - 30, 15), dfaultColor2
    p1.Line (15, 15)-(15, p1.Height - 30), dfaultColor2
    
    p1.Line (15, p1.Height - 30)-(p1.Width - 30, p1.Height - 30), dfaultColor3
    p1.Line (p1.Width - 30, 15)-(p1.Width - 30, p1.Height - 15), dfaultColor3
    
    p1.Line (0, p1.Height - 15)-(p1.Width - 15, p1.Height - 15), dfaultColor4
    p1.Line (p1.Width - 15, 0)-(p1.Width - 15, p1.Height), dfaultColor4
    End Function
    
    Public Sub HSLtoRGB(ByVal Hue As Integer, ByVal Saturation As Integer, ByVal Luminance As Integer, ByRef Red As Integer, ByRef Green As Integer, ByRef Blue As Integer)
    
       ReDim temp3(0 To 2)
       Dim pHue, pSat, pLum, pRed, pGreen, pBlue, temp2, temp1, n As Double
       pHue = Hue / 240
       pSat = Saturation / 240
       pLum = Luminance / 240
    
       If pSat = 0 Then
          pRed = pLum
          pGreen = pLum
          pBlue = pLum
       Else
          If pLum < 0.5 Then
             temp2 = pLum * (1 + pSat)
          Else
             temp2 = pLum + pSat - pLum * pSat
          End If
          temp1 = 2 * pLum - temp2
       
          temp3(0) = pHue + 1 / 3
          temp3(1) = pHue
          temp3(2) = pHue - 1 / 3
          
          For n = 0 To 2
             If temp3(n) < 0 Then temp3(n) = temp3(n) + 1
             If temp3(n) > 1 Then temp3(n) = temp3(n) - 1
          
             If 6 * temp3(n) < 1 Then
                temp3(n) = temp1 + (temp2 - temp1) * 6 * temp3(n)
             Else
                If 2 * temp3(n) < 1 Then
                   temp3(n) = temp2
                Else
                   If 3 * temp3(n) < 2 Then
                      temp3(n) = temp1 + (temp2 - temp1) * ((2 / 3) - temp3(n)) * 6
                   Else
                      temp3(n) = temp1
                    End If
                 End If
              End If
           Next n
    
           pRed = temp3(0)
           pGreen = temp3(1)
           pBlue = temp3(2)
        End If
    
        Red = Int(pRed * 255)
        If Red < 1 Then Red = 0: If Red > 255 Then Red = 255
        Green = Int(pGreen * 255)
        If Green < 1 Then Green = 0: If Green > 255 Then Green = 255
        Blue = Int(pBlue * 255)
        If Blue < 1 Then Blue = 0: If Blue > 255 Then Blue = 255
    End Sub
    
    Public Sub RGBtoHSL(ByVal Red As Integer, ByVal Green As Integer, ByVal Blue As Integer, ByRef Hue As Integer, ByRef Saturation As Integer, ByRef Luminance As Integer)
    
        Dim pRed, pGreen, pBlue, pMax, pMin, pHue, pSat, pLum As Double
        'MsgBox Red & "/" & Green & "/" & Blue
        pRed = Red / 255
        pGreen = Green / 255
        pBlue = Blue / 255
       
        If pRed > pGreen Then
           If pRed > pBlue Then
              pMax = pRed
           Else
              pMax = pBlue
           End If
        ElseIf pGreen > pBlue Then
            pMax = pGreen
        Else
            pMax = pBlue
        End If
    
        If pRed < pGreen Then
            If pRed < pBlue Then
                pMin = pRed
            Else
                pMin = pBlue
            End If
        ElseIf pGreen < pBlue Then
            pMin = pGreen
        Else
            pMin = pBlue
        End If
    
        pLum = (pMax + pMin) / 2
       
        If pMax = pMin Then
            pSat = 0
            pHue = 0
        Else
            If pLum < 0.5 Then
                pSat = (pMax - pMin) / (pMax + pMin)
            Else
                pSat = (pMax - pMin) / (2 - pMax - pMin)
            End If
            Select Case pMax
                Case pRed: pHue = (pGreen - pBlue) / (pMax - pMin)
                Case pGreen: pHue = 2 + (pBlue - pRed) / (pMax - pMin)
                Case pBlue: pHue = 4 + (pRed - pGreen) / (pMax - pMin)
            End Select
        End If
    
        Hue = pHue * 240 \ 6
        If Hue < 0 Then Hue = Hue + 240
        Saturation = Int(pSat * 240)
        Luminance = Int(pLum * 240)
        
    End Sub
    
    Public Function SplitRGB(ByVal lngColor As Long, ByRef lngRed As Integer, ByRef lngGreen As Integer, ByRef lngBlue As Integer)
    
    'Converts Long Color to RGB
    lngRed = lngColor And &HFF
    lngGreen = (lngColor And &HFF00&) \ &H100&
    lngBlue = (lngColor And &HFF0000) \ &H10000
    End Function
    
    Public Function btnNose(p1 As PictureBox, downB As Boolean)
    Dim xX, yY As Integer
    Dim downX, downY, i As Integer
    Dim k As String
    i = InStr(1, p1.Tag, ";", vbBinaryCompare)
    
    k = Left(p1.Tag, i - 1)
    
    If downB = True Then
    downX = 15
    downY = 15
    Else
    downX = 0
    downY = 0
    End If
    
    xX = (p1.Width - 105) \ 2
    yY = (p1.Height - 60) \ 2
    
    xX = xX + downX
    yY = yY + downY
    
    p1.Cls
    p1.DrawWidth = 1
    p1.Line (xX, yY)-(xX + 105, yY), Val(k)
    xX = xX + 15
    yY = yY + 15
    p1.Line (xX, yY)-(xX + 75, yY), Val(k)
    xX = xX + 15
    yY = yY + 15
    p1.Line (xX, yY)-(xX + 45, yY), Val(k)
    xX = xX + 15
    yY = yY + 15
    p1.Line (xX, yY)-(xX + 15, yY), Val(k)
    End Function
    Last edited by HanneSThEGreaT; February 6th, 2015 at 06:19 AM. Reason: added code tags

  2. #2
    Join Date
    Jan 2006
    Location
    Fox Lake, IL
    Posts
    15,007

    Re: Flat Combo with custom button, border & nose color

    Is there a question somewhere in there?

    Also, open the ADVANCED TAB, and add CODE TAGS to get people to read your code.

    Code:
    ' This is code with tags
    Click the # after highlighting your code
    Code:
     / inside of the [ to close
    Last edited by dglienna; January 29th, 2015 at 03:50 AM.
    David

    CodeGuru Article: Bound Controls are Evil-VB6
    2013 Samples: MS CODE Samples

    CodeGuru Reviewer
    2006 Dell CSP
    2006, 2007 & 2008 MVP Visual Basic
    If your question has been answered satisfactorily, and it has been helpful, then, please, Rate this Post!

  3. #3
    Join Date
    Jul 2001
    Location
    Sunny South Africa
    Posts
    11,283

    Re: Flat Combo with custom button, border & nose color

    javabill, Please ask a question and do not just copy and paste your code onto this forum, expecting us to know what the problem is. Help us help you.

  4. #4
    Join Date
    Jan 2014
    Posts
    9

    Re: Flat Combo with custom button, border & nose color

    Quote Originally Posted by HanneSThEGreaT View Post
    javabill, Please ask a question and do not just copy and paste your code onto this forum, expecting us to know what the problem is. Help us help you.
    well, that is not the regular process for making a flat combo. i wish to see the reaction of the people who read that post. i also wish to know the drawbacks of that process. [every time placing a picturebox is not the matter b'cos i already made a withEvents class and call the function when form is loading]. so please tell me if there is any other drawback.

    Sorry for my english too

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  





Click Here to Expand Forum to Full Width

Featured