vbAccelerator - Contents of code file: Test.frm
VERSION 5.00
Object = "{72D18DD4-0DA7-11D2-8E21-00B404C10000}#2.3#0"; "vbalODCL.ocx"
Begin VB.Form frmTest
Caption = "Owner Draw Combo and List Box Tester"
ClientHeight = 8475
ClientLeft = 2565
ClientTop = 1785
ClientWidth = 6975
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "Test.frx":0000
LinkTopic = "Form1"
ScaleHeight = 8475
ScaleWidth = 6975
Begin VB.CommandButton cmdTestForm
Caption = "MDI Test Form"
Height = 435
Left = 2460
TabIndex = 9
Top = 6060
Width = 1215
End
Begin VB.CheckBox chkEmpty
Caption = "&Empty"
Height = 195
Left = 1440
TabIndex = 7
Top = 4440
Width = 2235
End
Begin ODCboLst.OwnerDrawComboList cboFonts
Height = 360
Left = 60
TabIndex = 6
Top = 3900
Width = 3615
_ExtentX = 6376
_ExtentY = 582
Sorted = -1 'True
ExtendedUI = -1 'True
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = -2147483630
ClientDraw = 7
Style = 0
End
Begin VB.CommandButton cmdSetFocus
Caption = "Set Focus v"
Height = 435
Left = 5760
TabIndex = 11
Top = 6060
Width = 1095
End
Begin VB.Timer tmrFocus
Interval = 250
Left = 3900
Top = 5880
End
Begin ODCboLst.OwnerDrawComboList lstMultiSelect
Height = 1755
Left = 4020
TabIndex = 15
Top = 4080
Width = 2835
_ExtentX = 5001
_ExtentY = 3096
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = -2147483630
ClientDraw = 1
Style = 6
MaxLength = 0
End
Begin ODCboLst.OwnerDrawComboList cboCursors
Height = 360
Left = 4020
TabIndex = 13
Top = 2940
Width = 2895
_ExtentX = 5106
_ExtentY = 635
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Arial"
Size = 9.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = -2147483630
Style = 0
Enabled = 0 'False
NoGrayWhenDisabled= -1 'True
End
Begin ODCboLst.OwnerDrawComboList lstSysColours
Height = 1995
Left = 3960
TabIndex = 12
Top = 300
Width = 2955
_ExtentX = 5212
_ExtentY = 3519
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = -2147483630
ClientDraw = 5
Style = 4
MaxLength = 0
End
Begin ODCboLst.OwnerDrawComboList cboSysColor
Height = 360
Left = 60
TabIndex = 0
Top = 300
Width = 2055
_ExtentX = 3625
_ExtentY = 556
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = -2147483630
ClientDraw = 5
MaxLength = 0
End
Begin ODCboLst.OwnerDrawComboList cboColorPicker
Height = 360
Left = 60
TabIndex = 3
Top = 1500
Width = 1995
_ExtentX = 3519
_ExtentY = 556
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = -2147483630
ClientDraw = 3
MaxLength = 0
End
Begin ODCboLst.OwnerDrawComboList cboStyles
Height = 360
Left = 60
TabIndex = 5
Top = 3000
Width = 3555
_ExtentX = 6271
_ExtentY = 582
ExtendedUI = -1 'True
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = -2147483630
ClientDraw = 6
Style = 0
End
Begin ODCboLst.OwnerDrawComboList lstCheck
Height = 1335
Left = 60
TabIndex = 8
Top = 4680
Width = 3615
_ExtentX = 6376
_ExtentY = 2355
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = -2147483630
Style = 7
MaxLength = 0
End
Begin ODCboLst.OwnerDrawComboList lstMultiCol
Height = 1875
Left = 60
TabIndex = 10
Top = 6540
Width = 6795
_ExtentX = 11986
_ExtentY = 3307
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Style = 4
MaxLength = 0
End
Begin VB.CheckBox chkEnabled
Caption = "&Enabled"
Enabled = 0 'False
Height = 195
Left = 4020
TabIndex = 16
Top = 5880
Width = 2835
End
Begin VB.CheckBox chkShowNames
Caption = "&Show Names"
Height = 255
Left = 60
TabIndex = 4
Top = 1920
Value = 1 'Checked
Width = 1995
End
Begin VB.PictureBox picColorSample
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 855
Left = 2100
ScaleHeight = 795
ScaleWidth = 915
TabIndex = 22
TabStop = 0 'False
Top = 1500
Width = 975
End
Begin VB.CheckBox chkVisible
Caption = "Selection &Invisible"
Height = 195
Left = 60
TabIndex = 2
Top = 720
Width = 1875
End
Begin VB.CommandButton cmdLoad
Caption = "&Load..."
Height = 375
Left = 4020
TabIndex = 14
Top = 3480
Width = 1035
End
Begin VB.CommandButton cmdShow
Caption = "v"
Height = 375
Left = 3180
TabIndex = 1
Top = 300
Width = 375
End
Begin VB.PictureBox picSample
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 855
Left = 2160
ScaleHeight = 795
ScaleWidth = 915
TabIndex = 17
TabStop = 0 'False
Top = 300
Width = 975
End
Begin VB.Label lblFocus
Caption = "x"
Height = 315
Left = 3900
TabIndex = 28
Top = 6300
Width = 1035
End
Begin VB.Label lblInfo
Caption = "Multi Column List Box:"
Height = 195
Index = 5
Left = 60
TabIndex = 27
Top = 6300
Width = 3615
End
Begin VB.Label lblInfo
Caption = "Checked List Box:"
Height = 195
Index = 4
Left = 60
TabIndex = 26
Top = 4440
Width = 3135
End
Begin VB.Label lblInfo
Caption = "Font Chooser Combo with Auto-Complete and ExtendedUI
(Down Arrow key drops):"
Height = 435
Index = 3
Left = 60
TabIndex = 25
Top = 3480
Width = 3615
End
Begin VB.Label lblInfo
Caption = "As a Multi Select List Box:"
Height = 195
Index = 8
Left = 4020
TabIndex = 24
Top = 3840
Width = 2775
End
Begin VB.Label lblInfo
Caption = "Default Draw Using Imagelist. Auto-Complete combo
box which doesn't gray when disabled."
Height = 615
Index = 7
Left = 4020
TabIndex = 23
Top = 2340
Width = 2775
End
Begin VB.Label lblInfo
Caption = "Colour Picker Combo:"
Height = 195
Index = 1
Left = 60
TabIndex = 21
Top = 1260
Width = 3075
End
Begin VB.Label lblInfo
Caption = "Sys Colour Picker as a List Box:"
Height = 195
Index = 6
Left = 3960
TabIndex = 20
Top = 60
Width = 2775
End
Begin VB.Label lblInfo
Caption = "Paragraph Style Chooser with Auto-Complete and
ExtendedUI (Down Arrow key drops):"
Height = 435
Index = 2
Left = 120
TabIndex = 19
Top = 2580
Width = 3495
End
Begin VB.Label lblInfo
Caption = "Sys Colour Picker as a ComboBox:"
Height = 195
Index = 0
Left = 60
TabIndex = 18
Top = 60
Width = 3075
End
End
Attribute VB_Name = "frmTest"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA"
(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
Long) As Long
Private Const LB_SETHORIZONTALEXTENT = &H194
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long
Private Sub AddStyles()
Dim sFnt As New StdFont, lHeight As Long
lHeight = 32
With cboStyles
sFnt.Name = "Arial"
sFnt.Size = 14
sFnt.Bold = True
sFnt.Italic = False
Set Me.Font = sFnt
.AddItemAndData "Heading 1", , 8, , , sFnt.Size, , lHeight, , eixVCentre,
sFnt
sFnt.Name = "Arial"
sFnt.Size = 12
sFnt.Bold = False
sFnt.Italic = True
Set Me.Font = sFnt
.AddItemAndData "Heading 2", , 8, , , sFnt.Size, , lHeight, , eixVCentre,
sFnt
sFnt.Name = "Arial"
sFnt.Size = 10
sFnt.Bold = True
sFnt.Italic = False
Set Me.Font = sFnt
.AddItemAndData "Heading 3", , 8, , , sFnt.Size, , lHeight, , eixVCentre,
sFnt
sFnt.Name = "Times New Roman"
sFnt.Size = 10
sFnt.Bold = False
sFnt.Italic = False
Set Me.Font = sFnt
.AddItemAndData "Normal", , 8, , , sFnt.Size, , lHeight, , eixVCentre,
sFnt
.AddItemAndData "Centred", , 8, , , sFnt.Size, , lHeight, eixCentre,
eixVCentre, sFnt
sFnt.Name = "Courier New"
sFnt.Size = 8
sFnt.Bold = False
sFnt.Italic = False
Set Me.Font = sFnt
.AddItemAndData "Code", , 8, , , sFnt.Size, , lHeight, , eixVCentre, sFnt
sFnt.Name = "Arial"
sFnt.Size = 10
sFnt.Bold = False
sFnt.Italic = False
sFnt.Underline = True
Set Me.Font = sFnt
.AddItemAndData "Followed Hyperlink", , 8, &H800080, , sFnt.Size, ,
lHeight, , eixVCentre, sFnt
.AddItemAndData "Hyperlink", , 8, &HFF0000, , sFnt.Size, , lHeight, ,
eixVCentre, sFnt
.DoAutoComplete = True
.AutoCompleteListItemsOnly = True
End With
End Sub
Private Sub cboColorPicker_Click()
picColorSample.BackColor =
cboColorPicker.ItemBackColor(cboColorPicker.ListIndex)
End Sub
Private Sub cboCursors_Change()
Debug.Print "cboCursors_Change", cboCursors.Text
End Sub
Private Sub cboCursors_Click()
Debug.Print "cboCursors_Click"
End Sub
Private Sub cboCursors_GotFocus()
Debug.Print "cboCursors:LostFocus"
End Sub
Private Sub cboCursors_KeyDown(KeyCode As Integer, Shift As Integer)
Debug.Print "cboCursors_KeyDown", KeyCode, Shift
End Sub
Private Sub cboCursors_KeyPress(KeyAscii As Integer)
Debug.Print "cboCursors_KeyPRess", KeyAscii
Dim sC As String
sC = Chr$(KeyAscii)
KeyAscii = Asc(UCase$(sC))
End Sub
Private Sub cboCursors_LostFocus()
Debug.Print "cboCursors:LostFocus"
End Sub
Private Sub cboCursors_ODGotFocus()
Debug.Print "cboCursors:ODGotFocus"
End Sub
Private Sub cboCursors_ODLostFocus()
Debug.Print "cboCursors:ODLostFocus"
End Sub
Private Sub cboSysColor_Click()
picSample.BackColor = cboSysColor.ItemBackColor(cboSysColor.ListIndex)
End Sub
Private Sub cboSysColor_CloseUp()
If (chkVisible.Value = 1) Then
cmdShow.SetFocus
End If
End Sub
Private Sub cboSysColor_KeyDown(KeyCode As Integer, Shift As Integer)
Debug.Print "SysColor:KeyDown", KeyCode
End Sub
Private Sub chkEmpty_Click()
If (chkEmpty.Value = Checked) Then
lstCheck.Clear
Else
' Add some items to the checked list box:
With lstCheck
.AddItem "File Menu Items"
.AddItemAndData "Open", , 16
.AddItemAndData "Save", , 16
.AddItemAndData "Exit", , 16
End With
End If
End Sub
Private Sub chkEnabled_Click()
cboCursors.Enabled = -1 * chkEnabled.Value
lstMultiSelect.Enabled = -1 * chkEnabled.Value
If (chkEnabled.Value = Checked) Then
cboCursors.BackColor = vbWindowBackground
Else
cboCursors.BackColor = vbButtonFace
End If
End Sub
Private Sub chkShowNames_Click()
If (chkShowNames.Value = 1) Then
cboColorPicker.ClientDraw = ecdColourPickerWithNames
Else
cboColorPicker.ClientDraw = ecdColourPickerNoNames
End If
End Sub
Private Sub chkVisible_Click()
cboSysColor.Visible = (chkVisible - 1) * -1
End Sub
Private Sub cmdLoad_Click()
Dim sFile As String
Dim iCount As Integer
Dim iImgCount As Integer
Dim i As Long
Dim sLC As String
Dim bFound As Boolean
Dim iH As Long
Dim cf As New cFileIcon
Dim iC As Long
Dim fMaxColorDepth As Double
Dim iMaxColorDepthIndex As Long
Dim hIcon As Long
If cboCursors.Tag = "" Then
With cboCursors.InternalImageList
.IconSizeX = 16
.IconSizeY = 16
.ColourDepth = ILC_COLOR24
.Create2
cboCursors.ImageList = .hIml
End With
iImgCount = 0
sFile = Dir(App.Path & "\Images\*.*")
Do While sFile <> ""
iCount = iCount + 1
cf.LoadIcon App.Path & "\Images\" & sFile
fMaxColorDepth = 0
For iC = 1 To cf.ImageCount
If (cf.ImageWidth(iC) = 16) Then
If (cf.ImageColourCount(iC) > fMaxColorDepth) And Not
(cf.ImageHasAlphaChannel(iC)) Then
fMaxColorDepth = cf.ImageColourCount(iC)
iMaxColorDepthIndex = iC
End If
End If
Next iC
hIcon = cf.IconHandle(Me.hdc, iMaxColorDepthIndex)
cboCursors.InternalImageList.AddFromHandle hIcon, IMAGE_ICON
DestroyIcon hIcon
iImgCount = iImgCount + 1
If (iCount = 1) Then
cboCursors.AddItemAndData UCase$(Left$(sFile, 1)), , 2
iCount = iCount + 1
Else
' Check if we have a header:
sLC = UCase$(Left$(sFile, 1))
bFound = False
For iH = 0 To cboCursors.ListCount - 1
If (cboCursors.List(iH) = sLC) Then
bFound = True
End If
Next iH
If Not (bFound) Then
cboCursors.AddItemAndData sLC, , 2
cboCursors.ItemOverLine(cboCursors.NewIndex) = True
End If
End If
cboCursors.AddItemAndData sFile, (iImgCount - 1), 8, , , iCount, , 20
sFile = Dir
Loop
If (iCount > 0) Then
chkEnabled.Enabled = True
chkEnabled.Value = 1
cboCursors.ListIndex = 0
cmdLoad.Enabled = False
lstMultiSelect.ImageList = cboCursors.InternalImageList.hIml
For i = 0 To cboCursors.ListCount - 1
lstMultiSelect.AddItemAndData cboCursors.List(i),
cboCursors.ItemIcon(i), cboCursors.ItemIndent(i), , ,
cboCursors.ItemData(i), , IIf(i Mod 2 = 0,
cboCursors.itemHeight(i) - 2, 64)
If (cboCursors.ItemOverLine(i)) Then
lstMultiSelect.ItemOverLine(i) = True
End If
Next i
Else
MsgBox "No images found in the path: " & App.Path & "\Images\*.*",
vbInformation
End If
cboCursors.Tag = "LOADED"
cboCursors.DoAutoComplete = True
cboCursors.AutoCompleteItemsAreSorted = True
cboCursors.AutoCompleteListItemsOnly = False
End If
End Sub
Private Sub cmdShow_Click()
Dim X As Long, Y As Long
X = cmdShow.Left \ Screen.TwipsPerPixelX
Y = 1 + (cmdShow.Top + cmdShow.Height) \ Screen.TwipsPerPixelY
cboSysColor.ShowDropDownAtPosition X, Y
End Sub
Private Sub cmdTestForm_Click()
mfrmTest.Show
End Sub
Private Sub cmdSetFocus_Click()
lstMultiCol.SetFocus
End Sub
Private Sub Form_Load()
cboSysColor.DropDownWidth = (cboSysColor.Width * 2) \ Screen.TwipsPerPixelX
' Set up the colour picker combo:
With cboColorPicker
.AddItemAndData "Black", , , , vbBlack
.AddItemAndData "Dark Red", , , , &H80&
.AddItemAndData "Dark Green", , , , &H8000&
.AddItemAndData "Ochre", , , , &H8080&
.AddItemAndData "Dark Blue", , , , &H800000
.AddItemAndData "Purple", , , , &H800080
.AddItemAndData "Turquoise", , , , &H808000
.AddItemAndData "Silver", , , , &HC0C0C0
.AddItemAndData "Gray", , , , &H808080
.AddItemAndData "Red", , , , vbRed
.AddItemAndData "Green", , , , vbGreen
.AddItemAndData "Yellow", , , , vbYellow
.AddItemAndData "Blue", , , , vbBlue
.AddItemAndData "Magenta", , , , vbMagenta
.AddItemAndData "Cyan", , , , vbCyan
.AddItemAndData "White", , , , vbWhite
.ListIndex = 0
End With
' Select the first font:
If (cboFonts.ListCount = 0) Then
cboFonts.AddItem "No fonts available"
cboFonts.Enabled = False
Else
cboFonts.DoAutoComplete = True
cboFonts.AutoCompleteItemsAreSorted = True
cboFonts.AutoCompleteListItemsOnly = True
End If
cboFonts.ListIndex = 0
' Set up available styles:
AddStyles
' Add some items to the checked list box:
With lstCheck
.AddItem "File Menu Items"
.AddItemAndData "Open", , 16
.AddItemAndData "Save", , 16
.AddItemAndData "Exit", , 16
End With
' Set up the multi-column list box:
Dim lW As Long, i As Long
With lstMultiCol
.Columns = 4
lW = lstMultiCol.Width \ Screen.TwipsPerPixelX * 8
.ColWidth(1) = lW * 3
.ColWidth(2) = lW
.ColWidth(3) = 2 * lW
.ColWidth(4) = 2 * lW
.ImageList = .InternalImageList.hIml
For i = 1 To 10
.AddItemAndData ("Quite a reasonably long item for column 1, row" & i
& vbTab & "Col2" & i & vbTab & Format$(Now, "hh:mm:ss") & vbTab & i),
Rnd * 7
Next i
.FullRowSelect = True
End With
SendMessageLong lstMultiCol.hWnd, LB_SETHORIZONTALEXTENT, (lstMultiCol.Width
\ Screen.TwipsPerPixelX) * 3, 0
End Sub
Private Sub lstCheck_Click()
Dim i As Long
'Debug.Print "Check_Click"
'If (lstCheck.ListIndex = 0) Then
' For i = 1 To 3
' lstCheck.Selected(i) = lstCheck.Selected(0)
' Next i
'End If
End Sub
Private Sub lstCheck_KeyPress(KeyAscii As Integer)
Dim lI As Long
If (KeyAscii = 13) Then
lI = lstCheck.ListIndex
If (lI > -1) Then
'lstCheck.Selected(lI) = Not (lstCheck.Selected(lI))
End If
End If
End Sub
Private Sub lstMultiCol_Click()
Debug.Print "MultiCol_Click" & lstMultiCol.List(lstMultiCol.ListIndex)
End Sub
Private Sub lstMultiSelect_MeasureItem(Index As Long, WidthPixels As Long,
HeightPixels As Long)
If (Index Mod 2) = 0 Then
HeightPixels = 64
End If
End Sub
Private Sub lstSysColours_Change()
Debug.Print "Colour:Change"
End Sub
Private Sub lstSysColours_Click()
Debug.Print "Colour:Click"
Debug.Print lstSysColours.List(lstSysColours.ListIndex)
End Sub
Private Sub lstSysColours_KeyDown(KeyCode As Integer, Shift As Integer)
Debug.Print "Colour:KeyDown", KeyCode, Shift
End Sub
Private Sub lstSysColours_KeyPress(KeyAscii As Integer)
Debug.Print "Colour:KeyPress", KeyAscii
End Sub
Private Sub lstSysColours_KeyUp(KeyCode As Integer, Shift As Integer)
Debug.Print "Colour:KeyUp"
End Sub
Private Sub lstMultiCol_KeyDown(KeyCode As Integer, Shift As Integer)
Debug.Print "MultiCol:KEYDOWN", KeyCode, Shift
End Sub
Private Sub lstMultiSelect_KeyDown(KeyCode As Integer, Shift As Integer)
Debug.Print KeyCode, Shift
End Sub
Private Sub picSample_Click()
Set cboStyles.Font = Me.Font
End Sub
Private Sub tmrFocus_Timer()
If Not (Me.ActiveControl Is Nothing) Then
lblFocus.Caption = Me.ActiveControl.Name
Else
lblFocus.Caption = "<none>"
End If
End Sub
|
|