vbAccelerator - Contents of code file: frmDropDown.frm

VERSION 5.00
Object = "{4A3A29A4-F2E3-11D3-B06C-00500427A693}#2.0#0"; "vbalDDFm6.ocx"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmDropDown 
   BorderStyle     =   5  'Sizable ToolWindow
   ClientHeight    =   1935
   ClientLeft      =   4695
   ClientTop       =   4050
   ClientWidth     =   4365
   ControlBox      =   0   'False
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form2"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1935
   ScaleWidth      =   4365
   ShowInTaskbar   =   0   'False
   Begin MSComctlLib.ListView lvwDropDown 
      Height          =   1515
      Left            =   0
      TabIndex        =   1
      Top             =   60
      Width           =   4395
      _ExtentX        =   7752
      _ExtentY        =   2672
      View            =   3
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      _Version        =   393217
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   0
   End
   Begin MSComctlLib.ImageList ilsIcons 
      Left            =   3720
      Top             =   1260
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   2
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmDropDown.frx":0000
            Key             =   ""
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmDropDown.frx":27B4
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin vbalDropDownForm6.vbalDropDownClient ddcDropDown 
      Align           =   1  'Align Top
      Height          =   75
      Left            =   0
      ToolTipText     =   "Drag to make this menu float"
      Top             =   0
      Width           =   4365
      _ExtentX        =   7699
      _ExtentY        =   132
      AllowTearOff    =   0   'False
      AllowResize     =   0   'False
   End
   Begin VB.CommandButton cmdAdvanced 
      Caption         =   "Advanced..."
      Height          =   255
      Left            =   0
      TabIndex        =   0
      Top             =   1680
      Width           =   1215
   End
End
Attribute VB_Name = "frmDropDown"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Const elviReportFullRowSelect = &H20            '// applies to report
 mode only

Private Const LVM_FIRST = &H1000                   '// ListView messages
Private Const LVM_GETITEMRECT = (LVM_FIRST + 14)
Private Const LVM_GETEXTENDEDLISTVIEWSTYLE = (LVM_FIRST + 55)
Private Const LVM_SETEXTENDEDLISTVIEWSTYLE = (LVM_FIRST + 54) '// optional
 wParam == mask
Private Declare Function SendMessageByLong Lib "user32" Alias "SendMessageA"
 (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As
 Long) As Long
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 Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
End Type
Private Type POINTAPI
   X As Long
   Y As Long
End Type
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect
 As RECT) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long,
 lpPoint As POINTAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long,
 lpPoint As POINTAPI) As Long
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private m_sValue As String
Private m_bCancel As Boolean
Private m_iNameCount As Long
Private m_sFirstName() As String
Private m_sSurName() As String

Public Event Change()
Public Event CloseUp()

Public Property Let ShowState(ByVal eState As EWindowShowState)
   ' This is to allow the parent form
   ' to control the current drop-down state:
   ddcDropDown.ShowState = eState
End Property
Public Property Get ShowState() As EWindowShowState
   ' This is to allow the parent form
   ' to control the current drop-down state:
   ShowState = ddcDropDown.ShowState
End Property

Private Sub cmdAdvanced_Click()
   MsgBox "Show Advanced Dialog Here"
End Sub

Private Sub ddcDropDown_AppActivate(ByVal bState As Boolean)
   ' Emulate Word - hide away floating
   ' toolwindows when we're not the focus
   ' app:
   If (bState) Then
      If ddcDropDown.ShowState = ewssFloating Then
         Me.Show
      End If
   Else
      If ddcDropDown.ShowState = ewssFloating Then
         Me.Hide
      End If
   End If
End Sub

Private Sub ddcDropDown_CaptionResize()
   ' Here you would resize your form/move the
   ' contents to accommodate the change in size
   ' of the caption:
   
End Sub

Private Sub ddcDropDown_CloseClick()
   ' User pressed the close button on the
   ' ToolWindow:
   Unload Me
End Sub

Public Property Get Cancelled() As Boolean
   Cancelled = m_bCancel
End Property
Public Property Get Value() As String
   Value = m_sValue
End Property
Public Property Let Value(ByVal sValue As String)
Dim itmX As ListItem
   m_sValue = sValue
   If ddcDropDown.ShowState = ewssDropped Then
      For Each itmX In lvwDropDown.ListItems
         With itmX
            If sValue = .Text & " " & .SubItems(1) & " " & .SubItems(2) Then
               itmX.Selected = True
               Exit For
            End If
         End With
      Next
   End If
End Property

Private Sub ddcDropDown_Sizing(lLeft As Long, lTop As Long, lWidth As Long,
 lHeight As Long)
   ' Set the drop-down size within limits:
   If lWidth > 400 Then
      lWidth = 400
   End If
   If lWidth < 96 Then
      lWidth = 96
   End If
   If lHeight > 300 Then
      lHeight = 300
   End If
   If lHeight < 96 Then
      lHeight = 96
   End If
End Sub

Private Property Get vowel(Optional ByVal iHowMany As Long = 1) As String
Dim i As Long
Dim sOut As String
Dim s As String
   For i = 1 To iHowMany
      Do
         s = Chr$(Asc("a") + Rnd * 25)
      Loop While Not (isin(s, "a", "e", "i", "o", "u"))
      sOut = sOut & s
   Next i
   vowel = sOut
End Property

Private Property Get consonant(Optional ByVal iHowMany As Long = 1) As String
Dim i As Long
Dim sOut As String
Dim s As String
   For i = 1 To iHowMany
      Do
         s = Chr$(Asc("a") + Rnd * 25)
      Loop While isin(s, "a", "e", "i", "o", "u")
      sOut = sOut & s
   Next i
   consonant = sOut
End Property
Private Function isin(ByVal s As String, ParamArray vOptions() As Variant) As
 Boolean
Dim i As Long
   For i = LBound(vOptions) To UBound(vOptions)
      If (s = vOptions(i)) Then
         isin = True
         Exit Function
      End If
   Next i
End Function

Private Sub Form_Activate()
   lvwDropDown.SetFocus
End Sub

Private Sub Form_Load()
   m_bCancel = True
   
   ' Set up the ListView so it has a multi-select style:
   Dim i As Long, itmX As ListItem
   Dim lStyle As Long
   lvwDropDown.SmallIcons = ilsIcons
   lvwDropDown.View = lvwReport
   lvwDropDown.ColumnHeaders.Add , , "Title", 16 * Screen.TwipsPerPixelX
   lvwDropDown.ColumnHeaders.Add , , "First Name", 64 * Screen.TwipsPerPixelX
   lvwDropDown.ColumnHeaders.Add , , "Surname", 64 * Screen.TwipsPerPixelX
   GenerateNames
   For i = 1 To m_iNameCount
      Set itmX = lvwDropDown.ListItems.Add(, , "Mr", , 1)
      itmX.SubItems(1) = m_sFirstName(i)
      itmX.SubItems(2) = m_sSurName(i)
   Next i
   lStyle = SendMessageByLong(lvwDropDown.hwnd, LVM_GETEXTENDEDLISTVIEWSTYLE,
    0, 0)
   lStyle = lStyle Or elviReportFullRowSelect
   SendMessageByLong lvwDropDown.hwnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0, lStyle
   
End Sub
Private Sub GenerateNames()
Dim i As Long
Static bFirst As Boolean
   If Not bFirst Then
      m_iNameCount = Rnd * 20 + 20
      ReDim m_sFirstName(1 To m_iNameCount) As String
      ReDim m_sSurName(1 To m_iNameCount) As String
      For i = 1 To m_iNameCount
         m_sFirstName(i) = UCase$(consonant) & vowel & consonant(2) & vowel &
          consonant
         m_sSurName(i) = UCase$(consonant) & vowel(2) & consonant(2) & vowel &
          consonant(2)
      Next i
      bFirst = True
   End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
   '
   RaiseEvent CloseUp
End Sub

Private Sub Form_Resize()
   lvwDropDown.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight - cmdAdvanced.Height -
    4 * Screen.TwipsPerPixelY
   cmdAdvanced.Move cmdAdvanced.Left, Me.ScaleHeight - cmdAdvanced.Height - 2 *
    Screen.TwipsPerPixelY
End Sub

Private Sub lvwDropDown_Click()
   With lvwDropDown.SelectedItem
      m_sValue = .Text & " " & .SubItems(1) & " " & .SubItems(2)
      RaiseEvent Change
      m_bCancel = False
   End With
   Unload Me
End Sub


Private Sub lvwDropDown_ColumnClick(ByVal ColumnHeader As
 MSComctlLib.ColumnHeader)
Dim colX As ColumnHeader
   For Each colX In lvwDropDown.ColumnHeaders
      If Not ColumnHeader Is colX Then
         colX.Tag = ""
      End If
   Next
   If ColumnHeader.Tag = "ASC" Then
      ColumnHeader.Tag = "DESC"
   Else
      ColumnHeader.Tag = "ASC"
   End If
   lvwDropDown.SortKey = ColumnHeader.Index - 1
   If (ColumnHeader.Tag = "ASC") Then
      lvwDropDown.SortOrder = lvwAscending
   Else
      lvwDropDown.SortOrder = lvwDescending
   End If
   lvwDropDown.Sorted = True
End Sub

Private Sub lvwDropDown_ItemClick(ByVal Item As MSComctlLib.ListItem)
   With lvwDropDown.SelectedItem
      m_sValue = .Text & " " & .SubItems(1) & " " & .SubItems(2)
      RaiseEvent Change
   End With
End Sub

Private Sub lvwDropDown_KeyUp(KeyCode As Integer, Shift As Integer)
   If (KeyCode = vbKeyReturn) Then
      lvwDropDown_Click
   ElseIf (KeyCode = vbKeyEscape) Then
      Unload Me
   End If
End Sub

Private Sub lvwDropDown_MouseDown(Button As Integer, Shift As Integer, X As
 Single, Y As Single)
   'SetCapture lvwDropDown.hwnd
End Sub

Private Sub lvwDropDown_MouseMove(Button As Integer, Shift As Integer, X As
 Single, Y As Single)
Dim tR As RECT
Dim tP As POINTAPI
Dim i As Long
Dim lhWNd As Long
   Debug.Print X, Y
   lhWNd = lvwDropDown.hwnd
   GetCursorPos tP
   ScreenToClient lvwDropDown.hwnd, tP
   For i = 1 To lvwDropDown.ListItems.Count
      SendMessage lhWNd, LVM_GETITEMRECT, i - 1, tR
      If tR.Top > tP.Y Then
         Exit For
      Else
         If tR.Left <= tP.X And tR.Right >= tP.X Then
            If tR.Top <= tP.Y And tR.Bottom >= tP.Y Then
               lvwDropDown.ListItems(i).Selected = True
               Exit For
            End If
         End If
      End If
   Next i
End Sub

Private Sub lvwDropDown_MouseUp(Button As Integer, Shift As Integer, X As
 Single, Y As Single)
   lvwDropDown_ItemClick lvwDropDown.SelectedItem
End Sub