Option Compare Text
#Region "Imports"
Imports System
Imports System.Math
Imports System.Drawing
Imports System.Drawing.Drawing2D
Imports System.Drawing.Imaging
Imports System.Drawing.Text
Imports System.Windows.Forms
Imports System.Windows.Forms.Design
Imports System.ComponentModel
Imports System.Runtime.InteropServices
Imports System.Reflection
Imports System.ComponentModel.Design.Serialization
Imports System.Globalization
#End Region
#Region "Class ExCB"
Public Class ExCB
Inherits UserControl
#Region "Enums"
Public Enum DataType
_Text ' String
_Date ' Date[Time]
_Numeric
_LogicTxt ' Boolean, Text checkbox
_LogicImg ' Boolean, Image checkbox
_Image
End Enum
Public Enum SizeMode
_Stretch ' Only Stretch &
_Zoom ' Zoom are allowed
End Enum
#End Region
#Region "Variables"
Private Const _VSArea As Integer = 21 ' Vertical Scroll area
Friend _ColAttr() As _cAttr ' Column's Attributes & Fields
Private _ListRowHeight As Integer ' Effective ListView row height
Private IL As New ImageList ' Controls ListView row height
Private IL813 As New ImageList ' ImageList for sort arrows
Private Img_No As Image = My.Resources.cbNo ' Original CheckBox (Unchecked)
Private Img_Yes As Image = My.Resources.cbYes ' Original CheckBox (Checked)
Private _TxtHeight As Integer = 20 ' TextBox height
Private _LblBoxH As Integer = 32 ' Label1 (counter) + TextBox1 heights
Private _1stCol As Boolean = True ' Flags first Column
Private _1stRow As Boolean = True ' Flags first Row
Private _SelRow As Integer = -1 ' Index of the currently selected item (row)
Private _NCols As Integer = 0 ' Number of columns
Private _NCImg As Integer = 0 ' Number of Columns with Image
Private _ColsX As Integer = 0 ' Columns X value
Private _MaxSiz As Integer = _VSArea ' Control's Max size (including vertical scroll area)
Private _iRows As Integer = -1 ' Last Row index (Number of Rows - 1)
Private _NSRows As Integer = 0 ' Number of Selected Rows
Private _SRows() As Integer ' List of Selected Rows
Private _NDRows As Integer = 0 ' Number of Displayed Rows
Private _EC_Tmp(,) As _ECT ' Temporary EmbeddedControls
Private _TCImg() As Integer ' Temporary image Column List
Private _TxtBk As String ' Previously typed Text
Private _TBtyped As Boolean = False ' Has text been typed?
Private _MB_Right As Boolean = False ' Right Mouse Button clicked?
Private _Wrk As Boolean = False ' Used for bypassing some procedures
#End Region
#Region "Properties"
Private _BStyle As BorderStyle = Windows.Forms.BorderStyle.Fixed3D
<Category("_ExCB specifics")> _
<Description("Location of the built-in Row counter")> _
Public Overloads Property BorderStyle() As BorderStyle
Get
Return _BStyle
End Get
Set(ByVal value As BorderStyle)
_BStyle = value
_CalcSize()
End Set
End Property
<Category("_ExCB specifics")> _
<Description("The font used to display text in the TextBox and List portions of the ExCB")> _
Public Overrides Property Font() As Font
Get
Return MyBase.Font
End Get
Set(ByVal Value As Font)
MyBase.Font = Value
Label1.Font = Value
TextBox1.Font = Value
MyLV1.Font = Value
_CalcSize()
End Set
End Property
Public Enum _CounterLoc
None = 0
TopLeft = 1
BottomLeft = 2
TopRight = 3
BottomRight = 4
End Enum
Private _CtLoc As _CounterLoc = _CounterLoc.TopRight ' see CounterLoc Enum (above)
<Category("_ExCB specifics")> _
<Description("Location of the built-in Row counter")> _
Public Property CounterLoc() As _CounterLoc
Get
Return _CtLoc
End Get
Set(ByVal value As _CounterLoc)
_CtLoc = value
_CalcSize()
End Set
End Property
Private _MinWidth As Integer = 87 ' Min width of control (TextBox width)
<Category("_ExCB specifics")> _
<Description("Minimum width of the control (TextBox + Button)")> _
Public Property MinimumWidth() As Integer
Get
Return _MinWidth
End Get
Set(ByVal value As Integer)
_MinWidth = If(value < 37, 37, value)
Me.Width = value
_CalcSize()
End Set
End Property
Private _MaxDsp As Integer = 8 ' Max Items to display in List
<Category("_ExCB specifics")> _
<Description("Maximum number of rows to display in the drop-down list")> _
Public Property MaxRowsDisp() As Integer
Get
Return _MaxDsp
End Get
Set(ByVal value As Integer)
_MaxDsp = value
End Set
End Property
Dim _RdOnly As Boolean = False ' Read Only?
' If False, ignores
<Category("_ExCB specifics")> _
<Description("Controls whether the ExCB can be dropped-down/changed")> _
Public Property Read_Only() As Boolean
Get
Return _RdOnly
End Get
Set(ByVal value As Boolean)
_RdOnly = value
Button1.Visible = Not (_RdOnly)
TextBox1.ReadOnly = _RdOnly
MyLV1.Enabled = Not (_RdOnly)
If _RdOnly Then
TextBox1.BorderStyle = Windows.Forms.BorderStyle.FixedSingle
Else
TextBox1.BorderStyle = Windows.Forms.BorderStyle.Fixed3D
End If
End Set
End Property
<Category("_ExCB specifics")> _
<Description("Displays grid lines in the list portion of the control")> _
Public Property GridLines() As Boolean
Get
Return MyLV1.GridLines
End Get
Set(ByVal value As Boolean)
MyLV1.GridLines = value
End Set
End Property
Private _Filter As Boolean = False ' Filterable?
<Category("_ExCB specifics")> _
<Description("Can the list be filtered?")> _
Public Property Filterable() As Boolean
Get
Return _Filter
End Get
Set(ByVal value As Boolean)
_Filter = value
End Set
End Property
Private _AutoComplete As Boolean = False ' Updates - New
<Category("_ExCB specifics")> _
<Description("Shows only Rows containing typed text IN ANY COLUMN")> _
Public Property AutoComplete() As Boolean ' Updates - New Property
Get
Return _AutoComplete
End Get
Set(ByVal value As Boolean)
_AutoComplete = value
If _AutoComplete Then ' AutoComplete requires
Filterable = True ' Filterable = True
End If
End Set
End Property
Private _G_Resiz As Boolean = False ' Resizable ?
<Category("_ExCB specifics")> _
<Description("Can the list columns be resized?")> _
Public Property Resizable() As Boolean
Get
Return _G_Resiz
End Get
Set(ByVal value As Boolean)
_G_Resiz = value
End Set
End Property
Private _G_Reord As Boolean = False ' Reordable ?
<Category("_ExCB specifics")> _
<Description("Can the list columns be reordered?")> _
Public Property Reordable() As Boolean
Get
Return _G_Reord
End Get
Set(ByVal value As Boolean)
_G_Reord = value
End Set
End Property
Private _G_Sortab As Boolean = True ' Sortable ?
<Category("_ExCB specifics")> _
<Description("Can the list be sorted by columns?")> _
Public Property Sortable() As Boolean
Get
Return _G_Sortab
End Get
Set(ByVal value As Boolean)
_G_Sortab = value
End Set
End Property
Private _DispCol As Integer = 0 ' Index of Column to Display
<Category("_ExCB specifics")> _
<Description("Index of the column whose values are to be shown in the textbox")> _
Public Property DisplayColumn() As Integer
Get
Return _DispCol
End Get
Set(ByVal value As Integer)
_DispCol = value
End Set
End Property
<System.ComponentModel.Browsable(False)> _
Public ReadOnly Property Count() As Integer
Get
Return _iRows + 1
End Get
End Property
<System.ComponentModel.Browsable(False)> _
Public Property SelectedIndex() As Integer
Get
Return _SelRow
End Get
Set(ByVal value As Integer)
If value < 0 OrElse value > _iRows Then
MyLV1.SelectedItems.Clear()
_SelRow = -1
_Wrk = True
TextBox1.Text = ""
_Wrk = False
Else
Try ' Updates - New
MyLV1.Items(value).Selected = True
Catch ' Updates - New
End Try ' Updates - New
End If
End Set
End Property
<System.ComponentModel.Browsable(False)> _
Public Overrides Property Text() As String
Get
Return TextBox1.Text
End Get
Set(ByVal value As String)
_Wrk = True
Dim iFound As Integer = RowSelect(_DispCol, value)
If iFound = Nothing Then
MyLV1.SelectedItems.Clear()
Else
MyLV1.Items(iFound).Selected = True
End If
_Wrk = False
End Set
End Property
<System.ComponentModel.Browsable(False)> _
ReadOnly Property Columns() As ListView.ColumnHeaderCollection 'Columns in the Listview
Get
Return MyLV1.Columns
End Get
End Property
<System.ComponentModel.Browsable(False)> _
ReadOnly Property Items() As ListView.ListViewItemCollection 'Items in the listview
Get
Return MyLV1.Items
End Get
End Property
<DefaultValueAttribute(GetType(System.Drawing.Color), "Transparent")> _
Public Overrides Property BackColor() As System.Drawing.Color
Get
Return MyBase.BackColor
End Get
Set(ByVal Value As System.Drawing.Color)
MyBase.BackColor = Value
End Set
End Property
#End Region
#Region "Expandable properties"
Private Sizes_ As New Sz_
<TypeConverter(GetType(Sz_Conv))> _
<Category("_ExCB specifics")> _
<DesignerSerializationVisibility(DesignerSerializationVisibility.Content)> _
<Description("ExCB default sizes")> _
Public Property Sizes() As Sz_
Get
Return Sizes_
End Get
Set(ByVal value As Sz_)
Sizes_ = value
_CalcSize()
End Set
End Property
Private Colors_ As Co_ = New Co_
<TypeConverter(GetType(Co_Conv))> _
<Category("_ExCB specifics")> _
<DesignerSerializationVisibility(DesignerSerializationVisibility.Content)> _
<Description("ExCB default colors")> _
<RefreshProperties(RefreshProperties.Repaint)> _
Public Property Colors() As Co_
Get
Return Colors_
End Get
Set(ByVal value As Co_)
Colors_ = value
TextBox1.BackColor = Colors_.TBoxBackColor
TextBox1.ForeColor = Colors_.TBoxForeColor
End Set
End Property
#End Region
#Region "Public Event"
Public Event ItemSelected(ByVal ItemArray As Array, ByVal Index As Integer)
Public Event DropDownChanged(IsDroppedDown As Boolean)
#End Region
#Region "Public Methods"
Public Sub Clear(Optional ByVal AlsoColumns As Boolean = False)
_HideLV() ' Hide ListView
MyLV1.ECClear() ' Clear Embedded Controls
MyLV1.Items.Clear() ' Clear Items
MyLV1._ItmStr = Nothing ' Clear added rows
_SRows = Nothing
_NSRows = 0
_NDRows = 0
_iRows = -1
_SelRow = -1
_1stRow = True
_ListRowHeight = Sizes.ListRow_Height
_Wrk = True
TextBox1.Text = ""
_Wrk = False
Label1.Text = "0"
If AlsoColumns Then
MyLV1.Columns.Clear() ' Clear Columns
_ColAttr = Nothing ' Clear Column definitions
_NCols = 0
_ColsX = 0
_1stCol = True
_MaxSiz = _VSArea
End If
End Sub
Public Sub AddColumn(ByVal HeaderText As String, Optional ByVal Width As Integer = 80, _
Optional ByVal Align As HorizontalAlignment = HorizontalAlignment.Left, _
Optional ByVal DataType As DataType = DataType._Text, _
Optional ByVal Format As String = Nothing, _
Optional ByVal ForeColor As Color = Nothing, _
Optional ByVal BackColor As Color = Nothing, _
Optional ByVal ImgWidth As Integer = Nothing, _
Optional ByVal ImgHeight As Integer = Nothing, _
Optional ByVal SizeMode As SizeMode = SizeMode._Stretch, _
Optional ByVal Resizable As Boolean = True, _
Optional ByVal Reordable As Boolean = True, _
Optional ByVal Sortable As Boolean = True, _
Optional ByVal ArrowOnRight As Boolean = False)
' In VS2008, Colors are passed as "Integer", not as "Color", because
' "Optional parameters cannot have structure types"
MyLV1.Columns.Add(HeaderText, Width, Align)
If _NCols = 0 Then
ReDim _ColAttr(0)
Else
ReDim Preserve _ColAttr(_NCols)
End If
_ColAttr(_NCols)._Type = DataType
_ColAttr(_NCols)._Format = Format
_ColAttr(_NCols)._Align = Align
_ColAttr(_NCols)._X = _ColsX
_ColAttr(_NCols)._Width = Width
_ColAttr(_NCols).Resizable = Resizable
_ColAttr(_NCols).Reordable = Reordable
_ColAttr(_NCols).Sortable = Sortable
_ColAttr(_NCols)._ArrowOnRight = ArrowOnRight
' Column BackColor and ForeColor
If BackColor = Nothing Then
_ColAttr(_NCols)._BackColor = MyLV1.BackColor
Else
_ColAttr(_NCols)._BackColor = BackColor
End If
If ForeColor = Nothing Then
_ColAttr(_NCols)._ForeColor = Colors_.ListForeColor
Else
_ColAttr(_NCols)._ForeColor = ForeColor
End If
If _ColAttr(_NCols)._Type > 3 Then ' Booleans with image or Image
ReDim Preserve _TCImg(_NCImg)
_TCImg(_NCImg) = _NCols
_NCImg += 1 ' Column with image
If _ColAttr(_NCols)._Type = 4 Then ' Booleans with image
' Prepare Column "checkboxes" with selected ForeColor
_ColAttr(_NCols)._cbNo = ChgColor(Img_No, _ColAttr(_NCols)._ForeColor)
_ColAttr(_NCols)._cbYes = ChgColor(Img_Yes, _ColAttr(_NCols)._ForeColor)
End If
_ColAttr(_NCols)._ForeColor = _ColAttr(_NCols)._BackColor
If ImgWidth = Nothing Then
If _ColAttr(_NCols)._Type = DataType._Image Then
_ColAttr(_NCols)._ImgWidth = Sizes_.Image_Width
Else
_ColAttr(_NCols)._ImgWidth = Sizes_.YesNo_Height
End If
Else
_ColAttr(_NCols)._ImgWidth = ImgWidth
End If
If ImgHeight = Nothing Then
If _ColAttr(_NCols)._Type = DataType._Image Then
_ColAttr(_NCols)._ImgHeight = Sizes_.Image_Height
Else
_ColAttr(_NCols)._ImgHeight = Sizes_.YesNo_Height
End If
Else
_ColAttr(_NCols)._ImgHeight = ImgHeight
End If
If _ColAttr(_NCols)._Type = 5 Then ' Image
_ColAttr(_NCols)._SizeMode = SizeMode
' SizeMode Zoom not allowed in checkboxes (YesNo)
End If
End If
If ImgHeight + 2 > _ListRowHeight Then
' Adjust ListView Row Height
_ListRowHeight = Math.Max(Math.Max(ImgHeight + 2, Sizes.ListRow_Height), _ListRowHeight)
IL.ImageSize = New Size(1, _ListRowHeight)
End If
_NCols += 1
_ColsX += Width
_MaxSiz += Width
End Sub
Public Sub AddRow(ByVal ItemArray As Object())
If _1stRow Then
' Only first row
MyLV1._ColsAttr(_ColAttr)
_CalcSize()
_1stRow = False
End If
Dim IA_Txt(_NCols - 1) As String ' Initialize String Array
For C As Integer = 0 To _NCols - 1 ' Every Column
Dim CA As _cAttr = _ColAttr(C)
If CA._Type = DataType._Image Then ' Image DataType
' An Image is always created
Dim _imgIndex As Integer = If(MyLV1._Images Is Nothing, 0, MyLV1._Images.Length)
ReDim Preserve MyLV1._Images(_imgIndex)
If TypeOf (ItemArray(C)) Is Image Then ' Image sent?
MyLV1._Images(_imgIndex) = ItemArray(C)
ElseIf TypeOf (ItemArray(C)) Is String Then
Dim Path As String = ItemArray(C)
If Path > "" Then ' Path supplied?
Try ' Try to get Image from File
MyLV1._Images(_imgIndex) = Image.FromFile(Path)
Catch ' Bad Path or image error
MyLV1._Images(_imgIndex) = Nothing
End Try
Else ' Path not supplied
MyLV1._Images(_imgIndex) = Nothing
End If
Else ' Bad data type
MyLV1._Images(_imgIndex) = Nothing
End If
IA_Txt(C) = _imgIndex
Else ' All other DataTypes
IA_Txt(C) = CType(ItemArray(C), String)
If CA._Type < 3 Then
If CA._Format IsNot Nothing Then ' Formatted data?
Try
If CA._Type = DataType._Date Then
IA_Txt(C) = Format(CDate(IA_Txt(C)), CA._Format)
ElseIf CA._Type = DataType._Numeric Then
IA_Txt(C) = Format(CDbl(IA_Txt(C)), CA._Format)
Else
IA_Txt(C) = Format(IA_Txt(C), CA._Format)
End If
Catch ex As Exception
If (MsgBox("Column Index: " & C.ToString & vbCr & _
"Row Index: " & (_iRows + 1).ToString & vbCr & _
"SubItem: " & IA_Txt(C).ToString & vbCr & vbCr & _
ex.Message, MsgBoxStyle.OkCancel, "Data conversion error")) = MsgBoxResult.Cancel Then
Me.ParentForm.Close()
End If
End Try
End If
End If
End If
Next
_iRows += 1
ReDim Preserve MyLV1._ItmStr(_iRows)
MyLV1._ItmStr(_iRows) = IA_Txt
_SelectRow(_iRows)
End Sub
Public Function RowSelect(ByVal ColIndex As Integer, ByVal Value As Object, Optional ByVal GetItem As Integer = -1)
' ColIndex: Column Index to search
' Value: value (string, number, boolean) to search
' GetItem: Column Index of item to return [of Row where Value(ColIndex) is found]
If MyLV1.Columns.Count > 0 Then
Dim _Found As Integer = -1
If MyLV1._ItmStr.Length > MyLV1.Items.Count Then
' Not all Items selected?
_SelectAllRows()
_DisplayRows()
End If
For iCtr As Integer = 0 To _iRows ' Search specific (ColIndex) element
If MyLV1.Items(iCtr).SubItems(ColIndex).Text = If(_ColAttr(ColIndex)._Type = 3 _
OrElse _ColAttr(ColIndex)._Type = 4, _Bool2Char(Value), Value) Then
_Found = iCtr
Exit For
End If
Next
If _Found >= 0 Then ' ITEM FOUND
_SelRow = _Found
_Wrk = True
TextBox1.Text = MyLV1.Items(_Found).SubItems(DisplayColumn).Text
_Wrk = False
MyLV1.Items(_Found).Selected = True
MyLV1.Select()
If GetItem >= 0 Then ' Item required
Return If(_ColAttr(GetItem)._Type = 3 OrElse _ColAttr(GetItem)._Type = 4, _
_Char2Bool(MyLV1.Items(_Found).SubItems(GetItem).Text), _
MyLV1.Items(_Found).SubItems(GetItem).Text)
End If
Return _Found ' Return Found Index
Else ' ITEM NOT FOUND
SelectedIndex = -1
_Wrk = True
TextBox1.Text = ""
MyLV1.SelectedItems.Clear()
_Wrk = False
MyLV1_ItemSelectionChanged(Nothing, Nothing) ' For firing the event
End If
End If
Return Nothing ' If no Columns or Item not found
End Function
Public Function GetImage(ImageIndex As Integer) As Image
Dim Img As Image = Nothing
If ImageIndex >= 0 Then
If MyLV1._Images.Length > 0 And MyLV1._Images.Length > ImageIndex Then
Img = MyLV1._Images(ImageIndex)
End If
End If
Return Img
End Function
Public Function ARGB(ByVal C As Color) As Integer
Return C.ToArgb
End Function
Public Sub AdjustListHeight() ' Updates - New Method
Try
Dim Parent_csH As Integer = Me.ParentForm.ClientSize.Height ' Exclude TitleBar and Borders
Dim HeaderH = Math.Max(Sizes.ListHeader_Height, TextRenderer.MeasureText(" ", Me.Font).Height + 4)
Dim RestH As Integer = Parent_csH - Me.Top - MyLV1.Top - HeaderH
_MaxDsp = RestH \ (_ListRowHeight + 1)
Dim MinRows As Integer = Math.Min(_MaxDsp, MyLV1.Items.Count + 1)
If MyLV1.Visible Then
MyLV1.Height = HeaderH + MinRows * (_ListRowHeight + 1)
Me.Height = _LblBoxH + MyLV1.Height
Else
_HideLV()
End If
Catch
End Try
End Sub
#End Region
#Region "Sub New"
Public Sub New()
' This call is required by the Windows Form Designer.
InitializeComponent()
' Add any initialization after the InitializeComponent() call.
Me.SetStyle(ControlStyles.SupportsTransparentBackColor, True)
Me.BackColor = Color.Transparent
' The 2 lines above are suggested by Microsoft to give Controls
' a Transparent BackColor:
' http://msdn.microsoft.com/en-us/library/wk5b13s4(v=vs.85).aspx
' Unfortunatelly, it seems do not work...
_BStyle = Windows.Forms.BorderStyle.Fixed3D
IL813.ImageSize = New Size(8, 13)
IL813.Images.Add(My.Resources.SortA)
IL813.Images.Add(My.Resources.SortD)
End Sub
#End Region
#Region "ListView code"
Private Sub MyLV1_ItemSelectionChanged(ByVal sender As Object, ByVal e As System.Windows.Forms.ListViewItemSelectionChangedEventArgs) Handles MyLV1.ItemSelectionChanged
If _Wrk = False Then
Dim _iCC = _NCols - 1
Dim _Itms(_iCC)
If e IsNot Nothing Then
Try
_SelRow = e.ItemIndex
_HideLV()
For iCtr As Integer = 0 To _iCC
If _ColAttr(iCtr)._Type = DataType._LogicTxt OrElse _ColAttr(iCtr)._Type = DataType._LogicImg Then
_Itms(iCtr) = _Char2Bool(MyLV1.Items(_SelRow).SubItems(iCtr).Text)
Else
_Itms(iCtr) = MyLV1.Items(_SelRow).SubItems(iCtr).Text
End If
Next
_Wrk = True
TextBox1.Text = _Itms(DisplayColumn)
_Wrk = False
'RaiseEvent ItemSelected(_Itms, _SelRow)
Catch ex As Exception
MsgBox(ex.Message, , "ItemSelectionChanged")
End Try
End If
RaiseEvent ItemSelected(_Itms, _SelRow)
End If
End Sub
Private Sub ClearArrow()
For iCtr As Integer = 0 To _NCols - 1
If _ColAttr(iCtr)._Sort > 0 Then ' Previous sorted column
_ColAttr(iCtr)._Sort = 0
SetItem(_ColAttr(iCtr)._Align, iCtr) ' Send message HDM_SETITEM
MyLV1.Invalidate(True)
Exit For
End If
Next
End Sub
Private Sub MyLV1_ColumnClick(ByVal sender As Object, ByVal e As System.Windows.Forms.ColumnClickEventArgs) Handles MyLV1.ColumnClick
If _G_Sortab Then
If _ColAttr(e.Column).Sortable Then
' First, clear arrow of previous sorted column (if any)
For iCtr As Integer = 0 To _NCols - 1
If iCtr <> e.Column Then
If _ColAttr(iCtr)._Sort > 0 Then ' Previous sorted column
_ColAttr(iCtr)._Sort = 0
SetItem(_ColAttr(iCtr)._Align, iCtr) ' Send message HDM_SETITEM
MyLV1.Invalidate(True)
End If
End If
Next
' Next, draw arrow and sort data
For iCtr As Integer = 0 To _NCols - 1
If iCtr = e.Column Then ' Clicked column
If _ColAttr(iCtr)._Sort = 1 Then
_ColAttr(iCtr)._Sort = 2 ' If Ascending, -> Descending
Else
_ColAttr(iCtr)._Sort = 1 ' If Descending or None, -> Ascending
End If
SetItem(_ColAttr(iCtr)._Align, iCtr) ' Send message HDM_SETITEM
MyLV1.ListViewItemSorter = New SortLV(e.Column, _ColAttr(iCtr)._Type, _ColAttr(iCtr)._Sort)
End If
Next
End If
End If
End Sub
Private Sub SetItem(ByVal HA As HorizontalAlignment, ByVal Index As Integer)
' Send message HDM_SETITEM
Dim HDI As New HDITEM
HDI.mask = Defs.HDI_FORMAT
HDI.fmt = HDF_OWNERDRAW Or HA
Defs.SendMessage(MyLV1.Handle, HDM_SETITEM, Index, HDI)
End Sub
Private Sub MyLV1_DrawColumnHeader(ByVal sender As Object, ByVal e As DrawListViewColumnHeaderEventArgs) Handles MyLV1.DrawColumnHeader
If _Wrk = False Then
' Draw Graphics
e.DrawDefault = False
e.Graphics.FillRectangle(New SolidBrush(Colors_.HeadBackColor), e.Bounds)
Dim _Bnds As Rectangle = e.Bounds
_Bnds.Width -= 1
_Bnds.Height -= 2
e.Graphics.DrawRectangle(SystemPens.ControlDarkDark, _Bnds)
_Bnds.Width -= 1
_Bnds.Height -= 1
e.Graphics.DrawLine(SystemPens.ControlLightLight, _Bnds.X, _Bnds.Y, _Bnds.Right, _Bnds.Y)
e.Graphics.DrawLine(SystemPens.ControlLightLight, _Bnds.X, _Bnds.Y, _Bnds.X, _Bnds.Bottom)
e.Graphics.DrawLine(SystemPens.ControlDark, (_Bnds.X + 1), _Bnds.Bottom, _Bnds.Right, _Bnds.Bottom)
e.Graphics.DrawLine(SystemPens.ControlDark, _Bnds.Right, (_Bnds.Y + 1), _Bnds.Right, _Bnds.Bottom)
If e.ColumnIndex = _NCols - 1 Then ' If last column
' Paint the area from last column to the end of the header
Dim r1 As New Rectangle(e.Bounds.Right, e.Bounds.Top, Me.Width - e.Bounds.Right, e.Bounds.Height)
e.Graphics.FillRectangle(New SolidBrush(Colors_.HeadBackColor), r1)
End If
' Draw Text
Dim _Flags As TextFormatFlags = e.Header.TextAlign Or TextFormatFlags.VerticalCenter
If _Flags > 4 Then
_Flags = (_Flags Xor 3)
End If
Dim _Txt As String = e.Header.Text
Dim _Size As Size = TextRenderer.MeasureText(" ", e.Font)
Dim _TxW As Integer = _Size.Width
_Bnds = Rectangle.Inflate(e.Bounds, -_TxW, 0)
TextRenderer.DrawText(e.Graphics, _Txt, e.Font, _Bnds, Colors_.HeadForeColor, _Flags)
' Draw Sort arrow ?
If _ColAttr(e.ColumnIndex).Sortable Then
If _ColAttr(e.ColumnIndex)._Sort > 0 Then
' Yes, draw Sort Arrow - Left or Right aligned, Height centered
e.Graphics.DrawImage(IL813.Images(_ColAttr(e.ColumnIndex)._Sort - 1), e.Bounds.X + (_TxW - 8) \ 2 + _
If(_ColAttr(e.ColumnIndex)._ArrowOnRight, _Bnds.Width + _TxW - 3, 2), _
e.Bounds.Y + (e.Bounds.Height - 13) \ 2, 8, 13)
End If
End If
If _1stCol Then ' First time Column 0 is drawn
Sizes_.ListRow_Height = Math.Max(Sizes_.ListRow_Height, _Size.Height)
_ListRowHeight = Math.Max(Sizes_.ListRow_Height, _ListRowHeight) ' Set effective ListView Row Height
_1stCol = False
End If
End If
End Sub
Private Sub MyLV1_DrawSubItem(ByVal sender As Object, ByVal e As DrawListViewSubItemEventArgs) Handles MyLV1.DrawSubItem
e.DrawDefault = True
End Sub
Private Sub MyLV1_ColumnWidthChanging(ByVal sender As Object, ByVal e As System.Windows.Forms.ColumnWidthChangingEventArgs) Handles MyLV1.ColumnWidthChanging
If Not (_G_Resiz And _ColAttr(e.ColumnIndex).Resizable) Then
e.Cancel = True
e.NewWidth = _ColAttr(e.ColumnIndex)._Width
End If
End Sub
Private Sub MyLV1_ColumnReordered(ByVal sender As Object, ByVal e As System.Windows.Forms.ColumnReorderedEventArgs) Handles MyLV1.ColumnReordered
Dim iCol As Integer
For iCtr As Integer = 0 To _NCols - 1
If Me.Columns(iCtr).DisplayIndex = e.OldDisplayIndex Then
iCol = iCtr
Exit For
End If
Next
If Not (_G_Resiz And _ColAttr(iCol).Reordable) Then
e.Cancel = True
End If
End Sub
#End Region
#Region "TextBox & Button code"
Private Sub TextBox1_Click(sender As Object, e As EventArgs) Handles TextBox1.Click
If _Filter = False Then
Button1_MouseDown(Nothing, Nothing)
End If
End Sub
Private Sub TextBox1_KeyPress(sender As Object, e As KeyPressEventArgs) Handles TextBox1.KeyPress
If _Filter Then
If e.KeyChar = ChrW(Keys.Return) Then
_MB_Right = False
Button1_MouseDown(Nothing, Nothing)
End If
Else
e.KeyChar = Nothing
End If
End Sub
Private Sub TextBox1_TextChanged(sender As Object, e As EventArgs) Handles TextBox1.TextChanged
If _Wrk = False Then
' Select Rows matching specified Text
Label1.Text = "0"
_NSRows = 0
_SRows = Nothing
Dim IA() As String
For iR = 0 To _iRows
IA = MyLV1._ItmStr(iR)
For iC As Integer = 0 To _NCols - 1
If Strings.InStr(IA(iC), Text, CompareMethod.Text) > 0 Then
_SelectRow(iR)
Exit For
End If
Next
Next
_TBtyped = True
If _AutoComplete Then ' Updates - New
Button1_MouseDown(Nothing, Nothing) ' Updates - New
End If ' Updates - New
End If
End Sub
Private Sub Button1_MouseDown(sender As Object, e As MouseEventArgs) Handles Button1.MouseDown
If MyLV1.Visible Then
' Hide ListView
_HideLV()
Else
' Witch Mouse Button was pressed?
If e Is Nothing Then ' No Mouse clicked, comes from
_MB_Right = False ' a <Return> in TextBox1 (or Click, if not Filterable)
Else
_MB_Right = (e.Button = Windows.Forms.MouseButtons.Right)
End If
_Wrk = True
If _TBtyped Then
_DisplayRows()
If TextBox1.Text <> _TxtBk Then
_TxtBk = TextBox1.Text
End If
_TBtyped = False
Else
If TextBox1.Text = "" OrElse _MB_Right Then
' Select all rows
TextBox1.Text = ""
If (_iRows + 1) <> _NDRows Then
_SelectAllRows()
_DisplayRows()
End If
End If
End If
' Show ListView
Label1.Text = MyLV1.Items.Count.ToString
Me.Width = Math.Max(_MaxSiz, _MinWidth)
MyLV1.Visible = True
' Rows to show (Smaller of Max Items to display / Item count + 1
Dim MX As Integer = Math.Min(_MaxDsp, MyLV1.Items.Count + 1)
' Compute ListView Height (Header + Rows)
Dim LX As Integer = Math.Max(Sizes.ListHeader_Height, _
TextRenderer.MeasureText(" ", Me.Font).Height + 4) + _
MX * (_ListRowHeight + 1) ' Updates - Updated
Me.Height = _LblBoxH + LX
MyLV1.Height = LX
RaiseEvent DropDownChanged(True)
_Wrk = False
End If
End Sub
#End Region
#Region "Fade in / Fade out"
Private Sub TextBox1_MouseEnter(ByVal sender As Object, ByVal e As System.EventArgs) Handles TextBox1.MouseEnter
Fade(Button1, True)
End Sub
Private Sub TextBox1_MouseLeave(ByVal sender As Object, ByVal e As System.EventArgs) Handles TextBox1.MouseLeave
Fade(Button1, False)
End Sub
Private Sub Button1_MouseEnter(ByVal sender As Object, ByVal e As System.EventArgs) Handles Button1.MouseEnter
Fade(CType(sender, Control), True)
End Sub
Private Sub Button1_MouseLeave(ByVal sender As Object, ByVal e As System.EventArgs) Handles Button1.MouseLeave
Fade(CType(sender, Control), False)
End Sub
Private Sub Fade(ByVal Ctrl As Control, ByVal Hovering As Boolean)
' Thanks to Burton Johnson (ballisticnylon@msn.com)
' GlowButtons - April 12, 2003
' You can view the original code at:
' http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=1129&lngWId=10
' I made some modifications, because in some versions of Windows, the original values
' [SystemColors.ActiveCaption (0,84,227)] does not work, a runtime error occurs
' Therefore, Windows 8 color values for ActiveCaption (153,180,209) are used
Dim Sb_R, Sb_G, Sb_B As Int16 ' <--- RGB values for the starting backcolor
Dim Sf_R, Sf_G, Sf_B As Int16 ' <--- RGB values for the starting forecolor
Dim Eb_R, Eb_G, Eb_B As Int16 ' <--- RGB values for the ending backcolor
Dim Ef_R, Ef_G, Ef_B As Int16 ' <--- RGB values for the ending forecolor
Select Case Hovering ' True for MouseEnter, False for MouseLeave
Case True
Sb_R = 255 ' Assign the variables the
Sb_G = 255 ' appropriate values based
Sb_B = 255 ' on system-defined colors
' ' for control and control text
Sf_R = 255
Sf_G = 255
Sf_B = 255
Eb_R = 153 ' Assign the variables the
Eb_G = 180 ' appropriate values based
Eb_B = 209 ' on system-defined colors
' ' for the title bar and the
Ef_R = 0 ' title bar's text.
Ef_G = 0
Ef_B = 0
Case False
Sb_R = 153 ' Assign the variables the
Sb_G = 180 ' appropriate values based
Sb_B = 209 ' on system-defined colors
' ' for the title bar and the
Sf_R = 0 ' title bar's text.
Sf_G = 0
Sf_B = 0
Eb_R = 255 ' Assign the variables the
Eb_G = 255 ' appropriate values based
Eb_B = 255 ' on system-defined colors
' ' for control and control
Ef_R = 255 ' text.
Ef_G = 255
Ef_B = 255
End Select
Dim b_RIncrement As Int16 = Round(((Eb_R - Sb_R) / 16), 0) ' Find the increments that
Dim b_GIncrement As Int16 = Round(((Eb_G - Sb_G) / 16), 0) ' the RGB values will take;
Dim b_BIncrement As Int16 = Round(((Eb_B - Sb_B) / 16), 0) ' 1/16th of the difference
' ' between the start and end
Dim f_RIncrement As Int16 = Round(((Ef_R - Sf_R) / 16), 0) ' values, rounded to the
Dim f_GIncrement As Int16 = Round(((Ef_G - Sf_G) / 16), 0) ' nearest integer.
Dim f_BIncrement As Int16 = Round(((Ef_B - Sf_B) / 16), 0)
Dim bR As Int16 = Sb_R ' \
Dim bG As Int16 = Sb_G ' }-- the RGB values for the backcolor as it changes.
Dim bB As Int16 = Sb_B ' /
Dim fR As Int16 = Sf_R ' \
Dim fG As Int16 = Sf_G ' }-- the RGB values for the forecolor as it changes.
Dim fB As Int16 = Sf_B ' /
Dim count As Int16
For count = 0 To 14
bR += b_RIncrement ' Add the appropriate increments to the
bG += b_GIncrement ' RGB values. The result is a nifty
bB += b_BIncrement ' "cross-fade" effect.
fR += f_RIncrement
fG += f_GIncrement
fB += f_BIncrement
Ctrl.BackColor = Color.FromArgb(bR, bG, bB) ' Repaint the button using the
Ctrl.ForeColor = Color.FromArgb(fR, fG, fB) ' current RGB values, and refresh
Ctrl.Refresh() ' the button.
Threading.Thread.Sleep(30 - (count * 2)) ' Wait a certain number of milliseconds,
' ' which is a factor of the current count.
' ' I tweaked these numbers to get a decent
' ' effect; feel free to adjust these
' ' numbers to achieve an effect you like.
Next
Select Case Hovering
Case True
Ctrl.BackColor = Color.FromArgb(153, 180, 209) ' Finish the effect by painting
Ctrl.ForeColor = Color.Black ' the control with it's final
Case False ' look, depending on whether
Ctrl.BackColor = Color.White ' we're fading in or out.
Ctrl.ForeColor = Color.White
End Select
End Sub
#End Region
#Region "Component Load & Resize"
Private Sub ExCB_Load(ByVal sender As Object, ByVal e As EventArgs) Handles Me.Load
Me.Height = _LblBoxH
MyLV1.Visible = False
MyLV1.Font = Me.Font
MyLV1.BackColor = Colors_.ListBackColor
MyLV1.ForeColor = Colors_.ListForeColor
Label1.Font = Me.Font
TextBox1.BorderStyle = _BStyle
TextBox1.Font = Me.Font
TextBox1.BackColor = Colors_.TBoxBackColor
TextBox1.ForeColor = Colors_.TBoxForeColor
MyLV1._HeaderHeight = Sizes_.ListHeader_Height
MyLV1.HeadBackColor = Colors_.HeadBackColor
MyLV1.HeadForeColor = Colors_.HeadForeColor
MyLV1.SmallImageList = IL
_ListRowHeight = Sizes_.ListRow_Height
IL.ImageSize = New Size(1, _ListRowHeight)
MyLV1.Sortable = _G_Sortab
End Sub
Private Sub ExCB_Resize(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Resize
If Me.DesignMode Then
If Me.Width < 37 Then ' Minimum width
Me.Width = 37
End If
_MinWidth = Me.Width
TextBox1.Width = _MinWidth
Label1.Width = _MinWidth - _TxtHeight
Button1.Left = _MinWidth - _TxtHeight
_CalcSize()
End If
End Sub
#End Region
#Region "Private Subs & Functions"
Private Sub _SelectRow(Row As Integer)
ReDim Preserve _SRows(_NSRows)
_SRows(_NSRows) = Row
_NSRows += 1
Label1.Text = _NSRows.ToString
_HideLV()
MyLV1.ListViewItemSorter = Nothing
End Sub
Private Sub _SelectAllRows()
ReDim _SRows(_iRows)
For iR As Integer = 0 To _iRows
_SRows(iR) = iR
Next
_NSRows = _iRows + 1
Label1.Text = _NSRows.ToString
End Sub
Private Sub _DisplayRows()
ClearArrow()
MyLV1.ECClear() ' Clear Embedded Controls
MyLV1.Items.Clear() ' Clear Items
_NDRows = 0 ' Number of Displayed Rows
If _NSRows > 0 Then ' Any Row(s) selected?
'
If _NCImg > 0 Then
ReDim Preserve _EC_Tmp(_NCImg - 1, _NSRows - 1)
End If
' Phase 1 - Add all selected rows
For iR As Integer = 0 To _NSRows - 1
AddSelRow(_SRows(iR), iR)
Next
' Phase 2 - Add all Embedded Controls
If _NCImg > 0 Then
For iR As Integer = 0 To _NSRows - 1
For iC As Integer = 0 To _NCImg - 1
With _EC_Tmp(iC, iR)
MyLV1._AddEmbeddedControl(.Row, .Col, .Img, .Width, .Height, .SzMod)
End With
Next
Next
End If
End If
End Sub
Private Function i_Of_C(C As Integer) As Integer
' Index of "image" Column
Dim i As Integer
For i = 0 To _NCImg - 1
If _TCImg(i) = C Then
Exit For
End If
Next
Return i
End Function
Private Sub AddSelRow(FxdRow As Integer, SelRow As Integer)
Dim Itm As ListViewItem = New ListViewItem(MyLV1._ItmStr(FxdRow))
Itm.UseItemStyleForSubItems = False
' Text (all types). Booleans are stored as Chr(254) for True, Chr(168) for False NEW
For C As Integer = 0 To _NCols - 1
If _ColAttr(C)._Type = DataType._LogicTxt OrElse _ColAttr(C)._Type = DataType._LogicImg Then
If _ColAttr(C)._Type = DataType._LogicTxt Then
Itm.SubItems(C).Font = New System.Drawing.Font("Wingdings", Sizes_.YesNo_Height, FontStyle.Regular)
End If
Itm.SubItems(C).Text = _Bool2Char(CBool(Itm.SubItems(C).Text))
End If
Itm.SubItems(C).BackColor = _ColAttr(C)._BackColor
Itm.SubItems(C).ForeColor = If(_ColAttr(C)._Type > 3, _ColAttr(C)._BackColor, _ColAttr(C)._ForeColor)
Next
MyLV1.Items.Add(Itm)
' Boolean & Image types - creates Embedded Control
For C As Integer = 0 To _NCols - 1
_Wrk = True
If _ColAttr(C)._Type = DataType._LogicImg Then
' Creates temporary Embedded Control definitions for (image) checkbox
Dim iC As Integer = i_Of_C(C)
With _EC_Tmp(iC, SelRow)
.Row = SelRow
.Col = C
.Img = If(_Char2Bool(Itm.SubItems(C).Text), _ColAttr(C)._cbYes, _ColAttr(C)._cbNo)
.Width = _ColAttr(C)._ImgWidth
.Height = _ColAttr(C)._ImgHeight
.SzMod = SizeMode._Stretch
End With
ElseIf _ColAttr(C)._Type = DataType._Image Then
' Creates temporary Embedded Control definitions for (true) image
Dim iC As Integer = i_Of_C(C)
With _EC_Tmp(iC, SelRow)
.Row = SelRow
.Col = C
.Img = MyLV1._Images(Val(Itm.SubItems(C).Text))
.Width = _ColAttr(C)._ImgWidth
.Height = _ColAttr(C)._ImgHeight
.SzMod = _ColAttr(C)._SizeMode
End With
End If
_Wrk = False
Next
_NDRows += 1
_SelRow = -1
End Sub
Private Sub _HideLV()
' Hide ListView
MyLV1.Visible = False
Me.Height = _LblBoxH
Me.Width = _MinWidth
RaiseEvent DropDownChanged(False)
End Sub
Private Function ChgColor(ByVal pbFrom As Image, ByVal ColorTo As Color) As Image
Dim iTo As Image = Nothing
If ColorTo <> Color.Black Then
Dim CM As New ColorMap
CM.OldColor = Color.Black
CM.NewColor = ColorTo
Dim RemapTab() As ColorMap = {CM}
Dim iAttr As New ImageAttributes
iAttr.SetRemapTable(RemapTab, ColorAdjustType.Bitmap)
Dim iFrom As Bitmap = pbFrom.Clone
iTo = New Bitmap(iFrom.Width, iFrom.Height)
Dim G As Graphics = Graphics.FromImage(iTo)
Dim rect As Rectangle = Rectangle.Round(iTo.GetBounds(GraphicsUnit.Pixel))
G.DrawImage(iFrom, rect, 0, 0, iTo.Width, iTo.Height, GraphicsUnit.Pixel, iAttr)
G.Dispose()
iFrom.Dispose()
iAttr.Dispose()
End If
Return iTo
End Function
Private Sub _CalcSize()
' Calculates all component & subcomponent sizes & locations
Dim tbN As New TextBox ' TextBox without BorderStyle
tbN.Font = Me.Font
tbN.BorderStyle = Windows.Forms.BorderStyle.None
Dim tbF As New TextBox ' TextBox with BorderStyle
tbF.Font = Me.Font
tbF.BorderStyle = Windows.Forms.BorderStyle.FixedSingle
Dim xHbsNone As Integer = tbN.Height ' Height without BorderStyle
Dim xHbsFixed As Integer = tbF.Height ' Height with BorderStyle
Dim LblH As Integer = xHbsFixed - 7
TextBox1.BorderStyle = _BStyle
TextBox1.Width = _MinWidth
Label1.Height = LblH
Dim xH_OK As Integer = If(_BStyle = 0, xHbsNone, xHbsFixed)
Label1.Visible = (_CtLoc > 0)
If (_CtLoc And 1) > 0 Then ' Top Left/Right
Label1.Top = 0
TextBox1.Top = LblH
Else ' Bottom Left/Right
TextBox1.Top = 0
Label1.Top = xH_OK
End If
Label1.TextAlign = If(_CtLoc > 2, ContentAlignment.MiddleRight, ContentAlignment.MiddleLeft)
_LblBoxH = xH_OK + LblH
MyLV1.Top = _LblBoxH - 1 - If((_CtLoc And 1) = 0, LblH, 0)
Me.Height = _LblBoxH
Button1.Top = TextBox1.Top + 1
Button1.Width = xH_OK
Button1.Height = xH_OK - 1
Button1.Left = Me.Width - xH_OK
Label1.Width = Button1.Left
Dim _TxH As Integer = TextRenderer.MeasureText(" ", Me.Font).Height
_ListRowHeight = Math.Max(Math.Max(_TxH, Sizes.ListRow_Height), _ListRowHeight)
MyLV1._HeaderHeight = Math.Max(Sizes.ListHeader_Height, _TxH + 4)
tbN.Dispose()
tbF.Dispose()
End Sub
Private Function _Bool2Char(ByVal VarBool As Boolean) As String
Return If(VarBool, Chr(254), Chr(168))
End Function
Private Function _Char2Bool(ByVal VarChar As String) As Boolean
Return If(VarChar = Chr(254), True, False)
End Function
#End Region
End Class ' ExCB
#End Region
#Region "Class Sz_"
<TypeConverter(GetType(Sz_Conv))> _
Public Class Sz_
Public Sub New()
End Sub
Public Sub New(ByVal IH As Integer, ByVal IW As Integer, ByVal HH As Integer, ByVal Ro As Integer, ByVal CB As Integer)
Me.Image_Height = IH
Me.Image_Width = IW
Me.ListHeader_Height = HH
Me.ListRow_Height = Ro
Me.YesNo_Height = CB
End Sub
Private _ImgH As Integer = 13
<Category("_ExCB specifics")> _
<Description("The Height of the Images in pixels")> _
Public Property Image_Height() As Integer
Get
Return _ImgH
End Get
Set(ByVal value As Integer)
_ImgH = value
End Set
End Property
Private _ImgW As Integer = 13
<Category("_ExCB specifics")> _
<Description("The Width of the Images in pixels")> _
Public Property Image_Width() As Integer
Get
Return _ImgW
End Get
Set(ByVal value As Integer)
_ImgW = value
End Set
End Property
Private _HeadH As Integer = 20
<Category("_ExCB specifics")> _
<Description("The Height of the List Header in pixels")> _
Public Property ListHeader_Height() As Integer
Get
Return _HeadH
End Get
Set(ByVal value As Integer)
If value < 20 Then
Throw New ArgumentOutOfRangeException("ListHeader_Height", "Value must be greather than 19")
Else
_HeadH = value
End If
End Set
End Property
Private _RowH As Integer = 16
<Category("_ExCB specifics")> _
<Description("The Height of the List Rows in pixels")> _
Public Property ListRow_Height() As Integer
Get
Return _RowH
End Get
Set(ByVal value As Integer)
If value < 16 Then
Throw New ArgumentOutOfRangeException("ListRow_Height", "Value must be greather than 15")
Else
_RowH = value
End If
End Set
End Property
Private _YN_H As Integer = 13
<Category("_ExCB specifics")> _
<Description("The Height of the 'CheckBoxes' in pixels")> _
Public Property YesNo_Height() As Integer
Get
Return _YN_H
End Get
Set(ByVal value As Integer)
_YN_H = value
End Set
End Property
Public Overrides Function ToString() As String
Return String.Format("{0}; {1}; {2}; {3}; {4}", Me._ImgH, Me._ImgW, Me._HeadH, Me._RowH, Me._YN_H)
End Function
End Class
#End Region
#Region "Class Sz_Conv"
Friend Class Sz_Conv
Inherits ExpandableObjectConverter
Public Overrides Function GetCreateInstanceSupported(ByVal context As ITypeDescriptorContext) As Boolean
Return True
End Function
Public Overrides Function CreateInstance(ByVal context As ITypeDescriptorContext, _
ByVal propertyValues As IDictionary) As Object
Dim _Szs As New Sz_
With _Szs
Integer.TryParse(propertyValues("Image_Height"), .Image_Height)
Integer.TryParse(propertyValues("Image_Width"), .Image_Width)
Integer.TryParse(propertyValues("ListHeader_Height"), .ListHeader_Height)
Integer.TryParse(propertyValues("ListRow_Height"), .ListRow_Height)
Integer.TryParse(propertyValues("YesNo_Height"), .YesNo_Height)
End With
Return _Szs
End Function
Public Overloads Overrides Function CanConvertFrom(ByVal context As ITypeDescriptorContext, _
ByVal sourceType As Type) As Boolean
If (sourceType Is GetType(String)) Then
Return True
End If
Return MyBase.CanConvertFrom(context, sourceType)
End Function
Public Overloads Overrides Function ConvertFrom(ByVal context As ITypeDescriptorContext, _
ByVal culture As CultureInfo, _
ByVal value As Object) As Object
If (TypeOf value Is String) Then
Try
Dim Sz_Items() As Integer = Array.ConvertAll(value.ToString.Split("; "), Function(s) CInt(s))
Dim _Szs As New Sz_
_Szs.Image_Height = Sz_Items(0)
_Szs.Image_Width = Sz_Items(1)
_Szs.ListHeader_Height = Sz_Items(2)
_Szs.ListRow_Height = Sz_Items(3)
_Szs.YesNo_Height = Sz_Items(4)
Return _Szs
Catch
Throw New ArgumentException("Cannot convert '" & CStr(value) & "' to type Integer")
End Try
End If
Return MyBase.ConvertFrom(context, culture, value)
End Function
Public Overloads Overrides Function ConvertTo(ByVal context As ITypeDescriptorContext, _
ByVal culture As CultureInfo, _
ByVal value As Object, _
ByVal destinationType As Type) As Object
If destinationType Is GetType(String) _
AndAlso TypeOf value Is Sz_ Then
Dim _Szs As Sz_ = DirectCast(value, Sz_)
Return String.Format("{0}; {1}; {2}; {3}; {4}", _
_Szs.Image_Height, _Szs.Image_Width, _Szs.ListHeader_Height, _Szs.ListRow_Height, _Szs.YesNo_Height)
ElseIf destinationType Is GetType(InstanceDescriptor) _
AndAlso TypeOf value Is Sz_ Then
Dim CI As ConstructorInfo = GetType(Sz_).GetConstructor(New Type() _
{GetType(Integer), GetType(Integer), GetType(Integer)})
Dim _Szs As Sz_ = DirectCast(value, Sz_)
Dim Args As New List(Of Integer)(New Integer() _
{_Szs.Image_Height, _Szs.Image_Width, _Szs.ListHeader_Height, _Szs.ListRow_Height, _Szs.YesNo_Height})
Return New InstanceDescriptor(CI, Args)
End If
Return MyBase.ConvertTo(context, culture, value, destinationType)
End Function
End Class
#End Region
#Region "Class Co_"
<TypeConverter(GetType(Co_Conv))> _
Public Class Co_
Public Sub New()
End Sub
Public Sub New(ByVal HBC As Color, ByVal HFC As Color, ByVal LBC As Color, ByVal LFC As Color, ByVal BBC As Color, ByVal BFC As Color)
Me.HeadBackColor = HBC
Me.HeadForeColor = HFC
Me.ListBackColor = LBC
Me.ListForeColor = LFC
Me.TBoxBackColor = BBC
Me.TBoxForeColor = BFC
End Sub
Public Sub New(ByVal HBC As String, ByVal HFC As String, ByVal LBC As String, ByVal LFC As String, ByVal BBC As String, ByVal BFC As String)
Me.HeadBackColor = Color.FromName(HBC)
Me.HeadForeColor = Color.FromName(HFC)
Me.ListBackColor = Color.FromName(LBC)
Me.ListForeColor = Color.FromName(LFC)
Me.TBoxBackColor = Color.FromName(BBC)
Me.TBoxForeColor = Color.FromName(BFC)
End Sub
Private _HeadBC As Color = Color.Bisque
<Category("_ExCB specifics")> _
<Description("List Header BackColor")> _
Public Property HeadBackColor() As Color
Get
Return _HeadBC
End Get
Set(ByVal value As Color)
_HeadBC = value
End Set
End Property
Private _HeadFC As Color = Color.Black
<Category("_ExCB specifics")> _
<Description("List Header ForeColor")> _
Public Property HeadForeColor() As Color
Get
Return _HeadFC
End Get
Set(ByVal value As Color)
_HeadFC = value
End Set
End Property
Private _ListBC As Color = System.Drawing.SystemColors.Window
<Category("_ExCB specifics")> _
<Description("List Rows BackColor")> _
Public Property ListBackColor() As Color
Get
Return _ListBC
End Get
Set(ByVal value As Color)
_ListBC = value
End Set
End Property
Private _ListFC As Color = System.Drawing.SystemColors.WindowText
<Category("_ExCB specifics")> _
<Description("List Rows ForeColor")> _
Public Property ListForeColor() As Color
Get
Return _ListFC
End Get
Set(ByVal value As Color)
_ListFC = value
End Set
End Property
Private TBoxBC As Color = System.Drawing.SystemColors.Window
<Category("_ExCB specifics")> _
<Description("TextBox BackColor")> _
Public Property TBoxBackColor() As Color
Get
Return TBoxBC
End Get
Set(ByVal value As Color)
TBoxBC = value
End Set
End Property
Private TBoxFC As Color = System.Drawing.SystemColors.WindowText
<Category("_ExCB specifics")> _
<Description("TextBox ForeColor")> _
Public Property TBoxForeColor() As Color
Get
Return TBoxFC
End Get
Set(ByVal value As Color)
TBoxFC = value
End Set
End Property
End Class
#End Region
#Region "Class Co_Conv"
Friend Class Co_Conv
Inherits ExpandableObjectConverter
Public Overrides Function GetCreateInstanceSupported(ByVal context As ITypeDescriptorContext) As Boolean
Return True
End Function
Public Overrides Function CreateInstance(ByVal context As ITypeDescriptorContext, _
ByVal propertyValues As IDictionary) As Object
Dim _Clrs As New Co_
With _Clrs
.HeadBackColor = CType(propertyValues("HeadBackColor"), Color)
.HeadForeColor = CType(propertyValues("HeadForeColor"), Color)
.ListBackColor = CType(propertyValues("ListBackColor"), Color)
.ListForeColor = CType(propertyValues("ListForeColor"), Color)
.TBoxBackColor = CType(propertyValues("TBoxBackColor"), Color)
.TBoxForeColor = CType(propertyValues("TBoxForeColor"), Color)
End With
Return _Clrs
End Function
Public Overloads Overrides Function CanConvertFrom(ByVal context As ITypeDescriptorContext, _
ByVal sourceType As Type) As Boolean
If (sourceType Is GetType(String)) Then
Return True
End If
Return MyBase.CanConvertFrom(context, sourceType)
End Function
Public Overloads Overrides Function ConvertFrom(ByVal context As ITypeDescriptorContext, _
ByVal culture As CultureInfo, _
ByVal value As Object) As Object
If TypeOf value Is String Then
Try
Dim s As String = CType(value, String)
Dim xColor(4) As String
xColor = Split(s, ",")
If Not IsNothing(xColor) Then
If IsNothing(xColor(0)) Then xColor(0) = "Bisque"
If IsNothing(xColor(1)) Then xColor(1) = "Black"
If IsNothing(xColor(2)) Then xColor(2) = "Window"
If IsNothing(xColor(3)) Then xColor(3) = "WindowText"
If IsNothing(xColor(4)) Then xColor(4) = "Window"
If IsNothing(xColor(5)) Then xColor(5) = "WindowText"
Return New Co_(Color.FromName(xColor(0).Trim), _
Color.FromName(xColor(1).Trim), _
Color.FromName(xColor(2).Trim), _
Color.FromName(xColor(3).Trim), _
Color.FromName(xColor(4).Trim), _
Color.FromName(xColor(5).Trim))
End If
Catch ex As Exception
Throw New ArgumentException("Can not convert '" & CStr(value) & "' to type Color")
End Try
End If
Return MyBase.ConvertFrom(context, culture, value)
End Function
Public Overloads Overrides Function ConvertTo(ByVal context As ITypeDescriptorContext, _
ByVal culture As CultureInfo, _
ByVal value As Object, _
ByVal destinationType As Type) As Object
If (destinationType Is GetType(System.String) AndAlso TypeOf value Is Co_) Then
Dim Colors_ As Co_ = CType(value, Co_)
Return String.Format("{0}, {1}, {2}, {3}, {4}, {5}", _
Colors_.HeadBackColor.Name, _
Colors_.HeadForeColor.Name, _
Colors_.ListBackColor.Name, _
Colors_.ListForeColor.Name, _
Colors_.TBoxBackColor.Name, _
Colors_.TBoxForeColor.Name)
End If
Return MyBase.ConvertTo(context, culture, value, destinationType)
End Function
End Class
#End Region
#Region "Class SortLV"
' Implements the manual sorting of items by columns (ascending/descending)
' Type (of data): 0=Text(String), 1=Date[Time], 2=Numeric
' Usage: Private Sub MyLV1_ColumnClick(ByVal sender As Object, ByVal e As System.Windows.Forms.ColumnClickEventArgs) Handles MyLV1.ColumnClick
' Usage: MyLV1.ListViewItemSorter = New SortLV.LVEx_ColumnSort(Column, DataType, NewOrder)
' Example: MyLV1.ListViewItemSorter = New SortLV(e.Column, _ColAttr(iCtr)._Type, _ColAttr(iCtr)._Sort)
Class SortLV
Implements IComparer
Private _Column As Integer
Private _Type As Integer
Private _Order As Integer
Public Sub New()
_Column = 0
End Sub
Public Sub New(ByVal Column As Integer, ByVal Type As Integer, ByVal Order As Integer)
_Column = Column
_Type = Type
_Order = Order
End Sub
Public Function Compare(ByVal x As Object, ByVal y As Object) As Integer _
Implements System.Collections.IComparer.Compare
Dim vX As Object
Dim vY As Object
' If DataType = Text or if some convertion fails...
vX = CStr(CType(x, ListViewItem).SubItems(_Column).Text)
vY = CStr(CType(y, ListViewItem).SubItems(_Column).Text)
If _Type = 2 Then ' DataType is Numeric
Try
vX = CDbl(CType(x, ListViewItem).SubItems(_Column).Text)
vY = CDbl(CType(y, ListViewItem).SubItems(_Column).Text)
Catch
End Try
ElseIf _Type = 1 Then ' DataType is Date[Time]
Try
vX = CDate(CType(x, ListViewItem).SubItems(_Column).Text).ToOADate
vY = CDate(CType(y, ListViewItem).SubItems(_Column).Text).ToOADate
Catch
End Try
End If
If _Order = 1 Then ' Ascending
Select Case True
Case vX < vY : Return -1
Case vX = vY : Return 0
Case vX > vY : Return 1
End Select
Else ' Descending
Select Case True
Case vX < vY : Return 1
Case vX = vY : Return 0
Case vX > vY : Return -1
End Select
End If
End Function
End Class
#End Region
#Region "Class MyLV"
Partial Public Class MyLV
Inherits ListView
#Region "Variables"
Public _ItmStr() As Array ' Original added Rows
Friend Sortable As Boolean = True ' Global
Private IL813 As New ImageList ' For Ascending & Descending Sort Arrows
Private _CAtt() As _cAttr ' Column attributes
Private Header As HeaderControl ' SubClassed HeaderControl
#End Region
#Region "Properties"
Private _HeadHeight As Integer = 20
Public WriteOnly Property _HeaderHeight() As Integer
Set(ByVal value As Integer)
_HeadHeight = value
End Set
End Property
Private _HeadBC As Color = Me.BackColor
Public WriteOnly Property HeadBackColor() As Color
Set(ByVal value As Color)
_HeadBC = value
End Set
End Property
Private _HeadFC As Color = Me.ForeColor
Public WriteOnly Property HeadForeColor() As Color
Set(ByVal value As Color)
_HeadFC = value
End Set
End Property
#End Region
#Region "Sub New"
Public Sub New()
Me.View = Windows.Forms.View.Details
Me.GridLines = True
Me.BorderStyle = Windows.Forms.BorderStyle.FixedSingle
Me.MultiSelect = False
Me.FullRowSelect = True
End Sub
#End Region
#Region "Overrides"
Protected Overrides Sub OnHandleCreated(ByVal e As EventArgs)
'Create a new HeaderControl object
Header = New HeaderControl(Me)
MyBase.OnHandleCreated(e)
End Sub
Protected Overrides Sub WndProc(ByRef m As Message)
If m.Msg = WM_PAINT Then
For Each EC As _EC In _EmbeddedControls
Dim Col As Integer = EC.Col
' Because Columns can be reordered...
Dim dCol As Integer = Me.Columns(Col).DisplayIndex
Dim VarX As Integer = 0
If dCol > 0 Then
For Each C As ColumnHeader In Me.Columns
If C.DisplayIndex < dCol Then
VarX += C.Width
End If
Next
End If
Dim ColW As Integer = Me.Columns(Col).Width
Dim ImgW As Integer = _CAtt(Col)._ImgWidth
Dim _iBnds As Rectangle = EC.Item.GetBounds(ItemBoundsPortion.Entire)
' Columns can be resized...
Dim X As Integer
If ColW + 3 <= ImgW Then
ImgW = ColW - 3
End If
Select Case _CAtt(Col)._Align
Case HorizontalAlignment.Left
X = VarX + 2
Case HorizontalAlignment.Center
X = VarX + (ColW - ImgW) \ 2
Case HorizontalAlignment.Right
X = VarX + ColW - ImgW - 1
End Select
Dim SIR = New Rectangle(X, _iBnds.Top, ImgW, _iBnds.Height)
SIR.Offset(0, (SIR.Height - EC.Control.Height) \ 2)
SIR.Height = EC.Control.Height
EC.Control.Bounds = SIR
Next
End If
MyBase.WndProc(m)
End Sub
#End Region
#Region "Embedded Controls"
Public _EmbeddedControls As New ArrayList() ' Effective Embedded Controls
Public _Images() As Image ' Original added Images
Public Sub _ColsAttr(ByVal ColAttrib As Object)
_CAtt = ColAttrib
End Sub
Public Sub _AddEmbeddedControl(ByVal Row As Integer, ByVal Col As Integer, ByVal Img As Image, _
ByVal Width As Integer, ByVal Height As Integer, ByVal SzMod As ExCB.SizeMode)
Dim xPB As New PictureBox ' All images are shown as PictureBox
xPB.Image = Img
xPB.SizeMode = If(SzMod = ExCB.SizeMode._Zoom, PictureBoxSizeMode.Zoom, PictureBoxSizeMode.StretchImage)
xPB.Width = Width
xPB.Height = Height
xPB.Tag = _EmbeddedControls.Count ' For use in _embeddedControl_Click.
Dim EC As _EC
EC.Control = xPB
EC.Col = Col
EC.Row = Row
EC.Item = Items(Row)
_EmbeddedControls.Add(EC) ' Add Embedded Control & EventHandler (Click event)
AddHandler xPB.Click, New EventHandler(AddressOf _embeddedControl_Click)
Me.Controls.Add(xPB)
End Sub
Public Sub ECClear()
For iE = _EmbeddedControls.Count - 1 To 0 Step -1
Dim xPB As PictureBox = _EmbeddedControls(iE).Control
RemoveHandler xPB.Click, New EventHandler(AddressOf _embeddedControl_Click)
Next
_EmbeddedControls.Clear()
Me.Controls.Clear()
End Sub
Private Sub _embeddedControl_Click(ByVal sender As Object, ByVal e As System.EventArgs)
' When a control is clicked the Item holding it is selected
Me.SelectedItems.Clear()
Me.Items(_EmbeddedControls(Val(sender.Tag)).Item.Index).Selected = True
End Sub
#End Region
#Region "Class HeaderControl"
Friend Class HeaderControl
Inherits NativeWindow
Private LV As MyLV
Public Sub New(ByVal L As MyLV)
Me.LV = L
Me.AssignHandle(Defs.SendMessage(LV.Handle, Defs.LVM_GETHEADER, IntPtr.Zero, IntPtr.Zero))
End Sub
Protected Overrides Sub WndProc(ByRef m As Message)
If m.Msg = HDM_LAYOUT Then
' Get LParam (as HDLAYOUT) from Message
Dim LParam As HDLAYOUT = DirectCast(m.GetLParam(GetType(HDLAYOUT)), HDLAYOUT)
' Get RECT from LParam.prc field
Dim Rect As RECT = DirectCast(Marshal.PtrToStructure(LParam.prc, GetType(RECT)), RECT)
' Get WINDOWPOS from LParam.pwpos field
Dim wPos As WINDOWPOS = DirectCast(Marshal.PtrToStructure(LParam.pwpos, GetType(WINDOWPOS)), WINDOWPOS)
' Apply changes to the Header
wPos.hWnd = Me.Handle
wPos.hWndInsertAfter = IntPtr.Zero
wPos.flags = SWP_FRAMECHANGED
wPos.x = Rect.Left
wPos.y = Rect.Top
wPos.cx = (Rect.Right - Rect.Left)
wPos.cy = LV._HeadHeight ' Header Height is changed here
Rect.Top = wPos.cy - 1
Marshal.StructureToPtr(Rect, LParam.prc, False)
Marshal.StructureToPtr(wPos, LParam.pwpos, False)
Exit Sub
Else
MyBase.WndProc(m)
End If
End Sub
End Class ' HeaderControl
#End Region
End Class ' MyLV
#End Region