www.pudn.com > xp_combox.zip > XPMCCombo.ctl
VERSION 5.00
Begin VB.UserControl XPMCCombo
AutoRedraw = -1 'True
ClientHeight = 780
ClientLeft = 0
ClientTop = 0
ClientWidth = 1755
BeginProperty Font
Name = "Marlett"
Size = 9.75
Charset = 2
Weight = 500
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ScaleHeight = 52
ScaleMode = 3 'Pixel
ScaleWidth = 117
ToolboxBitmap = "XPMCCombo.ctx":0000
Begin VB.TextBox Text1
BorderStyle = 0 'None
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 210
Left = 45
TabIndex = 0
Top = 45
Width = 1290
End
End
Attribute VB_Name = "XPMCCombo"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'# Email to :zhujinyong@totalise.co.uk
Option Explicit
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function GetFocus Lib "user32" () As Long
Private Declare Function IsWindowVisible Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long
Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
Private Declare Function DrawFocusRect Lib "user32" (ByVal hdc As Long, lpRect As RECT) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetRectEmpty Lib "user32" (lpRect As RECT) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function FrameRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Sub OleTranslateColor Lib "oleaut32.dll" (ByVal Clr As Long, ByVal hPal As Long, ByRef lpcolorref As Long)
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function DrawState Lib "user32" Alias "DrawStateA" _
(ByVal hdc As Long, _
ByVal hBrush As Long, _
ByVal lpDrawStateProc As Long, _
ByVal lParam As Long, _
ByVal wParam As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal cx As Long, _
ByVal cY As Long, _
ByVal fuFlags As Long) As Long
Private WithEvents m_Sniff As clsSubClass
Attribute m_Sniff.VB_VarHelpID = -1
Private Type TrackMouseEvent
cbSize As Long
dwFlags As Long
hWnd As Long
dwHoverTime As Long
End Type
Public Enum pbcStyle
pbXP = 0
pbSmart = 1
End Enum
Private Const WM_MOUSELEAVE = &H2A3
Private Const TME_LEAVE = &H2
Private Declare Function TrackMouseEvent Lib "comctl32.dll" Alias "_TrackMouseEvent" ( _
ByRef lpEventTrack As TrackMouseEvent) As Long
Private Const DST_COMPLEX = &H0
Private Const DST_TEXT = &H1
Private Const DST_PREFIXTEXT = &H2
Private Const DST_ICON = &H3
Private Const DST_BITMAP = &H4
Private Const DSS_NORMAL = &H0
Private Const DSS_UNION = &H10
Private Const DSS_DISABLED = &H20
Private Const DSS_MONO = &H80
Private Const DSS_RIGHT = &H8000
Private Const SM_CXHTHUMB = 10
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const DT_BOTTOM = &H8
Private Const DT_CENTER = &H1
Private Const DT_LEFT = &H0
Private Const DT_NOCLIP = &H100
Private Const DT_NOPREFIX = &H800
Private Const DT_RIGHT = &H2
Private Const DT_SINGLELINE = &H20
Private Const DT_TOP = &H0
Private Const DT_VCENTER = &H4
Private Const DT_WORDBREAK = &H10
Private Const m_def_Style = pbXP
Private Const m_def_FocusColor = &HC00000
Private Const m_def_ButtonFadeColor = vbWhite
Private Const m_def_Text = "XP Multi-Column Combo"
Private Const m_def_BorderColor = &HFF8080
Private Const m_def_BorderColorOver = vbHighlight
Private Const m_def_BorderColorDown = vb3DHighlight
Private Const m_def_BgColor = vbWhite
Private Const m_def_BgColorOver = vbButtonFace
Private Const m_def_BgColorDown = vbButtonFace
Private Const m_def_ButtonColor = &HFF8080 '&HD2BDB6
Private Const m_def_ButtonColorOver = &H80FF& 'vbWhite
Private Const m_def_ButtonColorDown = &HFF00& '&H800000
Private Const m_def_ButtonSize = 20
Private Const m_def_MinListHeight = 2000
Private Const m_def_BoundColumns = "0"
Private m_ColumnHeaders As Boolean
Private m_ButtonSize As Long
Private m_BorderColor As OLE_COLOR
Private m_BorderColorOver As OLE_COLOR
Private m_BorderColorDown As OLE_COLOR
Private m_BgColor As OLE_COLOR
Private m_BgColorOver As OLE_COLOR
Private m_BgColorDown As OLE_COLOR
Private m_ButtonColor As OLE_COLOR
Private m_ButtonColorOver As OLE_COLOR
Private m_ButtonColorDown As OLE_COLOR
Private m_ButtonCount As Long
Private m_Text As String
Private m_oStartColor As OLE_COLOR
Private m_oEndColor As OLE_COLOR
Dim m_ButtonFadeColor As OLE_COLOR
Dim m_FocusColor As OLE_COLOR
Dim m_Style As pbcStyle
Private UsrRect As RECT
Private ButtRect As RECT
Private Ret As Long
Private CrlRet As Long
Private IsMOver As Boolean
Private IsMDown As Boolean
Private IsButtDown As Boolean
Private IsCrlOver As Boolean
Private Clicked As Boolean
Private InFocus As Boolean
Private m_DropListEnabled As Boolean
Private IniLat As Long
Private IniLung As Long
Private m_NrColVisible As Integer ' Numbers of visible columns
Private m_ListHeight As Long
Private m_ListWidth As String 'example : 100;500;200 The first value will be ignored and she be considered the width of control
Private m_ColumnHeads As Boolean
Private lTotalWid As Long
Private NumBounds As Integer
Private m_BoundColumns As String
Event Click()
Event MouseOver()
Event MouseOut()
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyDown
Event KeyPress(KeyAscii As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyPress
Event KeyUp(KeyCode As Integer, Shift As Integer) 'MappingInfo=UserControl,UserControl,-1,KeyUp
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseDown
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseMove
Event Change()
Event DropList()
Public Sub DrawControl()
Dim Brsh As Long, Clr As Long
Dim lx As Long, ty As Long
Dim rx As Long, by As Long
Dim dR(1 To 3) As Double
Dim rct As RECT
Dim lHeight As Long, lWidth As Long
Dim lYStep As Long
Dim lY As Long
Dim bRGB(1 To 3) As Integer
Dim hBr As Long
Dim oColor As Long
Dim lcolor As Long
Dim m_RGBStartCol1(1 To 3) As Long
lx = ScaleLeft: ty = ScaleTop
rx = ScaleWidth: by = ScaleHeight
Cls
If m_Style = pbSmart Then
lHeight = (UserControl.Height + 30) \ Screen.TwipsPerPixelY
rct.Right = UserControl.Width \ Screen.TwipsPerPixelY
rct.Bottom = lHeight
FadeColor m_oStartColor, rct, m_oEndColor
Else
'control Backgound
Call SetRect(UsrRect, 0, 0, rx - m_ButtonSize, by)
Call OleTranslateColor(m_BgColor, ByVal 0&, Clr)
Brsh = CreateSolidBrush(Clr)
Call FillRect(hdc, UsrRect, Brsh)
DeleteObject Brsh
End If
'Button
Call SetRect(ButtRect, rx - m_ButtonSize, 0, rx, by)
If m_Style = pbXP Then
If IsMDown Then
Call OleTranslateColor(m_ButtonColorDown, ByVal 0&, Clr)
ElseIf IsMOver Then
Call OleTranslateColor(m_ButtonColorOver, ByVal 0&, Clr)
Else
Call OleTranslateColor(m_ButtonColor, ByVal 0&, Clr)
End If
Brsh = CreateSolidBrush(Clr)
Call FillRect(hdc, ButtRect, Brsh)
DeleteObject Brsh
Else
SetRect rct, rx - m_ButtonSize, 0, rx, by
If IsMDown Then
Call FadeColor(m_ButtonColorDown, rct, m_ButtonFadeColor)
ElseIf IsMOver Then
Call FadeColor(m_ButtonColorOver, rct, m_ButtonFadeColor)
End If
SetRectEmpty rct
End If
'Borders
If IsMDown Then
Call OleTranslateColor(m_BorderColorDown, ByVal 0&, Clr)
ElseIf IsMOver Then
Call OleTranslateColor(m_BorderColorOver, ByVal 0&, Clr)
ElseIf InFocus Then
Call OleTranslateColor(m_FocusColor, ByVal 0&, Clr)
Else
Call OleTranslateColor(m_BorderColor, ByVal 0&, Clr)
End If
Brsh = CreateSolidBrush(Clr)
Call FrameRect(hdc, ButtRect, Brsh)
DeleteObject Brsh
Call SetRect(UsrRect, 0, 0, rx, by)
Brsh = CreateSolidBrush(Clr)
Call FrameRect(hdc, UsrRect, Brsh)
DeleteObject Brsh
Call DrawText(hdc, "6", 1&, ButtRect, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
Call SetRectEmpty(UsrRect)
'# Whether Hide Listview's column Header?
'Note : You can't put those rungs in other Routine either showpopup or load_rs_to_lsw.
'Because DrawControl is Executed before them.
If m_ColumnHeaders = False Then
HideColumnHeaders = True
Else
HideColumnHeaders = False
End If
End Sub
Private Sub Text1_Change()
m_Text = Text1.text
RaiseEvent Change
End Sub
Private Sub Text1_GotFocus()
InFocus = True
Call DrawControl
End Sub
Private Sub Text1_LostFocus()
InFocus = False
Call DrawControl
End Sub
Private Sub UserControl_Initialize()
Set m_Sniff = New clsSubClass
m_Sniff.SubClassHwnd UserControl.hWnd, True
End Sub
Private Sub UserControl_Terminate()
m_Sniff.SubClassHwnd UserControl.hWnd, False
End Sub
Private Sub UserControl_LostFocus()
InFocus = False
End Sub
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseMove(Button, Shift, X, Y)
If Not Clicked Then
UserControl_MouseOut
End If
End Sub
Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If m_DropListEnabled = True Then
IsButtDown = False
Call DrawControl
If (X >= ButtRect.Left And X <= ButtRect.Right) And (Y >= ButtRect.Top And Y <= ButtRect.Bottom) Then
Call ShowPopup(1)
Else
Call ShowPopup(0)
Unload frmpopup
End If
End If
End Sub
Private Sub UserControl_Resize()
On Error Resume Next
Text1.Move 2, (ScaleHeight / 2) - (Text1.Height / 2), ScaleWidth - 3 - m_def_ButtonSize
Call DrawControl
End Sub
Function UserControl_MouseOut()
Dim tTrackMouseEvent As TrackMouseEvent
If Not IsMOver Then
With tTrackMouseEvent
.cbSize = Len(tTrackMouseEvent)
.dwFlags = TME_LEAVE
.hWnd = UserControl.hWnd
End With
RaiseEvent MouseOver
TrackMouseEvent tTrackMouseEvent
IsMOver = True
End If
Call DrawControl
End Function
Private Sub m_Sniff_NewMessage( _
ByVal hWnd As Long, _
uMsg As Long, _
wParam As Long, _
lParam As Long, _
Cancel As Boolean)
Select Case uMsg
Case WM_MOUSELEAVE
IsMOver = False
RaiseEvent MouseOut
Call DrawControl
End Select
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get BorderColor() As OLE_COLOR
BorderColor = m_BorderColor
End Property
Public Property Let BorderColor(ByVal New_BorderColor As OLE_COLOR)
m_BorderColor = New_BorderColor
PropertyChanged "BorderColor"
Call DrawControl
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get BorderColorOver() As OLE_COLOR
BorderColorOver = m_BorderColorOver
End Property
Public Property Let BorderColorOver(ByVal New_BorderColorOver As OLE_COLOR)
m_BorderColorOver = New_BorderColorOver
PropertyChanged "BorderColorOver"
Call DrawControl
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get BorderColorDown() As OLE_COLOR
BorderColorDown = m_BorderColorDown
End Property
Public Property Let BorderColorDown(ByVal New_BorderColorDown As OLE_COLOR)
m_BorderColorDown = New_BorderColorDown
PropertyChanged "BorderColorDown"
Call DrawControl
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get BgColor() As OLE_COLOR
BgColor = m_BgColor
End Property
Public Property Let BgColor(ByVal New_BgColor As OLE_COLOR)
m_BgColor = New_BgColor
PropertyChanged "BgColor"
Call DrawControl
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get BgColorOver() As OLE_COLOR
BgColorOver = m_BgColorOver
End Property
Public Property Let BgColorOver(ByVal New_BgColorOver As OLE_COLOR)
m_BgColorOver = New_BgColorOver
PropertyChanged "BgColorOver"
Call DrawControl
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get BgColorDown() As OLE_COLOR
BgColorDown = m_BgColorDown
End Property
Public Property Let BgColorDown(ByVal New_BgColorDown As OLE_COLOR)
m_BgColorDown = New_BgColorDown
PropertyChanged "BgColorDown"
Call DrawControl
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get ButtonColor() As OLE_COLOR
ButtonColor = m_ButtonColor
End Property
Public Property Let ButtonColor(ByVal New_ButtonColor As OLE_COLOR)
m_ButtonColor = New_ButtonColor
PropertyChanged "ButtonColor"
Call DrawControl
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get ButtonColorOver() As OLE_COLOR
ButtonColorOver = m_ButtonColorOver
End Property
Public Property Let ButtonColorOver(ByVal New_ButtonColorOver As OLE_COLOR)
m_ButtonColorOver = New_ButtonColorOver
PropertyChanged "ButtonColorOver"
Call DrawControl
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=10,0,0,0
Public Property Get ButtonColorDown() As OLE_COLOR
ButtonColorDown = m_ButtonColorDown
End Property
Public Property Let ButtonColorDown(ByVal New_ButtonColorDown As OLE_COLOR)
m_ButtonColorDown = New_ButtonColorDown
PropertyChanged "ButtonColorDown"
Call DrawControl
End Property
Public Property Get ColumnHeaders() As Boolean
ColumnHeaders = m_ColumnHeaders
End Property
Public Property Let ColumnHeaders(ByVal New_ColumnHeaders As Boolean)
m_ColumnHeaders = New_ColumnHeaders
PropertyChanged "ColumnHeaders"
End Property
'Initialize Properties for User Control
Private Sub UserControl_InitProperties()
Dim lcolor As Long
Dim oColor As Long
m_BorderColor = m_def_BorderColor
m_BorderColorOver = RGB(10, 36, 106)
m_BorderColorDown = RGB(10, 36, 106)
m_BgColor = m_def_BgColor
m_BgColorOver = m_def_BorderColorOver
m_BgColorDown = RGB(133, 146, 181)
m_ButtonColor = RGB(219, 216, 209)
m_ButtonColorOver = RGB(182, 189, 210)
m_ButtonColorDown = m_def_ButtonColorDown
m_BorderColorOver = m_def_BorderColorOver
m_ButtonSize = m_def_ButtonSize
m_Text = m_def_Text
m_ColumnHeaders = True
m_ListHeight = 3070
m_oStartColor = vbWhite
m_oEndColor = vbButtonFace
m_Style = m_def_Style
m_FocusColor = m_def_FocusColor
m_ButtonFadeColor = m_def_ButtonFadeColor
m_DropListEnabled = True
Call DrawControl
End Sub
'Load property values from storage
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
IniLat = Height
IniLung = Width
m_BorderColor = PropBag.ReadProperty("BorderColor", m_def_BorderColor)
m_BorderColorOver = PropBag.ReadProperty("BorderColorOver", m_def_BorderColorOver)
m_BorderColorDown = PropBag.ReadProperty("BorderColorDown", m_def_BorderColorDown)
m_BgColor = PropBag.ReadProperty("BgColor", m_def_BgColor)
m_BgColorOver = PropBag.ReadProperty("BgColorOver", m_def_BgColorOver)
m_BgColorDown = PropBag.ReadProperty("BgColorDown", m_def_BgColorDown)
m_ButtonColor = PropBag.ReadProperty("ButtonColor", m_def_ButtonColor)
m_ButtonColorOver = PropBag.ReadProperty("ButtonColorOver", m_def_ButtonColorOver)
m_ButtonColorDown = PropBag.ReadProperty("ButtonColorDown", m_def_ButtonColorDown)
m_ButtonSize = PropBag.ReadProperty("ButtonSize", m_def_ButtonSize)
m_Text = PropBag.ReadProperty("Text", m_def_Text)
Text1.text = m_Text
m_NrColVisible = PropBag.ReadProperty("NrColVisible", 1)
m_ListHeight = PropBag.ReadProperty("ListHeight", 3070)
m_ListWidth = PropBag.ReadProperty("ListWidth", "100")
m_BoundColumns = PropBag.ReadProperty("m_BoundColumns", "0")
bgBottomColor = PropBag.ReadProperty("bgBottomColor", vbWhite)
bgTopColor = PropBag.ReadProperty("bgTopColor", vbButtonFace)
m_Style = PropBag.ReadProperty("Style", m_def_Style)
m_FocusColor = PropBag.ReadProperty("FocusColor", m_def_FocusColor)
m_ButtonFadeColor = PropBag.ReadProperty("ButtonFadeColor", m_def_ButtonFadeColor)
Text1.ForeColor = PropBag.ReadProperty("Text_ForeColor", &H80000008)
Text1.Enabled = PropBag.ReadProperty("Text_Enabled", True)
Text1.Locked = PropBag.ReadProperty("Text_Locked", False)
m_DropListEnabled = PropBag.ReadProperty("DropListEnabled", True)
m_ColumnHeaders = PropBag.ReadProperty("ColumnHeaders", True)
Call DrawControl
End Sub
'Write property values to storage
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("BorderColor", m_BorderColor, m_def_BorderColor)
Call PropBag.WriteProperty("BorderColorOver", m_BorderColorOver, m_def_BorderColorOver)
Call PropBag.WriteProperty("BorderColorDown", m_BorderColorDown, m_def_BorderColorDown)
Call PropBag.WriteProperty("BgColor", m_BgColor, m_def_BgColor)
Call PropBag.WriteProperty("BgColorOver", m_BgColorOver, m_def_BgColorOver)
Call PropBag.WriteProperty("BgColorDown", m_BgColorDown, m_def_BgColorDown)
Call PropBag.WriteProperty("ButtonColor", m_ButtonColor, m_def_ButtonColor)
Call PropBag.WriteProperty("ButtonColorOver", m_ButtonColorOver, m_def_ButtonColorOver)
Call PropBag.WriteProperty("ButtonColorDown", m_ButtonColorDown, m_def_ButtonColorDown)
Call PropBag.WriteProperty("ButtonSize", m_ButtonSize, m_def_ButtonSize)
Call PropBag.WriteProperty("Text", m_Text, m_def_Text)
Call PropBag.WriteProperty("FocusColor", m_FocusColor, m_def_FocusColor)
Call PropBag.WriteProperty("bgBottomColor", bgBottomColor, vbWhite)
Call PropBag.WriteProperty("bgTopColor", bgTopColor, vbButtonFace)
Call PropBag.WriteProperty("ButtonFadeColor", m_ButtonFadeColor, m_def_ButtonFadeColor)
Call PropBag.WriteProperty("Style", m_Style, m_def_Style)
Call PropBag.WriteProperty("NrColVisible", m_NrColVisible, 1)
Call PropBag.WriteProperty("ListHeight", m_ListHeight, 3070)
Call PropBag.WriteProperty("ListWidth", m_ListWidth, "100")
Call PropBag.WriteProperty("BoundColumns", m_BoundColumns, "0")
Call PropBag.WriteProperty("ColumnHeaders", m_ColumnHeaders, True)
Call PropBag.WriteProperty("Text_ForeColor", Text1.ForeColor, &H80000008)
Call PropBag.WriteProperty("Text_Enabled", Text1.Enabled, True)
Call PropBag.WriteProperty("Text_Locked", Text1.Locked, False)
Call PropBag.WriteProperty("DropListEnabled", m_DropListEnabled, True)
End Sub
Private Sub UserControl_Click()
RaiseEvent Click
End Sub
Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyDown(KeyCode, Shift)
End Sub
Private Sub UserControl_KeyPress(KeyAscii As Integer)
RaiseEvent KeyPress(KeyAscii)
End Sub
Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
RaiseEvent KeyUp(KeyCode, Shift)
End Sub
Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
RaiseEvent MouseDown(Button, Shift, X, Y)
IsButtDown = True
End Sub
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MemberInfo=8,0,0,0
Public Property Get ButtonSize() As Long
ButtonSize = m_ButtonSize
End Property
Public Property Let ButtonSize(ByVal New_ButtonSize As Long)
m_ButtonSize = New_ButtonSize
PropertyChanged "ButtonSize"
Call DrawControl
End Property
Public Sub ShowPopup(Show As Integer)
If Show = 0 And IsWindowVisible(frmpopup.hWnd) = 0 Then
GoTo ShowDropDown_Exit
ElseIf Show = 1 And (IsWindowVisible(frmpopup.hWnd) <> 0 Or m_DropListEnabled = False) Then
GoTo ShowDropDown_Exit
End If
If Show Then
Dim ClrPos As RECT
Dim crx As Long
Call GetWindowRect(hWnd, ClrPos)
IsMDown = True
IsCrlOver = True
Call DrawControl
RaiseEvent DropList
With frmpopup
.Left = ClrPos.Left * Screen.TwipsPerPixelX
.Top = ClrPos.Bottom * Screen.TwipsPerPixelY
.BackColor = m_BgColor
.lsw.BackColor = m_BgColor
.isclick = False
.lsw.Width = lTotalWid
.lsw.Height = m_ListHeight
.selectedtext = Text1.text
If (.Top + .Height) > Screen.Height Then
.Top = ClrPos.Top * Screen.TwipsPerPixelY - .Height
End If
'Compensate Width based on 800by600 Pixes.
Dim cWidth As Long
cWidth = 0
If NumBounds < 3 Then
If NumBounds = 1 Then cWidth = 190
If NumBounds = 2 Then cWidth = 100
Else
cWidth = 0
End If
.Width = lTotalWid + (NumBounds * 380) + cWidth
If m_ListHeight <= 2000 Then
m_ListHeight = 2000
End If
'Check whether ColumnHeader is on or Hide
If m_ColumnHeaders = False Then
.Height = m_ListHeight - 270
Else
.Height = m_ListHeight + 10
End If
'Modal Mode
.Show 1
If .isclick Then
Text1.text = .selectedtext
End If
Unload frmpopup
End With
IsMDown = False
IsCrlOver = False
Call DrawControl
End If
ShowDropDown_Exit:
Exit Sub
End Sub
Public Property Get text() As String
text = m_Text
End Property
Public Property Let text(ByVal New_Text As String)
m_Text = New_Text
Text1.text = m_Text
PropertyChanged "Text"
End Property
Public Property Get Text_ForeColor() As OLE_COLOR
Text_ForeColor = Text1.ForeColor
End Property
Public Property Let Text_ForeColor(ByVal Text_New_ForeColor As OLE_COLOR)
Text1.ForeColor() = Text_New_ForeColor
PropertyChanged "Text_ForeColor"
End Property
Public Property Get Text_Enabled() As Boolean
Text_Enabled = Text1.Enabled
End Property
Public Property Let Text_Enabled(ByVal Text_New_Enabled As Boolean)
Text1.Enabled() = Text_New_Enabled
PropertyChanged "Text_Enabled"
End Property
Public Property Get Text_Locked() As Boolean
Text_Locked = Text1.Locked
End Property
Public Property Let Text_Locked(ByVal Text_New_Locked As Boolean)
Text1.Locked() = Text_New_Locked
PropertyChanged "Text_Locked"
End Property
Public Property Get NrColVisible() As Long
NrColVisible = m_NrColVisible
End Property
Public Property Let NrColVisible(New_NrColVisible As Long)
m_NrColVisible = New_NrColVisible
PropertyChanged "NrColVisible"
End Property
Public Property Get ListHeight() As Long
ListHeight = m_ListHeight
End Property
Public Property Let ListHeight(New_ListHeight As Long)
m_ListHeight = New_ListHeight
PropertyChanged "ListHeight"
End Property
Public Property Get ListWidth() As String
ListWidth = m_ListWidth
End Property
Public Property Let ListWidth(New_ListWidth As String)
m_ListWidth = New_ListWidth
PropertyChanged "ListWidth"
End Property
Public Property Get BoundColumns() As String
BoundColumns = m_BoundColumns
End Property
Public Property Let BoundColumns(New_BoundColumns As String)
m_BoundColumns = New_BoundColumns
PropertyChanged "BoundColumns"
End Property
'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
'MappingInfo=UserControl,UserControl,-1,DropListEnabled
Public Property Get DropListEnabled() As Boolean
DropListEnabled = m_DropListEnabled
End Property
Public Property Let DropListEnabled(ByVal New_DropListEnabled As Boolean)
m_DropListEnabled = New_DropListEnabled
PropertyChanged "DropListEnabled"
End Property
Public Property Get bgBottomColor() As OLE_COLOR
bgBottomColor = m_oStartColor
End Property
Public Property Let bgBottomColor(ByVal oColor As OLE_COLOR)
Dim lcolor As Long
If (m_oStartColor <> oColor) Then
m_oStartColor = oColor
DrawControl
End If
End Property
Public Property Get bgTopColor() As OLE_COLOR
bgTopColor = m_oEndColor
End Property
Public Property Let bgTopColor(ByVal oColor As OLE_COLOR)
Dim lcolor As Long
If (m_oEndColor <> oColor) Then
m_oEndColor = oColor
DrawControl
End If
End Property
Public Property Get Style() As pbcStyle
Style = m_Style
End Property
Public Property Let Style(ByVal New_Style As pbcStyle)
m_Style = New_Style
PropertyChanged "Style"
DrawControl
End Property
Public Property Get FocusColor() As OLE_COLOR
FocusColor = m_FocusColor
End Property
Public Property Let FocusColor(ByVal New_FocusColor As OLE_COLOR)
m_FocusColor = New_FocusColor
PropertyChanged "FocusColor"
DrawControl
End Property
Public Property Get ButtonFadeColor() As OLE_COLOR
ButtonFadeColor = m_ButtonFadeColor
End Property
Public Property Let ButtonFadeColor(ByVal New_ButtonFadeColor As OLE_COLOR)
m_ButtonFadeColor = New_ButtonFadeColor
PropertyChanged "ButtonFadeColor"
End Property
Private Sub FadeColor(oColor As Long, rct As RECT, obcolor As Long)
Dim plWidth As Long
Dim lFlags As Long
Dim dR(1 To 3) As Double
Dim lHeight As Long, lWidth As Long
Dim lYStep As Long
Dim lY As Long
Dim bRGB(1 To 3) As Integer
Dim hBr As Long
Dim m_RGBStartCol1(1 To 3) As Long
Dim m_RGBEndCol1(1 To 3) As Long
Dim lcolor As Long
OleTranslateColor oColor, 0, lcolor
m_RGBStartCol1(1) = lcolor And &HFF&
m_RGBStartCol1(2) = ((lcolor And &HFF00&) \ &H100)
m_RGBStartCol1(3) = ((lcolor And &HFF0000) \ &H10000)
OleTranslateColor obcolor, 0, lcolor
m_RGBEndCol1(1) = lcolor And &HFF&
m_RGBEndCol1(2) = ((lcolor And &HFF00&) \ &H100)
m_RGBEndCol1(3) = ((lcolor And &HFF0000) \ &H10000)
lHeight = ScaleHeight
lYStep = lHeight \ 255
If (lYStep = 0) Then
lYStep = 1
End If
bRGB(1) = m_RGBStartCol1(1)
bRGB(2) = m_RGBStartCol1(2)
bRGB(3) = m_RGBStartCol1(3)
dR(1) = m_RGBEndCol1(1) - m_RGBStartCol1(1)
dR(2) = m_RGBEndCol1(2) - m_RGBStartCol1(2)
dR(3) = m_RGBEndCol1(3) - m_RGBStartCol1(3)
For lY = lHeight To 0 Step -lYStep
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
bRGB(1) = m_RGBStartCol1(1) + dR(1) * (lHeight - lY) / lHeight
bRGB(2) = m_RGBStartCol1(2) + dR(2) * (lHeight - lY) / lHeight
bRGB(3) = m_RGBStartCol1(3) + dR(3) * (lHeight - lY) / lHeight
Next lY
End Sub
Public Sub load_rs_to_lsw(ByVal lswcbo_rs As Recordset)
Dim vbook
Dim chk_book As Boolean
Dim rs_opened As Boolean
Dim col_length As Integer
Dim itemx
Dim i As Integer
Dim col_turn As Integer
Dim intCount As Integer
If lswcbo_rs.state = 0 Then
rs_opened = True
lswcbo_rs.Open
Else
rs_opened = False
End If
'-------------------------------------------------
'# Deal Users input worng numbers of Bounding Columns
'Clear 0,numbers of Bounding Columns
NumBounds = 0
'Calculate how many Fields in Recordset
intCount = lswcbo_rs.Fields.Count
Dim lWid() As Long
Dim substr() As String
Dim SubStrCount As Integer
SubStrCount = 0
ReDim substr(0 To 10) As String
SubStrCount = DespartireSTR(substr(), m_ListWidth, ";")
Dim strsplit() As String
Dim StrBoundColumns As Integer
StrBoundColumns = 0
ReDim strsplit(0 To 10) As String
StrBoundColumns = DespartireSTR(strsplit(), m_BoundColumns, ";")
Dim m As Integer
Dim intsplit() As Integer
ReDim intsplit(0 To 10) As Integer
'# Check whether user set visible bounding columns are
' over total fields (XPMCCombo1.NrColVisible = 4 but intCount is
' only 3)
If m_NrColVisible > 0 Then
If m_NrColVisible >= intCount Then
NumBounds = intCount
Else
NumBounds = m_NrColVisible
End If
Else
NumBounds = 1
End If
'# Check whether user set visible bounding columns are
' over total fields (XPMCCombo1.ListWidth = "200;1800;1000;1000",StrBoundColumns=4
' but intCount has only 3,intCount=3)
If StrBoundColumns > 0 Then
If StrBoundColumns >= intCount Then
StrBoundColumns = intCount
End If
Else
StrBoundColumns = 1
End If
'# converter string to interger
For m = 1 To StrBoundColumns
intsplit(m) = CInt(Val(strsplit(m)))
'# Override the fault when user input illegal setting
' such as XPMCCombo1.BoundColumns = "2;0;4;" but total fields only
' have 3(that is:intcount=3)
If intsplit(m) > intCount Then intsplit(m) = intCount
Next m
If NumBounds >= StrBoundColumns Then
NumBounds = StrBoundColumns
End If
Dim iCt As Integer
iCt = NumBounds - 1
ReDim lWid(0 To iCt)
lTotalWid = 0
For i = 1 To iCt
lWid(i) = Val(substr(i + 1))
lTotalWid = lTotalWid + lWid(i)
Next
lTotalWid = lTotalWid + IniLung - 290
'-------------------------------------------------
With lswcbo_rs
If check_bookmarkable(lswcbo_rs) = True Then
chk_book = True
vbook = .Bookmark
Else
chk_book = False
End If
frmpopup.lsw.ColumnHeaders.Clear
'# no Records ?
If NoOfRecs(lswcbo_rs) = 0 Then
For i = 0 To iCt
If i <> 0 Then
frmpopup.lsw.ColumnHeaders.Add , , .Fields(intsplit(i + 1)).Name, lWid(i)
Else
'# First Column
frmpopup.lsw.ColumnHeaders.Add , , .Fields(intsplit(1)).Name, IniLung - 290
End If
Next
'# Compensate Listview width
lTotalWid = lTotalWid - NumBounds * 80
If rs_opened = True Then .Close
Exit Sub
End If
If NoOfRecs(lswcbo_rs) <= 13 And NoOfRecs(lswcbo_rs) > 0 Then
'# Based on Default m_ListHeight=3070 and 800x600 pixes,about 13 Rows.
'# Compensate and adjust Listview width
lTotalWid = lTotalWid - NumBounds * 80
ElseIf NoOfRecs(lswcbo_rs) > 13 Then lTotalWid = lTotalWid
End If
For i = 0 To iCt
If i <> 0 Then
frmpopup.lsw.ColumnHeaders.Add , , .Fields(intsplit(i + 1)).Name, lWid(i)
Else
'# First Column
frmpopup.lsw.ColumnHeaders.Add , , .Fields(intsplit(1)).Name, IniLung - 290
End If
Next
frmpopup.lsw.ListItems.Clear
.MoveFirst
Do Until .EOF
Set itemx = frmpopup.lsw.ListItems.Add(, , .Fields(intsplit(1)))
If iCt > 0 Then
Dim h As Integer
For h = 1 To iCt
itemx.SubItems(h) = .Fields(intsplit(h + 1))
Next
End If
.MoveNext
Loop
'---------------------------------------------------
If chk_book = True Then .Bookmark = vbook
If rs_opened = True Then .Close
'---------------------------------------------------
End With
End Sub
Private Function DespartireSTR(SubStrs() As String, ByVal SrcStr As String, _
ByVal Delimiter As String) As Integer
ReDim SubStrs(0) As String
Dim CurPos As Long
Dim NextPos As Long
Dim DelLen As Integer
Dim nCount As Integer
Dim TStr As String
CurPos = 0
NextPos = 0
DelLen = 0
nCount = 0
TStr = ""
SrcStr = Delimiter & SrcStr & Delimiter
DelLen = Len(Delimiter)
nCount = 0
CurPos = 1
NextPos = InStr(CurPos + DelLen, SrcStr, Delimiter)
Do Until NextPos = 0
TStr = Mid$(SrcStr, CurPos + DelLen, NextPos - CurPos - DelLen)
nCount = nCount + 1
ReDim Preserve SubStrs(nCount) As String
SubStrs(nCount) = TStr
CurPos = NextPos
NextPos = InStr(CurPos + DelLen, SrcStr, Delimiter)
Loop
DespartireSTR = nCount
End Function
Private Function check_bookmarkable(chk_rs As Recordset) As Boolean
If chk_rs.EOF = True Or chk_rs.BOF = True Then check_bookmarkable = False Else check_bookmarkable = True
End Function
Private Function NoOfRecs(Rs As ADODB.Recordset) As Integer
On Error GoTo NoOfRecs_Err
If Rs Is Nothing Then
NoOfRecs = 0
Else
NoOfRecs = Rs.RecordCount
End If
NoOfRecs_Exit:
Exit Function
NoOfRecs_Err:
MsgBox Err.Description, vbCritical, "NoOfRecs"
Resume NoOfRecs_Exit
End Function