-
January 26th, 2015, 07:48 AM
#1
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
-
January 29th, 2015, 03:47 AM
#2
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.
-
February 6th, 2015, 06:17 AM
#3
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.
-
February 8th, 2015, 11:26 PM
#4
Re: Flat Combo with custom button, border & nose color
Originally Posted by HanneSThEGreaT
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
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|