VBA Notes
Some Notes
Option Explicit
'Listview API
'-----------------------------Start Listview API-------------------------------------
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 Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
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 SendMessageAny Lib "user32" Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Const CLR_NONE = &HFFFFFFFF
Private Const LVM_FIRST = &H1000
Private Const LVM_SETBKCOLOR = (LVM_FIRST + 1)
'Private Const LVM_GETHEADER = (LVM_FIRST + 31)
Private Const LVM_SETTEXTBKCOLOR = (LVM_FIRST + 38)
Private Const LVM_SETICONSPACING = (LVM_FIRST + 53)
Private Const LVBKIF_SOURCE_NONE = &H0
Private Const LVBKIF_SOURCE_HBITMAP = &H1 ' Not supported
Private Const LVBKIF_SOURCE_URL = &H2
Private Const LVBKIF_SOURCE_MASK = &H3
Private Const LVBKIF_STYLE_NORMAL = &H0
Private Const LVBKIF_STYLE_TILE = &H10
Private Const LVBKIF_STYLE_MASK = &H10
Private Const LVM_SETBKIMAGEA = (LVM_FIRST + 68)
Private Const LVM_GETBKIMAGEA = (LVM_FIRST + 69)
Private Const LVM_SETBKIMAGE = LVM_SETBKIMAGEA
Private Const LVM_GETBKIMAGE = LVM_GETBKIMAGEA
Private Const LVM_SETEXTENDEDLISTVIEWSTYLE = LVM_FIRST + 54
Private Const LVM_GETEXTENDEDLISTVIEWSTYLE = LVM_FIRST + 55
Private Const LVS_EX_FULLROWSELECT = &H20
Private Const LVS_EX_GRIDLINES = &H1
Private Const LVS_EX_CHECKBOXES As Long = &H4
Private Const LVS_EX_HEADERDRAGDROP = &H10
Private Const LVS_EX_TRACKSELECT = &H8
Private Const LVS_EX_ONECLICKACTIVATE = &H40
Private Const LVS_EX_TWOCLICKACTIVATE = &H80
Private Const LVS_EX_SUBITEMIMAGES = &H2
Private Const LVIF_STATE = &H8
Private Const LVM_SETITEMSTATE = (LVM_FIRST + 43)
Private Const LVM_GETITEMSTATE As Long = (LVM_FIRST + 44)
Private Const LVM_GETITEMTEXT As Long = (LVM_FIRST + 45)
Private Const LVIS_STATEIMAGEMASK As Long = &HF000
'Selected State
'Private Const LVM_FIRST = &H1000
Private Const LVM_GETNEXTITEM = (LVM_FIRST + 12)
Private Const LVNI_SELECTED = &H2
Private Const LVM_GETSELECTEDCOUNT = (LVM_FIRST + 50)
Private Type LVITEM
mask As Long
iItem As Long
iSubItem As Long
State As Long
stateMask As Long
pszText As String
cchTextMax As Long
iImage As Long
lParam As Long
iIndent As Long
End Type
Private Const LVM_GETCOLUMN = (LVM_FIRST + 25)
Private Const LVM_GETCOLUMNORDERARRAY = (LVM_FIRST + 59)
Private Const LVCF_TEXT = &H4
Private Type LVCOLUMN
mask As Long
fmt As Long
cx As Long
pszText As String
cchTextMax As Long
iSubItem As Long
iImage As Long
iOrder As Long
End Type
' Bitmaps in list views!
Private Type LVBKIMAGE
ulFlags As Long
hbm As Long
pszImage As String
cchImageMax As Long
xOffsetPercent As Long
yOffsetPercent As Long
End Type
'hHeaderFont is the handle to the font used to draw the
'header text, and must not be destroyed unless no longer
'needed (see the Unload event).
Private hHeaderFont As Long
'vars representing the checkbox options in
'the chkHeaderFont control array.
Private Const optBold = 0
Private Const optItalic = 1
Private Const optUnderlined = 2
Private Const optStrikeOut = 3
'-----------------------------------------------
'APIs, constants and structures required to change the listview header font
Private Const LVM_GETHEADER = (LVM_FIRST + 31)
'font weight vars
Private Const FW_NORMAL = 400
Private Const FW_BOLD = 700
'SendMessage vars
Private Const WM_SETFONT = &H30
Private Const WM_GETFONT = &H31
Private Const LF_FACESIZE = 32
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" _
(ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" _
Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long
' Flat Column Headers
Private Const HDS_BUTTONS = &H2
Private Const GWL_STYLE = (-16)
Const SWP_DRAWFRAME = &H20
Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1
Const SWP_NOZORDER = &H4
Private Const SWP_FLAGS = SWP_NOZORDER Or SWP_NOSIZE Or SWP_NOMOVE Or SWP_DRAWFRAME
Private Declare Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hWnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, _
ByVal cx As Long, ByVal cy As Long, _
ByVal wFlags As Long) As Long
Private Const SW_NORMAL = 1
Private Const SW_SHOWMAXIMIZED = 3
Private Const SW_SHOWDEFAULT = 10
Private Const SW_SHOWNOACTIVATE = 4
Private Const SW_SHOWNORMAL = 1
'----------------------End Listview API--------------------------------------
'Private m_ColCollection As New Collection
Private Enum HdrAlignment
lvLeft = 0
lvCenter = 1
lvRight = 2
End Enum
Event Change(ByRef iIndex As Long, ByRef itemKey As String, ByRef curSel As String)
Event FetchColumnSetup(ByRef strFldName As String, ByRef strMask As String)
Event LastError(ByRef ErrNum As Long, ByRef strDescription As String)
Event RSEmpty(ByRef IsEmpty As Boolean)
Private WithEvents oList As MSComctlLib.ListView
'Private WithEvents oList As ComctlLib.ListView
Private ParentHandle As Long
Private m_ItemIndex As Long 'ListItems Index to selected Item
Private curSelection As String
Private itemKey As String
Private strIndex As String
Private strItemIndex As String
Private bGridLines As Boolean
Private bFullRowSelect As Boolean
Private bFlatHeaders As Boolean
Private bIsEmpty As Boolean
Private strFieldName() As String
Private FldCount As Integer
'Private optBold As Integer
'Private optItalic As Integer
'Private optUnderlined As Integer
'Private optStrikeOut As Integer
Public Function InitializeListview(ListObj As Object, lngParentHandle As Long, _
Optional GridLines = False, Optional RowSelect = False, Optional FlatHeaders = False)
On Error GoTo LocalErr
Set oList = ListObj
ParentHandle = lngParentHandle
oList.View = lvwReport
If GridLines Then bGridLines = GridLines: Call SetGridLines
If RowSelect Then bFullRowSelect = RowSelect: Call SetFullRowSelect
If FlatHeaders Then bFlatHeaders = FlatHeaders: Call SetFlatHeaders
'SetBackgroundImage App.Path & "\back.gif"
Exit Function
LocalErr:
RaiseEvent LastError(Err.Number, "Error Initializing ListView " & Err.Description)
End Function
Public Function ClearColumnheaders()
On Error Resume Next
If oList.ColumnHeaders.Count <> 0 Then oList.ColumnHeaders.Clear
End Function
Public Function AddColumnheaders(strHdrName As String, Optional BindField = vbNullString, Optional lWidth = 0, Optional Alignment As ListColumnAlignmentConstants = lvLeft)
'Dim Header As ComctlLib.ColumnHeader
Dim Header As MSComctlLib.ColumnHeader
Static numField As Integer
Static Count As Integer
On Error GoTo LocalErr
Set Header = oList.ColumnHeaders.Add()
Header.Text = strHdrName
If lWidth <> 0 Then
Header.Width = lWidth
End If
'lvwColumnCenter
'lvwColumnLeft
'lvwColumnRight
'The first column must be left align
If Alignment <> 0 And Count = 0 Then
Header.Alignment = 0
Else
Header.Alignment = Alignment
End If
If BindField <> vbNullString Then
ReDim Preserve strFieldName(0 To numField)
strFieldName(numField) = BindField
'Store in our Tag Property
Header.Tag = BindField
'1. Return the number of fields to show
FldCount = numField
'2. increment our numField
numField = numField + 1
Else
Header.Tag = strHdrName
End If
Count = Count + 1
Exit Function
LocalErr:
RaiseEvent LastError(Err.Number, "Error Adding Columnheaders " & Err.Description)
End Function
Private Sub Class_Initialize()
bGridLines = False
bFullRowSelect = True
bFlatHeaders = False
bIsEmpty = True
' optBold = 0
' optItalic = 0
' optUnderlined = 0
' optStrikeOut = 0
End Sub
Private Sub Class_Terminate()
If hHeaderFont > 0 Then
Dim r As Long
r = DeleteObject(hHeaderFont)
End If
End Sub
Public Function ADOLoadRecords(ByVal rsTemp As ADODB.Recordset, pos_start As Long, pos_end As Long)
Dim rsTemp1 As ADODB.Recordset
Dim nFlds As ADODB.Field
'Dim LI As ComctlLib.ListItem
Dim LI As MSComctlLib.ListItem
Dim X As Integer
Dim mMask As String
Dim Count As Long
Set rsTemp1 = rsTemp
oList.ListItems.Clear
If rsTemp1.RecordCount < 1 Then Exit Function
rsTemp1.AbsolutePosition = pos_start
'If primaryindex is null set index to field(0)
If strIndex = vbNullString Then
strIndex = rsTemp1.Fields(0).Name
End If
Do While Not rsTemp1.EOF
RaiseEvent FetchColumnSetup(rsTemp1.Fields(strFieldName(0)).Name, mMask)
Set LI = oList.ListItems.Add(, Tombstone & rsTemp(strIndex), IIf(Not IsNull(mMask), Format(rsTemp1.Fields(strFieldName(0)).Value, mMask), rsTemp1.Fields(strFieldName(0)).Value), 0, 0)
'LI.Tag = rsTemp(strIndex)
LI.Tag = rsTemp1.Fields(strIndex) & Tombstone & Count + pos_start
For X = 1 To FldCount
Set nFlds = rsTemp1.Fields(strFieldName(X))
RaiseEvent FetchColumnSetup(nFlds.Name, mMask)
LI.SubItems(X) = IIf(IsNull(nFlds.Value), "", IIf(Not IsNull(mMask), Format(nFlds.Value, mMask), nFlds.Value))
Next X
'rsTemp.MoveNext
If rsTemp1.AbsolutePosition >= pos_end Then
Exit Do
Else
rsTemp1.MoveNext
Count = Count + 1
End If
Loop
'Set our first record to top
If Not X <= 0 Then
bIsEmpty = False
' oList.ListItems(1).Selected = True
' Call SetItemCheck
End If
RaiseEvent RSEmpty(bIsEmpty)
'rsTemp1.Close
'Set rsTemp1 = Nothing
Set LI = Nothing
Count = 0
End Function
Private Sub SetGridLines()
On Error Resume Next
Dim rStyle As Long
Dim r As Long
'get the current ListView style
rStyle = SendMessageLong(oList.hWnd, LVM_GETEXTENDEDLISTVIEWSTYLE, 0&, 0&)
If Not bGridLines Then
'remove the extended bit
rStyle = rStyle Xor LVS_EX_GRIDLINES
ElseIf bGridLines Then
'set the extended bit
rStyle = rStyle Or LVS_EX_GRIDLINES
End If
'set the new ListView style
r = SendMessageLong(oList.hWnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0&, rStyle)
End Sub
Private Sub SetFullRowSelect()
On Error Resume Next
Dim rStyle As Long
Dim r As Long
'get the current ListView style
rStyle = SendMessageLong(oList.hWnd, LVM_GETEXTENDEDLISTVIEWSTYLE, 0&, 0&)
If Not bFullRowSelect Then
'remove the extended style bit
rStyle = rStyle Xor LVS_EX_FULLROWSELECT
ElseIf bFullRowSelect Then
'set the extended style bit
rStyle = rStyle Or LVS_EX_FULLROWSELECT
End If
'set the new ListView style
r = SendMessageLong(oList.hWnd, LVM_SETEXTENDEDLISTVIEWSTYLE, 0&, rStyle)
End Sub
Private Sub SetFlatHeaders()
On Error Resume Next
Dim r As Long
Dim style As Long
Dim hHeader As Long
'get the handle to the listview header
hHeader = SendMessageLong(oList.hWnd, LVM_GETHEADER, 0, ByVal 0&)
'get the current style attributes for the header
style = GetWindowLong(hHeader, GWL_STYLE)
'modify the style by toggling the HDS_BUTTONS style
style = style Xor HDS_BUTTONS
'set the new style and redraw the listview
If style Then
r = SetWindowLong(hHeader, GWL_STYLE, style)
r = SetWindowPos(oList.hWnd, ParentHandle, 0, 0, 0, 0, SWP_FLAGS)
End If
End Sub
Public Sub SetHeaderFontStyle(Optional intBold = 0, Optional intItalic = 0, _
Optional intStrikeOut = 0, Optional intUnderline = 0)
Dim LF As LOGFONT
Dim r As Long
Dim hCurrFont As Long
Dim hOldFont As Long
Dim hHeader As Long
'get the windows handle to the header
'portion of the listview
hHeader = SendMessageLong(oList.hWnd, LVM_GETHEADER, 0, 0)
'get the handle to the font used in the header
hCurrFont = SendMessageLong(hHeader, WM_GETFONT, 0, 0)
'get the LOGFONT details of the
'font currently used in the header
r = GetObject(hCurrFont, Len(LF), LF)
'if GetObject was sucessful...
If r > 0 Then
'set the font attributes according to the selected check boxes
If intBold = 1 Then
LF.lfWeight = FW_BOLD
Else: LF.lfWeight = FW_NORMAL
End If
LF.lfItalic = intItalic = 1
LF.lfUnderline = intUnderline = 1
LF.lfStrikeOut = intStrikeOut = 1
'clean up by deleting any previous font
r = DeleteObject(hHeaderFont)
'create a new font for the header control to use.
'This font must NOT be deleted until it is no
'longer required by the control, typically when
'the application ends (see the Unload sub), or
'above as a new font is to be created.
hHeaderFont = CreateFontIndirect(LF)
'select the new font as the header font
hOldFont = SelectObject(hHeader, hHeaderFont)
'and inform the listview header of the change
r = SendMessageLong(hHeader, WM_SETFONT, hHeaderFont, True)
End If
End Sub
Public Property Get PrimaryIndex() As String
PrimaryIndex = strIndex
End Property
Public Property Let PrimaryIndex(ByVal vNewValue As String)
strIndex = vNewValue
End Property
Public Function GetAllSubItems(iIndex As Long) As Variant
On Error GoTo LocalErr
Dim X As Long
Dim strTemp As String
For X = 1 To FldCount
strTemp = strTemp & oList.ListItems(iIndex).SubItems(X) & ";"
Next X
strTemp = Left(strTemp, Len(strTemp) - 1)
GetAllSubItems = Array(strTemp)
Exit Function
LocalErr:
If iIndex <= 0 Then
RaiseEvent LastError(Err.Number, "Parameter Index# " & iIndex & " not found")
Else
RaiseEvent LastError(Err.Number, Err.Description)
End If
End Function
Public Function GetSubItem(iIndex As Long, iCol As Long) As String
On Error GoTo LocalErr
GetSubItem = oList.ListItems(iIndex).SubItems(iCol)
Exit Function
LocalErr:
If iCol > FldCount Then
RaiseEvent LastError(Err.Number, "Parameter Column# " & iCol & " not found")
ElseIf iIndex <= 0 Then
RaiseEvent LastError(Err.Number, "Parameter Index# " & iIndex & " not found")
Else
RaiseEvent LastError(Err.Number, Err.Description)
End If
End Function
Public Function GetSubItemsByNames(iIndex As Long, vNames As Variant) As Variant
On Error GoTo LocalErr
Dim X, Y As Long
Dim strTemp As String
For X = 0 To UBound(vNames)
For Y = 1 To FldCount
If UCase$(strFieldName(Y)) = UCase$(CStr(vNames(X))) Then
'Debug.Print UCase$(strFieldName(x)) & " = " & UCase$(CStr(vNames(y)))
strTemp = strTemp & oList.ListItems(iIndex).SubItems(Y) & ";"
'Debug.Print strTemp
End If
Next Y
Next X
If strTemp <> "" Then
strTemp = Left(strTemp, Len(strTemp) - 1)
End If
GetSubItemsByNames = Array(strTemp)
Exit Function
LocalErr:
If iIndex <= 0 Then
RaiseEvent LastError(Err.Number, "Parameter Index# " & iIndex & " not found")
Else
RaiseEvent LastError(Err.Number, Err.Description)
End If
End Function
Private Sub SetItemCheck()
Dim lngCount As Long
Dim lCurSelectedItemIndex As Long
'Dim tmpKey As String
lCurSelectedItemIndex = -1
lngCount = SendMessage(oList.hWnd, LVM_GETSELECTEDCOUNT, 0, 0)
'Check if we have selected a row
If lngCount <> 0 Then
'Since this API is 0 based we have to add a 1 from this return value
m_ItemIndex = SendMessage(oList.hWnd, LVM_GETNEXTITEM, lCurSelectedItemIndex, ByVal LVNI_SELECTED) + 1
curSelection = vbNullString
If ItemIndex <> -1 Then
'Get the Key
itemKey = GetKeyID(oList.SelectedItem.Tag) 'Trim(oList.SelectedItem.Key)
'Extract it removing 'X' on the 1st part
'itemKey = Mid(tmpKey, 2, Len(tmpKey) - 1)
End If
curSelection = oList.ListItems.item(ItemIndex)
RaiseEvent Change(m_ItemIndex, itemKey, curSelection)
End If
End Sub
Private Sub oList_ItemClick(ByVal item As MSComctlLib.ListItem)
'Private Sub oList_ItemClick(ByVal Item As ComctlLib.ListItem)
'Dim tmpKey As String
m_ItemIndex = oList.SelectedItem.Index
curSelection = vbNullString
If m_ItemIndex <> -1 Then
'Get the Key
'tmpKey = Trim(oList.SelectedItem.Key)
itemKey = GetKeyID(oList.SelectedItem.Tag)
'Extract it removing 'X' on the 1st part
'itemKey = Mid(tmpKey, 2, Len(tmpKey) - 1)
End If
curSelection = oList.ListItems.item(m_ItemIndex)
RaiseEvent Change(m_ItemIndex, itemKey, curSelection)
End Sub
Public Function GetVirtualID() As String
Dim srcUF As String
If oList.SelectedItem.Tag <> "" Then
srcUF = oList.SelectedItem.Tag
If srcUF = Tombstone Then GetVirtualID = "": Exit Function
Dim i As Integer
Dim t As String
For i = (InStr(1, srcUF, Tombstone, vbTextCompare) + 3) To Len(srcUF)
t = t & Mid$(srcUF, i, 1)
Next i
GetVirtualID = t
i = 0
t = ""
End If
End Function
Private Function GetKeyID(ByVal srcUF As String) As String
'srcUF = oList.SelectedItem.Tag
If srcUF = Tombstone Then GetKeyID = "": Exit Function
Dim i As Integer
Dim t As String
For i = 1 To Len(srcUF)
If Mid$(srcUF, i, 3) = Tombstone Then
Exit For
Else
t = t & Mid$(srcUF, i, 1)
End If
Next i
GetKeyID = t
i = 0
t = ""
End Function
Public Property Get ItemIndex() As Long
If oList.SelectedItem.Index <> -1 Then
m_ItemIndex = oList.SelectedItem.Index
Else
m_ItemIndex = -1
End If
ItemIndex = m_ItemIndex
End Property
Public Property Let ItemIndex(ByVal vNewValue As Long)
On Error GoTo LocalErr
m_ItemIndex = vNewValue
If m_ItemIndex <> -1 Then
oList.ListItems(m_ItemIndex).Selected = True
End If
' oList.SelectedItem.index = vNewValue
Exit Property
LocalErr:
If Err.Number = 35600 Then vNewValue = -1
End Property
Public Property Get ListItemSelectedText() As String
ListItemSelectedText = curSelection
End Property
Public Function GetCheckedItems()
Dim i As Long
Dim retVal As Long
Dim LV As LVITEM
Dim strTemp As String
'iterate through each item, checking its item state
strItemIndex = vbNullString
For i = 0 To oList.ListItems.Count - 1
retVal = SendMessageAny(oList.hWnd, LVM_GETITEMSTATE, i, LVIS_STATEIMAGEMASK)
'when an item is checked, the LVM_GETITEMSTATE call
'returns 8192 (&H2000&).
If retVal And &H2000& Then
'its checked, so pad the LVITEM string members
With LV
.cchTextMax = MAX_PATH
.pszText = Space$(MAX_PATH)
End With
'and retrieve the value (text) of the checked item
retVal = SendMessageAny(oList.hWnd, LVM_GETITEMTEXT, i, LV)
'continue building the msgbox string with the info
'b = b & "item " & CStr(i) & " ( " & _
' Left$(LV.pszText, InStr(LV.pszText, Chr$(0)) - 1) & " )" & vbCrLf
strTemp = strTemp & Left$(LV.pszText, InStr(LV.pszText, Chr$(0)) - 1) & ","
strItemIndex = strItemIndex & CStr(LV.iItem + 1) & ","
' strTemp = strTemp & CStr(LV.iItem) & ","
End If
Next
If strTemp <> "" Then
strTemp = Left(strTemp, Len(strTemp) - 1)
strItemIndex = Left(strItemIndex, Len(strItemIndex) - 1)
GetCheckedItems = strTemp
Else
GetCheckedItems = vbNullString
End If
End Function
'Public Sub SetBackgroundImage(strPathToImage As String)
' Dim tLBI As LVBKIMAGE
' If FileExist(strPathToImage) Then
' tLBI.pszImage = strPathToImage & Chr$(0)
' tLBI.cchImageMax = Len(strPathToImage) + 1
' tLBI.ulFlags = LVBKIF_SOURCE_URL Or LVBKIF_STYLE_TILE
' SendMessage oList.hWnd, LVM_SETBKIMAGE, 0, tLBI
' ' Set the background colour of the ListView to &HFFFFFFFF (-1)
' ' so it will be transparent!
' SendMessageByLong oList.hWnd, LVM_SETTEXTBKCOLOR, 0, CLR_NONE
' Else
' MsgBox "Image path not found."
' End If
'End Sub
Public Property Get IndexCheckSelected() As String
'This is an array containing the index of selected checkbox
'returned from GetCheckedItems
IndexCheckSelected = strItemIndex
End Property