Flexgrid functions

Most samples in this complete thread can also be used for the MSHFlexGrid, in the functions just change the As MSFlexGrid to As MSHFlexGrid
To autosize the columns of a MSHFlexGrid with multiple bands go to this (http://www.visualbasicforum.com/showpost.php?postid=542899&postcount=25) post

Autosize the columns or rows in a MSFlexGrid:


Public Function FG_AutosizeRows(myGrid As MSFlexGrid, _
Optional ByVal lFirstRow As Long = -1, _
Optional ByVal lLastRow As Long = -1, _
Optional bCheckFont As Boolean = False)

' This will only work for Cells with a Chr(13)
' To have it working with WordWrap enabled
' you need some other routine
' Which has been added too

Dim lCol As Long, lRow As Long, lCurCol As Long, lCurRow As Long
Dim lCellHeight As Long, lRowHeight As Long
Dim bFontBold As Boolean
Dim dFontSize As Double
Dim sFontName As String

If bCheckFont Then
' save the forms font settings
bFontBold = Me.FontBold
sFontName = Me.FontName
dFontSize = Me.FontSize
End If

With myGrid
If bCheckFont Then
lCurCol = .Col
lCurRow = .Row
End If

If lFirstRow = -1 Then lFirstRow = 0
If lLastRow = -1 Then lLastRow = .Rows - 1

For lRow = lFirstRow To lLastRow
lRowHeight = 0
If bCheckFont Then .Row = lRow
For lCol = 0 To .Cols - 1
If bCheckFont Then
.Col = lCol
Me.FontBold = .CellFontBold
Me.FontName = .CellFontName
Me.FontSize = .CellFontSize
End If
lCellHeight = Me.TextHeight(.TextMatrix(lRow, lCol))
If lCellHeight > lRowHeight Then lRowHeight = lCellHeight
Next lCol
.RowHeight(lRow) = lRowHeight + Me.TextHeight("Wg") / 5
Next lRow

If bCheckFont Then
.Row = lCurRow
.Col = lCurCol
End If
End With

If bCheckFont Then
' restore the forms font settings
Me.FontBold = bFontBold
Me.FontName = sFontName
Me.FontSize = dFontSize
End If

End Function

Public Function FG_AutosizeCols(myGrid As MSFlexGrid, _
Optional ByVal lFirstCol As Long = -1, _
Optional ByVal lLastCol As Long = -1, _
Optional bCheckFont As Boolean = False)

Dim lCol As Long, lRow As Long, lCurCol As Long, lCurRow As Long
Dim lCellWidth As Long, lColWidth As Long
Dim bFontBold As Boolean
Dim dFontSize As Double
Dim sFontName As String

If bCheckFont Then
' save the forms font settings
bFontBold = Me.FontBold
sFontName = Me.FontName
dFontSize = Me.FontSize
End If

With myGrid
If bCheckFont Then
lCurRow = .Row
lCurCol = .Col
End If

If lFirstCol = -1 Then lFirstCol = 0
If lLastCol = -1 Then lLastCol = .Cols - 1

For lCol = lFirstCol To lLastCol
lColWidth = 0
If bCheckFont Then .Col = lCol
For lRow = 0 To .Rows - 1
If bCheckFont Then
.Row = lRow
Me.FontBold = .CellFontBold
Me.FontName = .CellFontName
Me.FontSize = .CellFontSize
End If
lCellWidth = Me.TextWidth(.TextMatrix(lRow, lCol))
If lCellWidth > lColWidth Then lColWidth = lCellWidth
Next lRow
.ColWidth(lCol) = lColWidth + Me.TextWidth("W")
Next lCol

If bCheckFont Then
.Row = lCurRow
.Col = lCurCol
End If
End With

If bCheckFont Then
' restore the forms font settings
Me.FontBold = bFontBold
Me.FontName = sFontName
Me.FontSize = dFontSize
End If

End Function

Needed controls for this example:
MSFlexGrid1, MSFlexGrid2 and txtDrag (textbox)


Private Sub Form_Load()
Dim lCol As Long
Dim lRow As Long

With MSFlexGrid1
.Rows = 10
.Cols = 9
For lRow = 0 To .Rows - 1
For lCol = 0 To .Cols - 1
.TextMatrix(lRow, lCol) = "Src: " & lRow & ";" & lCol
Next lCol
Next lRow
End With

With MSFlexGrid2
.Rows = 10
.Cols = 9
For lRow = 0 To .Rows - 1
For lCol = 0 To .Cols - 1
.TextMatrix(lRow, lCol) = "Dst: " & lRow & ";" & lCol
Next lCol
Next lRow
End With

End Sub

Private Sub MSFlexGrid1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Then
With MSFlexGrid1
.Col = .MouseCol
.Row = .MouseRow
txtDrag.Move .CellLeft, .CellTop, .CellWidth, .CellHeight
txtDrag.Text = .Text
txtDrag.Drag vbBeginDrag
End With
End If
End Sub

Private Sub MSFlexGrid2_DragDrop(Source As Control, x As Single, y As Single)
Dim lCol As Long
Dim lRow As Long
Dim curX As Single
Dim curY As Single

With MSFlexGrid2
For lRow = 0 To .Rows - 1
.Row = lRow
.Col = 0
If y > .CellTop And y < .CellTop + .CellHeight Then
For lCol = 0 To .Cols - 1
.Col = lCol
If x > .CellLeft And x < .CellLeft + .CellWidth Then
.Text = txtDrag.Text
Exit For
End If
Next lCol
End If
Next lRow
End With
End Sub

Public Function FG_SaveAsExcel(FG As MSFlexGrid, sFileName As String, Optional sHeader As String = "", Optional sFooter As String = "")
Dim myExcel As ExcelFileV2
Dim lRow As Integer, lCol As Integer
Dim excelDouble As Double
Dim rowOffset As Long
Dim aTemp() As String

If Len(sHeader) > 0 Then
aTemp = Split(sHeader, vbTab)
rowOffset = UBound(aTemp) + 1
End If

Set myExcel = New ExcelFileV2

With myExcel

.OpenFile sFileName

' Heading
For lRow = 1 To rowOffset
.eWritestring lRow, 1, aTemp(lRow - 1)
Next lRow

' FlexGrid -> Fixedrows
For lRow = 1 To FG.FixedRows
For lCol = 1 To FG.Cols
.eWritestring lRow + rowOffset, lCol, FG.textmatrix(lRow - 1, lCol - 1)
Next lCol
Next lRow

' Data
For lRow = FG.FixedRows + 1 To FG.Rows

' FlexGrid -> Fixedcols
For lCol = 1 To FG.FixedCols
.eWritestring lRow + rowOffset, lCol, FG.textmatrix(lRow - 1, lCol - 1)
Next lCol

' FlexGrid -> Data
For lCol = FG.FixedCols + 1 To FG.Cols
If IsNumeric(FG.textmatrix(lRow - 1, lCol - 1)) Then
excelDouble = CDbl(FG.textmatrix(lRow - 1, lCol - 1)) + 0
.EWriteDouble lRow + rowOffset, lCol, excelDouble
Else
.eWritestring lRow + rowOffset, lCol, FG.textmatrix(lRow - 1, lCol - 1)
End If
Next lCol
Next lRow

' Footer
If Len(sFooter) > 0 Then
aTemp = Split(sFooter, vbTab)
For lRow = 0 To UBound(aTemp)
.eWritestring lRow + rowOffset + FG.Rows + 1, 1, aTemp(lRow)
Next lRow
End If

.CloseFile
End With

End Function


The lines in bold were missing or incorrect

For this example you need a Form with 2 controls:
1. MSFlexGrid1
2. Label1

The Label1 control will be used the determine the correct height of the cell.

Option Explicit

Private Sub Form_Load()
Dim lCol As Long, lRow As Long

' just add some data
With MSFlexGrid1
.Cols = 8
.Rows = 8
.WordWrap = True
For lRow = 1 To .Rows - 1
For lCol = 1 To .Cols - 1
.TextMatrix(lRow, lCol) = "This line is to long and should wrap to the next line"
Next lCol
Next lRow
End With

FG_AutosizeRows MSFlexGrid1, Label1
End Sub

Public Function FG_AutosizeRows(myGrid As MSFlexGrid, _
myLabel As Label, _
Optional ByVal lFirstRow As Long = -1, _
Optional ByVal lLastRow As Long = -1, _
Optional bCheckFont As Boolean = False)

Dim lCol As Long, lRow As Long, lCurCol As Long, lCurRow As Long
Dim lCellHeight As Long, lRowHeight As Long
Dim bFontBold As Boolean
Dim dFontSize As Double
Dim sFontName As String

With myLabel
.AutoSize = True
.WordWrap = True
End With

With myGrid
If bCheckFont Then
lCurCol = .Col
lCurRow = .Row
End If

If lFirstRow = -1 Then lFirstRow = 0
If lLastRow = -1 Then lLastRow = .Rows - 1

For lRow = lFirstRow To lLastRow
lRowHeight = 0
If bCheckFont Then .Row = lRow
For lCol = 0 To .Cols - 1
If bCheckFont Then
.Col = lCol
myLabel.FontBold = .CellFontBold
myLabel.FontName = .CellFontName
myLabel.FontSize = .CellFontSize
End If
myLabel.Width = .ColWidth(lCol)
myLabel.Caption = .TextMatrix(lRow, lCol)
lCellHeight = myLabel.Height
If lCellHeight > lRowHeight Then lRowHeight = lCellHeight
Next lCol
.RowHeight(lRow) = lRowHeight + Me.TextHeight("Wg") / 5
Next lRow

If bCheckFont Then
.Row = lCurRow
.Col = lCurCol
End If
End With

End Function

Private Sub MSFlexGrid1_KeyPress(KeyAscii As Integer)
Dim sTemp As String

With MSFlexGrid1

sTemp = .TextMatrix(.Row, .Col)

Select Case KeyAscii
Case 8 ' backspace
If Len(sTemp) > 0 Then
sTemp = Left$(sTemp, Len(sTemp) - 1)
End If
Case 27 ' escape
sTemp = ""
Case 0 To 31
KeyAscii = 0
Case Else
sTemp = sTemp & Chr$(KeyAscii)
End Select
.TextMatrix(.Row, .Col) = sTemp
End With
End Sub

Public Sub FG_Rotate(FG As MSFlexGrid)
Dim lRow As Long, lCol As Long
Dim fgText() As String, fgCellAlignment() As Long
Dim fgColHidden() As Boolean, fgRowHidden() As Boolean
Dim fgCols As Long, fgRows As Long
Dim fgFixedCols As Long, fgFixedRows As Long
Dim iMergeCells As Integer, fgMergeRows() As Boolean, fgMergeCols() As Boolean

With FG
' store data
fgRows = .Rows
fgCols = .Cols
fgFixedCols = .FixedCols
fgFixedRows = .FixedRows

iMergeCells = .MergeCells

ReDim fgText(fgRows - 1, fgCols - 1)
ReDim fgCellAlignment(fgRows - 1, fgCols - 1)
ReDim fgRowHidden(fgRows - 1)
ReDim fgColHidden(fgCols - 1)
ReDim fgMergeRows(fgRows - 1)
ReDim fgMergeCols(fgCols - 1)

For lRow = 0 To fgRows - 1
fgRowHidden(lRow) = (.RowHeight(lRow) = 0)
fgMergeRows(lRow) = .MergeRow(lRow)
.Row = lRow
For lCol = 0 To fgCols - 1
If lRow = 0 Then
fgColHidden(lCol) = (.ColWidth(lCol) = 0)
fgMergeCols(lCol) = .MergeCol(lCol)
End If
fgText(lRow, lCol) = .TextMatrix(lRow, lCol)
.Col = lCol
fgCellAlignment(lRow, lCol) = .CellAlignment
Next lCol
Next lRow

' rebuild grid and swap columns/rows

.Redraw = False
.Clear
.Rows = fgCols
.Cols = fgRows
.FixedRows = fgFixedCols
.FixedCols = fgFixedRows

For lRow = 0 To fgRows - 1
.Col = lRow
For lCol = 0 To fgCols - 1
.Row = lCol
.TextMatrix(lCol, lRow) = fgText(lRow, lCol)
.CellAlignment = fgCellAlignment(lRow, lCol)
Next lCol
Next lRow

.MergeCells = iMergeCells

' set hidden columns/rows and merge settings
For lRow = 0 To fgRows - 1
If fgRowHidden(lRow) Then .ColWidth(lRow) = 0
.MergeCol(lRow) = fgMergeRows(lRow)
Next lRow
For lCol = 0 To fgCols - 1
If fgColHidden(lCol) Then .RowHeight(lCol) = 0
.MergeRow(lCol) = fgMergeCols(lCol)
Next lCol

.Redraw = True
End With

End Sub

The MSFlexgrid does have some capabilities for sorting.
It works great if you want to sort 1 column.
If you want to sort multiple columns the flexgrid always sorts them from left to right and all in the same order (ascending/descending).

That's why I wrote a new module to provide a more flexible way of sorting.
It can sort on every column in any order and any direction, both numeric and text.

For this code example you need a form with 2 controls:
1. MSFlexGrid1
2. txtCell (a normal textbox)


Option Explicit

' to store the row/column of the cell
' being edited
Dim m_lCellCol As Long
Dim m_lCellRow As Long

Private Sub Form_Load()
m_lCellRow = -1
m_lCellCol = -1
txtCell.BorderStyle = 0
txtCell.Visible = False
' set the text background color to the
' backcolor of the tooltip text to make
' the cell being edited having a different color
txtCell.BackColor = vbInfoBackground
MSFlexGrid1.Cols = 10
MSFlexGrid1.Rows = 10
End Sub

Private Sub MSFlexGrid1_DblClick()
showTxtCell
End Sub

Private Sub MSFlexGrid1_RowColChange()
removeTxtCell
End Sub

Private Sub MSFlexGrid1_Scroll()
removeTxtCell
End Sub

Private Sub MSFlexGrid1_SelChange()
removeTxtCell
End Sub

Private Sub txtCell_Change()
MSFlexGrid1.Text = txtCell.Text
End Sub

Private Sub showTxtCell()
If m_lCellRow = -1 Then
With MSFlexGrid1
' store the current row and column
m_lCellRow = .Row
m_lCellCol = .Col
' move the textbox to the correct cell
txtCell.Move .Left + .CellLeft, .Top + .CellTop, .CellWidth, .CellHeight
txtCell.Text = .Text
' select all text
txtCell.SelLength = Len(.Text)
End With
txtCell.Visible = True
txtCell.SetFocus
End If
End Sub

Private Sub removeTxtCell()
If m_lCellRow <> -1 Then
MSFlexGrid1.TextMatrix(m_lCellRow, m_lCellCol) = txtCell.Text
m_lCellRow = -1
m_lCellCol = -1
txtCell.Visible = False
End If
End Sub

Private Sub txtCell_Validate(Cancel As Boolean)
removeTxtCell
End Sub

For readability it can be a wise decission to have different colors for the even and odd rows.

For this example you need a form 2 controls:
1. MSFlexGrid1 (msflexgrid control)
2. Command1 (command button)


Option Explicit

Private Sub Command1_Click()
FG_AlternateRowColors MSFlexGrid1, RGB(255, 255, 192), RGB(255, 255, 255)
End Sub

Private Sub Form_Load()
Dim lCol As Long, lRow As Long

' just fill the grid with some dummy data
With MSFlexGrid1
.Cols = 10
.Rows = 10
For lRow = 0 To .Rows - 1
For lCol = 0 To .Cols - 1
.TextMatrix(lRow, lCol) = "R" & lRow & "C" & lCol
Next lCol
Next lRow
End With
End Sub

Public Sub FG_AlternateRowColors(FG As MSFlexGrid, lColor1 As Long, lcolor2 As Long)
Dim lRow As Long, lCol As Long
Dim lOrgRow As Long, lOrgCol As Long
Dim lColor As Long

With FG ' MSFlexGrid1 <- Bugfix as stated by Trivium
.Redraw = False

' save the current cell position
lOrgRow = .Row
lOrgCol = .Col

' only the data rows
For lRow = .FixedRows To .Rows - 1
.Row = lRow

If lRow / 2 = lRow \ 2 Then
lColor = lColor1
Else
lColor = lcolor2
End If

' only the data columns
For lCol = .FixedCols To .Cols - 1
.Col = lCol
.CellBackColor = lColor
Next lCol
Next lRow

' restore the orginal cell position
.Row = lOrgRow
.Col = lOrgCol
.Redraw = True
End With
End Sub

The next sample project is an Auto Filter button.

Activating the Auto Filter will add a combobox to all columns with all unique items per column.

Almost the same as in Excel ;)

Updated version
- Combobox height adapted to height of first row instead of row height adapted.
- Taking in account the vertical scrollbar

The AutoFilter project:

Attach a small demo project to demonstrate my new printgrid class.

Things not included in the class:
- Cell merging
- Printing cell pictures

Small update of PrintGrid class.

New properties:
- PrintForeColor
- PrintBackColor

To print in black & white on color printers.

It's quite obvious how to delete a row from a MS(H)FlexGrid using the .RemoveItem method.
To delete a column we have to use a little trick by using a powerful feature of the flexgrid, moving columns (rows can be moved too). When you move the unwanted column to last column you can just lower the number of columns to get rid of it.


' To remove a column of a MSHFlexGrid
Public Function HFG_RemoveColumn(myGrid As MSHFlexGrid, ByVal lColumn As Long)
With myGrid
.Redraw = False
If lColumn < .Cols Then
.ColPosition(lColumn) = .Cols - 1
.Cols = .Cols - 1
End If
.Redraw = True
End With
End Function



' To remove a column of a MSFlexGrid
Public Function FG_RemoveColumn(myGrid As MSFlexGrid, ByVal lColumn As Long)
With myGrid
.Redraw = False
If lColumn < .Cols Then
.ColPosition(lColumn) = .Cols - 1
.Cols = .Cols - 1
End If
.Redraw = True
End With
End Function

Get a notification when a column/row in a flexgrid is resized:

I didn't write this code myself!

In a module:

' B Chernyachuk 1999 - BodyaC@hotmail.com
'
Option Explicit

Public g_lngDefaultHandler As Long ' Original handler of the grid events
Private m_bLMousePressed As Boolean 'true if the left button is pressed
Private m_bLMouseClicked As Boolean 'true just after the click (i.e. just after the left button is released)

'API declarations ============================================================
' Function to retrieve the address of the current Message-Handling routine
Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
' Function to define the address of the Message-Handling routine
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
' Function to execute a function residing at a specific memory address
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

'Windows messages constants
Public Const WM_LBUTTONUP = &H202
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_ERASEBKGND = &H14
'===================================================================== =========

'this is our event handler
Public Function GridMessage(ByVal hwnd As Long, ByVal Msg As Long, ByVal wp As Long, ByVal lp As Long) As Long

If m_bLMousePressed And Msg = WM_LBUTTONUP Then
'button have been just released
m_bLMousePressed = False
m_bLMouseClicked = True
End If

If Not (m_bLMousePressed) And Msg = WM_LBUTTONDOWN Then
'button have been just pressed
m_bLMousePressed = True
m_bLMouseClicked = False
End If

If m_bLMouseClicked And (Msg = WM_ERASEBKGND) Then
'Only when resize happens this event may occur after releasing the button !
'When user is making a simple click on grid,
'the WM_ERASEBKGND event occurs before WM_LBUTTONUP,
'and therefore will not be handled there

Debug.Print "Grid message: ", "Resized !" 'TO DO: Replace this futile code
'with something usefull

m_bLMouseClicked = False

End If

'call the default message handler
GridMessage = CallWindowProc(g_lngDefaultHandler, hwnd, Msg, wp, lp)

End Function


In a form:

Option Explicit
' This constant is used to refer to the Message Handling function in a given window
Private Const GWL_WNDPROC = (-4)

Private Sub Form_Load()

'Save the address of the existing Message Handler
g_lngDefaultHandler = GetWindowLong(Me.MSFlexGrid1.hwnd, GWL_WNDPROC)

'Define new message handler routine
Call SetWindowLong(Me.MSFlexGrid1.hwnd, GWL_WNDPROC, AddressOf GridMessage)

End Sub
Private Sub Form_Unload(Cancel As Integer)

'Return the old handler back
Call SetWindowLong(Me.MSFlexGrid1.hwnd, GWL_WNDPROC, g_lngDefaultHandler)

End Sub

Option Explicit

' variable to hold our selected rows
Private m_cSelectedRows As Collection

Private m_lForeColorSel As Long ' Our forecolor for selections
Private m_lBackColorSel As Long ' Our backcolor for selections

Private Sub Form_Load()
Dim lCol As Long, lRow As Long

' initialise our "selection" settings
Set m_cSelectedRows = New Collection
m_lBackColorSel = vbHighlight
m_lForeColorSel = vbHighlightText

' initialise the grid
With MSFlexGrid1
.Redraw = False
.Cols = 10
.Rows = 10
.AllowBigSelection = False
.SelectionMode = flexSelectionFree
.ForeColorSel = .ForeColor
.BackColorSel = .BackColor
.FocusRect = flexFocusLight

' fill the grid with some data
For lRow = .FixedRows To .Rows - 1
.TextMatrix(lRow, 0) = "Row: " & lRow
For lCol = .FixedCols To .Cols - 1
.TextMatrix(lRow, lCol) = "R" & lRow & "C" & lCol
Next lCol
Next lRow
'
.Redraw = True
End With
End Sub

Private Sub MSFlexGrid1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
' going to check whether a (new) row is selected
' If CTRL is pressed we add the row to the selection
' otherwise we clear the previous selection

With MSFlexGrid1
If .MouseCol >= .FixedCols Then
' not clicked on a fixed column
Exit Sub
End If

If .MouseRow < .FixedRows - 1 Then
' clicked on a fixed row
Exit Sub
End If

If Shift <> vbCtrlMask Then
ClearSelectedRows
End If
AddSelectedRow .MouseRow
End With
End Sub

Private Sub ClearSelectedRows()
Dim lCol As Long, lRow As Long
Dim lColSel As Long, lRowSel As Long
Dim lFillStyle As Long

If m_cSelectedRows.Count = 0 Then
' no previous selected rows
Exit Sub
End If

With MSFlexGrid1
.Redraw = False

' store the original settings
lCol = .Col
lRow = .Row
lColSel = .ColSel
lRowSel = .RowSel
lFillStyle = .FillStyle

' clear the selection
.FillStyle = flexFillRepeat
.Col = .FixedCols
.Row = .FixedRows
.ColSel = .Cols - 1
.RowSel = .Rows - 1
.CellBackColor = .BackColor
.CellForeColor = .ForeColor

' restore the settings
.Col = lCol
.Row = lRow
.ColSel = lColSel
.RowSel = lRowSel
.FillStyle = lFillStyle

.Redraw = True
.Refresh
End With

' clear our collection
Do While m_cSelectedRows.Count > 0
m_cSelectedRows.Remove 1
Loop
End Sub

Private Sub AddSelectedRow(lCurRow As Long)
Dim sKey As String
Dim lCol As Long, lRow As Long
Dim lColSel As Long, lRowSel As Long
Dim lFillStyle As Long

' keys in a collection can't be numeric
sKey = "row" & CStr(lCurRow)
With MSFlexGrid1
.Redraw = False

' store the original settings
lCol = .Col
lRow = .Row
lColSel = .ColSel
lRowSel = .RowSel
lFillStyle = .FillStyle

' highlight the selection
.FillStyle = flexFillRepeat
.Col = .FixedCols
.Row = lCurRow
.ColSel = .Cols - 1
.RowSel = lCurRow
.CellBackColor = m_lBackColorSel
.CellForeColor = m_lForeColorSel

.Redraw = True

' restore the settings
.Col = lCol
.Row = lRow
.ColSel = lColSel
.RowSel = lRowSel
.FillStyle = lFillStyle

End With

' some error handling for using collections
On Error Resume Next
m_cSelectedRows.Add lCurRow, sKey
End Sub

Updated: see post -> Version 2: Checkboxes using Wingdings

A simple way to display checkboxes in the MS(H)Flexgrid is by using the special characterset Wingdings.


Option Explicit

Private Const fgChecked As Byte = 253
Private Const fgUnChecked As Byte = 168


Private Sub Form_Load()
Dim lRow As Long
Dim lHeight As Long

With MSFlexGrid1
lHeight = .RowHeight(0)
.Cols = 4
.Rows = 25

.ColAlignment(2) = flexAlignCenterCenter
.Col = 2
For lRow = .FixedRows To .Rows - 1
.Row = lRow
.Font.Size = 12
.Font.Bold = False
.Font = "Wingdings"
.Text = Chr$(fgUnChecked)
Next lRow
.RowHeight(-1) = lHeight
End With
End Sub

Private Sub MSFlexGrid1_Click()
With MSFlexGrid1
If .Col = 2 Then
If .Text = Chr$(fgUnChecked) Then
.Text = Chr$(fgChecked)
ElseIf .Text = Chr$(fgChecked) Then
.Text = Chr$(fgUnChecked)
End If
End If
End With
End Sub

For this code sample place a MSFlexGrid control (MSFlexGrid1) and a command button (Command1) on your form and make a reference to "Microsoft ActiveX Data Object 2.x Library"

Option Explicit

Dim m_sDBPath As String

Private Sub Command1_Click()
Dim adoConn As ADODB.Connection
Dim adoRST As ADODB.Recordset

On Error Goto errHandler

' open the connection
Set adoConn = New ADODB.Connection
adoConn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & m_sDBPath

' get a recordset
Set adoRST = New ADODB.Recordset
adoRST.Open "Titles", adoConn, adOpenForwardOnly, , adCmdTable

With adoRST
If Not .EOF Then
FG_ShowRecordset MSFlexGrid1, adoRST
End If
.Close
End With
adoConn.Close

Set adoConn = Nothing
Set adoRST = Nothing
Exit Sub

errHandler:
MsgBox "An error occured." & vbLf & Err.Number & ": " & Err.Description, vbCritical
Set adoConn = Nothing
Set adoRST = Nothing
End Sub

Private Sub FG_ShowRecordset(myFG As MSFlexGrid, myRST As ADODB.Recordset)
Dim iField As Integer, iNofFields As Integer
Dim lRow As Long

Screen.MousePointer = vbHourglass

With myRST
.MoveFirst
iNofFields = .Fields.Count
End With

With myFG
.Redraw = False
.AllowUserResizing = flexResizeColumns
.ScrollTrack = True
.FixedCols = 0
.FixedRows = 0
.Cols = iNofFields
.Rows = 1

' setup the header
For iField = 0 To iNofFields - 1
.TextMatrix(0, iField) = myRST.Fields(iField).Name
Next iField
End With

With myRST
Do
' increase the number of rows
lRow = myFG.Rows
myFG.Rows = myFG.Rows + 1

' add the values to the current row
For iField = 0 To iNofFields - 1
If Not IsNull(.Fields(iField).Value) Then
myFG.TextMatrix(lRow, iField) = .Fields(iField).Value
End If
Next iField

' proceed to the next record
.MoveNext
Loop Until .EOF
End With

With myFG
.FixedRows = 1
.Redraw = True
End With

Screen.MousePointer = vbNormal
End Sub

Private Sub Form_Load()
m_sDBPath = "C:\Program Files\Microsoft Visual Studio\VB98\Biblio.MDB"
Me.Caption = m_sDBPath
End Sub

An almost perfect sample how to use real checkboxes in the MSFlexgrid control.

The previous version did change the font for the complete MSFlexgrid, ofcourse it is better to only change the font for the needed cells.

Option Explicit

Private Const fgChecked As Byte = 253
Private Const fgUnChecked As Byte = 168

Private Sub Form_Load()
Dim lRow As Long

With MSFlexGrid1
.Cols = 4
.Rows = 25

.ColAlignment(2) = flexAlignCenterCenter
.Col = 2
For lRow = .FixedRows To .Rows - 1
.Row = lRow
.CellFontName = "Wingdings"
.CellFontSize = 12
.CellFontBold = False
.Text = Chr$(fgUnChecked)
Next lRow
End With
End Sub

Private Sub MSFlexGrid1_Click()
With MSFlexGrid1
If .Col = 2 Then
If .Text = Chr$(fgUnChecked) Then
.Text = Chr$(fgChecked)
ElseIf .Text = Chr$(fgChecked) Then
.Text = Chr$(fgUnChecked)
End If
End If
End With
End Sub

When you are displaying a lot of data in the MSFlexGrid it can be usefull to give the user some searching capabilities.

The sample project uses a Timer and a Textbox control to do some "intelligent" searching.

A sample project to show how to implement column movement by dragging columns.

Not my own code but a link to some other webpage:

http://www.adit.co.uk/html/mousewheelsupport.html

Changing complete row / column background color:

FlexGridColumnColor MSFlexGrid1, 2, vbRed
FlexGridRowColor MSFlexGrid1, 3, vbBlue


Public Sub FlexGridColumnColor(FlexGrid As MSFlexGrid, ByVal lColumn As Long, ByVal lColor As Long)
Dim lPrevCol As Long, lPrevColSel As Long
Dim lPrevRow As Long, lPrevRowSel As Long
Dim lPrevFillStyle As Long

If lColumn > FlexGrid.Cols - 1 Then Exit Sub

With FlexGrid

' Store the current settings
lPrevCol = .Col
lPrevRow = .Row
lPrevColSel = .ColSel
lPrevRowSel = .RowSel
lPrevFillStyle = .FillStyle

' Change the backcolor
.Col = lColumn
.Row = .FixedRows
.ColSel = lColumn
.RowSel = .Rows - 1
.FillStyle = flexFillRepeat
.CellBackColor = lColor

' reset the settings
.Col = lPrevCol
.Row = lPrevRow
.ColSel = lPrevColSel
.RowSel = lPrevRowSel
.FillStyle = lPrevFillStyle
End With
End Sub

Public Sub FlexGridRowColor(FlexGrid As MSFlexGrid, ByVal lRow As Long, ByVal lColor As Long)
Dim lPrevCol As Long, lPrevColSel As Long
Dim lPrevRow As Long, lPrevRowSel As Long
Dim lPrevFillStyle As Long

If lRow > FlexGrid.Rows - 1 Then Exit Sub

With FlexGrid

' Store the current settings
lPrevCol = .Col
lPrevRow = .Row
lPrevColSel = .ColSel
lPrevRowSel = .RowSel
lPrevFillStyle = .FillStyle

' Change the backcolor
.Col = .FixedCols
.Row = lRow
.ColSel = .Cols - 1
.RowSel = lRow
.FillStyle = flexFillRepeat
.CellBackColor = lColor

' reset the settings
.Col = lPrevCol
.Row = lPrevRow
.ColSel = lPrevColSel
.RowSel = lPrevRowSel
.FillStyle = lPrevFillStyle
End With
End Sub

Public Function FG_AutosizeCols(myGrid As MSHFlexGrid, _
Optional ByVal lFirstCol As Long = -1, _
Optional ByVal lLastCol As Long = -1, _
Optional bCheckFont As Boolean = False)

Dim lCol As Long, lRow As Long, lCurCol As Long, lCurRow As Long
Dim lCellWidth As Long, lColWidth As Long
Dim bFontBold As Boolean
Dim dFontSize As Double
Dim sFontName As String

If bCheckFont Then
' save the forms font settings
bFontBold = Me.FontBold
sFontName = Me.FontName
dFontSize = Me.FontSize
End If

With myGrid
.Redraw = False

If bCheckFont Then
lCurRow = .Row
lCurCol = .Col
End If

If lFirstCol = -1 Then lFirstCol = 0

' Special for MSHFlexGrid with multiple bands
If lLastCol = -1 Then
lLastCol = 0
For i = 0 To .Bands - 1
lLastCol = lLastCol + .Cols(i)
Next i
lLastCol = lLastCol - 1
End If

For lCol = lFirstCol To lLastCol
lColWidth = 0
If bCheckFont Then .Col = lCol
For lRow = 0 To .Rows - 1
If bCheckFont Then
.Row = lRow
Me.FontBold = .CellFontBold
Me.FontName = .CellFontName
Me.FontSize = .CellFontSize
End If
lCellWidth = Me.TextWidth(.TextMatrix(lRow, lCol))
If lCellWidth > lColWidth Then lColWidth = lCellWidth
Next lRow
.ColWidth(lCol) = lColWidth + Me.TextWidth("WW")
Next lCol

If bCheckFont Then
.Row = lCurRow
.Col = lCurCol
End If

.Redraw = True
End With

If bCheckFont Then
' restore the forms font settings
Me.FontBold = bFontBold
Me.FontName = sFontName
Me.FontSize = dFontSize
End If

End Function

The original code can be found on ActiveVB.de (http://www.activevb.de/tipps/vb6tipps/tipp0249.html)

'Dieser Source stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
' Die Komponente 'Microsoft FlexGrid Control 6.0 (SP3)
' (MSFLXGRD.OCX)' wird benötigt.
'--------- Anfang Formular "Form1" alias Form1.frm ---------

'Control CommandButton: Command1
'Control FlexGrid: MSFlexGrid1

Option Explicit

Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hWnd As Long, ByVal wMsg As _
Long, ByVal wParam As Long, ByVal lParam As Long) _
As Long

Const WM_USER = &H400
Const VP_FORMATRANGE = WM_USER + 125
Const VP_YESIDO = 456654

Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Type TFormatRange
hdc As Long
hdcTarget As Long
rc As Rect
rcPage As Rect
End Type

Private Sub Command1_Click()
Call PrintGrid(MSFlexGrid1, 20, 25, 20, 20, _
"ActiveVB - FlexGrid drucken über " & _
"VP_FORMATRANGE", "")
End Sub

Private Sub Form_Load()
Dim Zahl%

' Fill the flex with 'random' data
With MSFlexGrid1
.ColWidth(0) = 1000
.ColWidth(1) = 2000
.ColWidth(2) = 2600
.ColAlignment(3) = 0
.ColWidth(3) = 500
.ColWidth(4) = 2800
.TextArray(0) = "Name"
.TextArray(1) = "E-Mail"
.TextArray(2) = "HomePage"
.TextArray(3) = "Nr."
.TextArray(4) = "Sonstiges"

For Zahl = 1 To 9
.AddItem "Dirk Lietzow" & vbTab & "dirk@activeVB.de" & _
vbTab & "www.activeVB.de" & vbTab & Zahl & vbTab & _
"Alle für einen, einer für alle ..."
Next Zahl

' 1. leere Zeile löschen
.RemoveItem 1

' Formatierungsbeispiele
.Col = 2
.Row = 2
.CellFontName = "Arial"
.CellFontSize = 11
.Col = 2
.Row = 3
.CellFontName = "Arial"
.CellFontSize = 12
.Col = 2
.Row = 4
.CellFontName = "Arial"
.CellFontSize = 14
.CellFontBold = True
.RowHeight(.Row) = 500
.Col = 2
.Row = 6
.CellBackColor = &H8000000F
.Col = 2
.Row = 8
.CellFontName = "Courier New"
.CellFontSize = 12
.CellFontBold = True
.CellForeColor = vbWhite
.CellBackColor = &HC00000
.RowHeight(.Row) = 500
End With
End Sub

Sub PrintGrid(Grid As MSFlexGrid, ByVal LeftMargin As Single, _
ByVal TopMargin As Single, ByVal RightMargin As _
Single, ByVal BottomMargin As Single, Titel As _
String, Datum As String, Optional many As Integer)

Dim tRange As TFormatRange
Dim lReturn As Long
Dim DName As String
Dim DSchacht As Integer
Dim gbeg As Long
Dim CopyCW() As Long
Dim GRef As Boolean
Dim X%

GRef = False
If many > 0 Then
' Set the number of columns to be printed
' All columns > many get a colwidth = 0
If Grid.Cols > many Then
gbeg = Grid.Cols - many
ReDim CopyCW(gbeg)
Grid.Redraw = False
For X = many To Grid.Cols - 1
CopyCW(X - many) = Grid.ColWidth(X)
Grid.ColWidth(X) = 0
Next X
GRef = True
End If
End If

'With wParam <> 0 can be checked
'whether the control supports OPP, if it does then the value
'456654 (VP_YESIDO) will be returned
lReturn = SendMessage(Grid.hWnd, VP_FORMATRANGE, 1, 0)

If lReturn = VP_YESIDO Then

' Fill the tRange structure
Printer.ScaleMode = vbPixels

With tRange
.hdc = Printer.hdc

' Height and Width (in Pixel)
.rcPage.Right = Printer.ScaleWidth
.rcPage.Bottom = Printer.ScaleHeight

' Set the printing range in pixels
.rc.Left = Printer.ScaleX(LeftMargin, vbMillimeters)
.rc.Top = Printer.ScaleY(TopMargin, vbMillimeters)
.rc.Right = .rcPage.Right - Printer.ScaleX(RightMargin, _
vbMillimeters)

.rc.Bottom = .rcPage.Bottom - Printer.ScaleY(BottomMargin, _
vbMillimeters)
End With

' Initialize printer
Printer.Print vbNullString

' Print page (n)
Do
Printer.CurrentX = Printer.ScaleX(LeftMargin, vbMillimeters)
Printer.CurrentY = Printer.ScaleY(10, vbMillimeters)
If Titel <> "" Then Printer.Print Titel

Printer.CurrentX = Printer.ScaleX(LeftMargin, vbMillimeters)
Printer.CurrentY = Printer.ScaleY(16, vbMillimeters)

If Datum <> "" Then
Printer.Print Datum
Else
Printer.Print Format(Date, "DD.MM.YYYY")
End If
lReturn = SendMessage(Grid.hWnd, VP_FORMATRANGE, 0, _
VarPtr(tRange))

If lReturn < 0 Then
Exit Do
Else
Printer.NewPage
End If
Loop
Printer.EndDoc

'Reset
lReturn = SendMessage(Grid.hWnd, VP_FORMATRANGE, 0, 0)
End If

If GRef Then
' Reset all columns to their original width
For X = many To Grid.Cols - 1
Grid.ColWidth(X) = CopyCW(X - many)
Next X
Grid.Redraw = True
End If
End Sub

'---------- Ende Formular "Form1" alias Form1.frm ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------

I created a class to extend the functionality of the MSFlexGrid with Excel like functions.

The class supports cell editing, but you can also add formula's and expressions in the cell.

Like in Excel if the text starts with a "=" then the rest of the text is parsed.

Simple cell references can be used using [] -> [row,col]

I added two range functions myself: SUM and AVG

cFlexSpread.TextFormula(4, 3) = "=sum([1,1]:[3,3])"
cFlexSpread.TextFormula(4, 3) = "=avg([1,1]:[3,3])"

For all other mathematical functions I used the Eval method of the ScriptControl which can be combined with cell references.

cFlexSpread.TextFormula(4, 3) = "=[1,1] * Sin([3,3]))"


Also added 3 events:

Private Sub cFlexSpread_AfterEdit(Row As Long, Col As Long)
Debug.Print "AfterEdit", Row, Col
End Sub

Private Sub cFlexSpread_BeforeEdit(Row As Long, Col As Long, Cancel As Boolean)
Debug.Print "Before", Row, Col
' lock column 3
Cancel = (Col = 3)
End Sub

Private Sub cFlexSpread_EvalError(Row As Long, Col As Long)
Debug.Print "EvalError", Row, Col
End Sub

Another sample using a class to save / load the settings of the MSFlexGrid to / from a INI style file.

It can save / load the general flexgrid settings, the general layout, the cell data and the layout of the cells.

Code from Form1

Option Explicit

Private Sub Form_Load()
Dim lCol As Long, lRow As Long

' Just fill the first grid with some data
' Note: you can resize the columns using the mouse
With MSFlexGrid1
.Cols = 10
.Rows = 12
.ColAlignment(-1) = flexAlignCenterCenter
.FixedCols = 2
.FixedRows = 2
.AllowUserResizing = flexResizeColumns
For lRow = 0 To .Rows - 1
For lCol = 0 To .Cols - 1
.TextMatrix(lRow, lCol) = "R" & lRow & "C" & lCol
If lRow / 3 = lRow \ 3 Then
If lCol / 2 = lCol \ 2 Then
.Row = lRow
.Col = lCol
.CellFontBold = True
End If
End If
Next lCol
Next lRow
End With
End Sub

' The Save button
Private Sub Command1_Click()
Dim cFlexSettings As clsFlexSettings

Set cFlexSettings = New clsFlexSettings
Set cFlexSettings.FlexGrid = MSFlexGrid1
cFlexSettings.SaveSettings "c:\test.flex", True, True, True, True
Me.Caption = "c:\test.flex"
End Sub

' The Load Button
Private Sub Command2_Click()
Dim cFlexSettings As clsFlexSettings

Set cFlexSettings = New clsFlexSettings
Set cFlexSettings.FlexGrid = MSFlexGrid2
cFlexSettings.LoadSettings "c:\test.flex", True, True, True, True

End Sub

Sample using the MSFlexGrid as a Month Calendar like Outlook.

'---------------------------------------------------------------------------------------
' Module : Form1
' DateTime : 11-7-2004 00:28
' Author : Flyguy
' Purpose : Sample using FlexGrid as Month Calendar
'---------------------------------------------------------------------------------------
Option Explicit

Private m_lDate As Long ' The date we are working on

Private Sub Form_Load()
m_lDate = Date
DrawGrid m_lDate
End Sub

Private Sub Command1_Click()
m_lDate = DateAdd("m", -1, m_lDate)
DrawGrid m_lDate
End Sub

Private Sub Command2_Click()
m_lDate = DateAdd("m", 1, m_lDate)
DrawGrid m_lDate
End Sub

Private Sub Form_Resize()
' I really don't care about errors when resizing
On Error Resume Next

Command2.Left = Me.ScaleWidth - Command1.Left - Command2.Width
With MSFlexGrid1
.Left = Command1.Left
.Top = 2 * Command1.Top + Command2.Height
.Move .Left, .Top, Me.ScaleWidth - 2 * .Left, Me.ScaleHeight - .Top - .Left
End With

' Also update the grid interior
SizeGrid
End Sub

'---------------------------------------------------------------------------------------
' Procedure : MSFlexGrid1_DblClick
' DateTime : 10-7-2004 23:55
' Author : Flyguy
' Purpose : To enter some data in the clicked cell
'---------------------------------------------------------------------------------------
'
Private Sub MSFlexGrid1_DblClick()
Dim lRow As Long
Dim lCol As Long
Dim sText As String

With MSFlexGrid1
lRow = .MouseRow
lCol = .MouseCol
If lRow / 2 = lRow \ 2 Then lRow = lRow + 1
sText = InputBox(.TextMatrix(lRow - 1, lCol), , .TextMatrix(lRow, lCol))
If StrPtr(sText) <> 0 Then .TextMatrix(lRow, lCol) = sText
End With
End Sub

Private Sub MSFlexGrid1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
SetCellFocus
End Sub

Private Sub MSFlexGrid1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Then SetCellFocus
End Sub

'---------------------------------------------------------------------------------------
' Procedure : DrawGrid
' DateTime : 11-7-2004 00:23
' Author : Flyguy
' Purpose : Draw the calendar for the given month
'---------------------------------------------------------------------------------------
'
Private Sub DrawGrid(ByVal theDate As Long)
Dim lFirstDate As Long
Dim lLastDate As Long
Dim lFirstCol As Long
Dim lCol As Long, lRow As Long, lRows As Long
Dim lDate As Long

Me.Caption = Format(theDate, "mmmm yyyy")

' Get the 1st and last day of the month
lFirstDate = DateSerial(Year(theDate), Month(theDate), 1)
lLastDate = DateSerial(Year(theDate), Month(theDate) + 1, 1) - 1

' The starting column
lFirstCol = Weekday(lFirstDate, vbUseSystemDayOfWeek) - 1

' Determine the number of weeks
lRows = DateDiff("ww", lFirstDate, lLastDate, vbUseSystemDayOfWeek) + 1

With MSFlexGrid1
' No borders etc to autosize nicely
.BorderStyle = flexBorderNone
.Appearance = flexFlat
.ScrollBars = flexScrollBarNone

' Just some color settings
.GridColor = vb3DFace
.BackColor = .GridColor

' No highlighting
.HighLight = flexHighlightNever
.FocusRect = flexFocusLight

' Enable texts to span multiple lines
.WordWrap = True

' Number of days in a week ;)
.Cols = 7

' For the date header
.Rows = lRows * 2
.Clear

lRow = 0
lCol = lFirstCol - 1
For lDate = lFirstDate To lLastDate
' Column and Row counters
lCol = lCol + 1
If lCol > 6 Then
lRow = lRow + 2
lCol = 0
End If

' Format the date header of the cell
.Col = lCol
.Row = lRow
.TextMatrix(lRow, lCol) = FormatDateTime(lDate, vbShortDate)
.CellAlignment = flexAlignRightTop
' Different color for weekend days
If Weekday(lDate, vbMonday) > 5 Then
.CellBackColor = RGB(239, 239, 239)
Else
.CellBackColor = vbWhite
End If
' Make it yellow when today
If lDate = Date Then .CellBackColor = vbYellow

' Format the data cell
.Row = lRow + 1
.CellBackColor = vbWhite
.CellAlignment = flexAlignLeftTop
.CellFontBold = True
' Different color for weekend days
If Weekday(lDate, vbMonday) > 5 Then
.CellBackColor = RGB(239, 239, 239)
Else
.CellBackColor = vbWhite
End If
' Make it yellow when today
If lDate = Date Then .CellBackColor = vbInfoBackground
Next lDate

' No fixed columns/rows
.FixedRows = 0
.FixedCols = 0

' Set the initial focus
.Col = lFirstCol
.Row = 1

SizeGrid

.Redraw = True
End With
End Sub

'---------------------------------------------------------------------------------------
' Procedure : SizeGrid
' DateTime : 11-7-2004 00:23
' Author : Flyguy
' Purpose : Resize the cells when the grid is resized
'---------------------------------------------------------------------------------------
'
Private Sub SizeGrid()
Dim lRowHeight As Long
Dim lRow As Long

' Don't care about resize errors
On Error Resume Next

With MSFlexGrid1
.Redraw = False

' Set the width of all columns
.ColWidth(-1) = Int(.Width / .Cols)

' Correct the width of last column
.ColWidth(.Cols - 1) = .ColWidth(.Cols - 1) + (.Width - .Cols * .ColWidth(.Cols - 1))

' Calculate the height of the data cells
lRowHeight = (.Height - (.Rows / 2) * .RowHeight(0)) / (.Rows / 2)

' Set the height of the data cells
For lRow = 1 To .Rows - 1 Step 2
.RowHeight(lRow) = lRowHeight
Next lRow

.Redraw = True
End With

End Sub

'---------------------------------------------------------------------------------------
' Procedure : SetCellFocus
' DateTime : 10-7-2004 23:56
' Author : Flyguy
' Purpose : Make sure to set the focus to the data part
'---------------------------------------------------------------------------------------
'
Private Sub SetCellFocus()
Dim lRow As Long
Dim lCol As Long

With MSFlexGrid1
lRow = .MouseRow
lCol = .MouseCol
If lRow >= 0 And lCol >= 0 Then
If lRow / 2 = lRow \ 2 Then lRow = lRow + 1
.Row = lRow
.Col = lCol
End If
End With
End Sub

Using the FillStyle property you can change a range of cells with a single command.
But you always have to take care about the current selected row, col, rowsel and colsel properties.
That's why I wrote a generic function which is capable of changing most of the cell properties with a single command.

Option Explicit

Private Enum FGCellStyle
fgcsBackColor = 1
fgcsForeColor = 2
fgcsText = 3
fgcsTextStyle = 4
fgcsFontName = 5
fgcsFontBold = 6
fgcsFontItalic = 7
fgcsAllignment = 8
End Enum

Private Sub Form_Load()
With MSFlexGrid1
.Cols = 10
.Rows = 10
End With

FG_Cell MSFlexGrid1, fgcsBackColor, 1, 1, 7, 7, RGB(191, 191, 255)
FG_Cell MSFlexGrid1, fgcsBackColor, 3, 2, 7, 5, vbGreen
FG_Cell MSFlexGrid1, fgcsForeColor, 1, 4, 3, 6, vbRed
FG_Cell MSFlexGrid1, fgcsText, 1, 1, 5, 5, "Hello"
FG_Cell MSFlexGrid1, fgcsFontBold, 2, 3, 5, 6, True
FG_Cell MSFlexGrid1, fgcsAllignment, 2, 4, 3, 4, flexAlignRightCenter
FG_Cell MSFlexGrid1, fgcsFontName, 1, 3, 2, 5, "Arial"
FG_Cell MSFlexGrid1, fgcsTextStyle, 1, 1, 3, 3, flexTextRaised
End Sub

Private Sub FG_Cell(FG As MSFlexGrid, ByVal What As FGCellStyle, Row1 As Long, Col1 As Long, Row2 As Long, Col2 As Long, Value As Variant)
Dim PrevRowCol(3) As Long ' to store the actual settings
Dim PrevFillStyle As Integer ' to store the actual settings

With FG
.Redraw = False

' Store current settings
PrevRowCol(0) = .Row
PrevRowCol(1) = .Col
PrevRowCol(2) = .RowSel
PrevRowCol(3) = .ColSel
PrevFillStyle = .FillStyle

' Set the range
.FillStyle = flexFillRepeat
.Row = Row1
.Col = Col1
.RowSel = Row2
.ColSel = Col2

' Apply changes
Select Case What
Case fgcsBackColor
.CellBackColor = Value
Case fgcsForeColor
.CellForeColor = Value
Case fgcsText
.Text = Value
Case fgcsTextStyle
.CellTextStyle = Value
Case fgcsFontName
.CellFontName = Value
Case fgcsFontBold
.CellFontBold = Value
Case fgcsFontItalic
.CellFontItalic = Value
Case fgcsAllignment
.CellAlignment = Value
End Select

' Restore settings
.FillStyle = PrevFillStyle
.Row = PrevRowCol(0)
.Col = PrevRowCol(1)
.RowSel = PrevRowCol(2)
.ColSel = PrevRowCol(3)

.Redraw = True
End With
End Sub

The MSFlexgrid does have some capabilities for sorting.
It works great if you want to sort 1 column.
If you want to sort multiple columns the flexgrid always sorts them from left to right and all in the same order (ascending/descending).

In the previous sort sample I used a stable sorting mechanisme, which means you sort the data in multiple steps while trying to preserve the orginal data order for other columns.
Somehow it isn't that stable at all and there are some problems when mixing ascending and descending sorting.

In the next sample I used a different technique which is not stable, but does the multi column sorting in a single step.

For this sample you need a form with:
1. MSFlexGrid control named MSFlexGrid1
1. Command button named Command1


'---------------------------------------------------------------------------------------
' Module : Form1
' DateTime : 27-12-2004
' Author : Flyguy
' Purpose : Demo for sorting multiple columns, data showed in a MSFlexGrid
'---------------------------------------------------------------------------------------
Option Explicit

Private Sub Form_Load()
Dim lRow As Long, lCol As Long

' Just fill the grid with some random data
With MSFlexGrid1
.Cols = 6
.Rows = 10
For lRow = .FixedRows To .Rows - 1
For lCol = .FixedCols To .Cols - 1
.TextMatrix(lRow, lCol) = Int(Rnd * 4)
Next lCol
Next lRow
End With
End Sub

Private Sub Command1_Click()
Dim aData() As String
Dim lRow As Long, lCol As Long
Dim cColumn As Collection, cOrder As Collection

' Put the grid data in a string array
With MSFlexGrid1
ReDim aData(.Rows - .FixedRows - 1, .Cols - .FixedCols - 1)
For lRow = .FixedRows To .Rows - 1
For lCol = .FixedCols To .Cols - 1
aData(lRow - .FixedRows, lCol - .FixedCols) = .TextMatrix(lRow, lCol)
Next lCol
Next lRow
End With

' Set the sorting parameters
Set cColumn = New Collection
Set cOrder = New Collection

cColumn.Add 0
cOrder.Add 1 ' sort Ascending

cColumn.Add 1
cOrder.Add -1 ' sort Descending

cColumn.Add 2
cOrder.Add 1 ' sort Ascending

' Sort the grid
ShellSortMultiColumn aData, cColumn, cOrder

' Put the data back in the grid
With MSFlexGrid1
For lRow = .FixedRows To .Rows - 1
For lCol = .FixedCols To .Cols - 1
.TextMatrix(lRow, lCol) = aData(lRow - .FixedRows, lCol - .FixedCols)
Next lCol
Next lRow
End With

End Sub

In a module:

'---------------------------------------------------------------------------------------
' Module : modShellSort
' DateTime : 27-12-2004
' Author : Flyguy
'---------------------------------------------------------------------------------------
Option Explicit

'---------------------------------------------------------------------------------------
' Procedure : ShellSortMultiColumn
' DateTime : 27-12-2004
' Author : Flyguy
' Purpose : Sort a 2D string array on multiple columns
'---------------------------------------------------------------------------------------
Public Sub ShellSortMultiColumn(sArray() As String, cColumns As Collection, _
cOrder As Collection)

Dim lLoop1 As Long, lHValue As Long
Dim lUBound As Long, lLBound As Long
Dim lUBound2 As Long, lLBound2 As Long
Dim lNofColumns As Long
Dim aColumns() As Long, aOrder() As Long
Dim bSorted As Boolean

If cColumns Is Nothing Then Exit Sub
If cOrder Is Nothing Then Exit Sub
If cColumns.Count <> cOrder.Count Then Exit Sub

lNofColumns = cColumns.Count
ReDim aColumns(lNofColumns)
ReDim aOrder(lNofColumns)
For lLoop1 = 1 To lNofColumns
aColumns(lLoop1) = cColumns(lLoop1)
aOrder(lLoop1) = cOrder(lLoop1)
Next lLoop1

lUBound = UBound(sArray)
lLBound = LBound(sArray)

lUBound2 = UBound(sArray, 2)
lLBound2 = LBound(sArray, 2)

lHValue = (lUBound - lLBound) \ 2

Do While lHValue > lLBound
Do
bSorted = True
For lLoop1 = lLBound To lUBound - lHValue
If CompareValues(sArray, lLoop1, lLoop1 + lHValue, lNofColumns, _
aColumns, aOrder) Then
SwapLines sArray, lLoop1, lLoop1 + lHValue, lLBound2, lUBound2
bSorted = False
End If
Next lLoop1

Loop Until bSorted
lHValue = lHValue \ 2
Loop

End Sub

'---------------------------------------------------------------------------------------
' Procedure : SwapLines
' DateTime : 27-12-2004
' Author : Flyguy
' Purpose : Swap a row of data in a 2D array
'---------------------------------------------------------------------------------------
Private Sub SwapLines(ByRef sArray() As String, lIndex1 As Long, _
lIndex2 As Long, lLBound As Long, lUBound As Long)

Dim i As Long, sTemp As String

For i = lLBound To lUBound
sTemp = sArray(lIndex1, i)
sArray(lIndex1, i) = sArray(lIndex2, i)
sArray(lIndex2, i) = sTemp
Next i
End Sub

'---------------------------------------------------------------------------------------
' Procedure : CompareValues
' DateTime : 27-12-2004
' Author : Flyguy
' Purpose : Compare column values for multicolumn sorting
'---------------------------------------------------------------------------------------
Private Function CompareValues(ByRef sArray() As String, lIndex1 As Long, _
lIndex2 As Long, lNofColumns As Long, aColumns() As Long, aOrder() As Long)

Dim i As Long
Dim lCol As Long
Dim sValue1 As String, sValue2 As String

For i = 1 To lNofColumns
lCol = aColumns(i)
If aOrder(i) = 1 Then
sValue1 = sArray(lIndex1, lCol)
sValue2 = sArray(lIndex2, lCol)
Else
sValue1 = sArray(lIndex2, lCol)
sValue2 = sArray(lIndex1, lCol)
End If

If sValue1 < sValue2 Then
Exit For
ElseIf sValue1 > sValue2 Then
CompareValues = True
Exit For
End If

Next i

End Function

An updated version of CompareValues function to take in account Numeric/Date values:

'---------------------------------------------------------------------------------------
' Procedure : CompareValues
' DateTime : 27-12-2004
' Author : Flyguy
' Purpose : Compare column values for multicolumn sorting
' Revision : 15-02-2005, take in account numeric and date values
'---------------------------------------------------------------------------------------
Private Function CompareValues(ByRef sArray() As String, lIndex1 As Long, _
lIndex2 As Long, lNofColumns As Long, aColumns() As Long, aOrder() As Long)

Dim i As Long
Dim lCol As Long
Dim sValue1 As String, sValue2 As String
Dim dValue1 As Double, dValue2 As Double
Dim bNumeric As Boolean

For i = 1 To lNofColumns
lCol = aColumns(i)
If aOrder(i) = 1 Then
sValue1 = sArray(lIndex1, lCol)
sValue2 = sArray(lIndex2, lCol)
Else
sValue1 = sArray(lIndex2, lCol)
sValue2 = sArray(lIndex1, lCol)
End If

If IsDate(sValue1) And IsDate(sValue2) Then
dValue1 = CDate(sValue1)
dValue2 = CDate(sValue2)
bNumeric = True
ElseIf IsNumeric(sValue1) And IsNumeric(sValue2) Then
dValue1 = CDbl(sValue1)
dValue2 = CDbl(sValue2)
bNumeric = True
Else
bNumeric = False
End If

If bNumeric Then
If dValue1 < dValue2 Then
Exit For
ElseIf dValue1 > dValue2 Then
CompareValues = True
Exit For
End If
Else
If sValue1 < sValue2 Then
Exit For
ElseIf sValue1 > sValue2 Then
CompareValues = True
Exit For
End If
End If
Next i

End Function

Create HTML table from MSFlexGrid control:

'---------------------------
' Module : modFlexHTML
' DateTime : 7-4-2005
' Author : ComponentOne, adapted by Flyguy to be used with MSFlexGrid
' Purpose : Exporting MSFlexGrid to HTML
'---------------------------
Option Explicit

Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Const EXTRAWIDTH As Double = 1.2

'---------------------------
' Procedure : HTMLColor
' DateTime : 30-1-2004
' Author : ComponentOne
' Purpose : converts a VB color into HTML color code
'---------------------------
Private Function HTMLColor(ByVal lColor As Long) As String
Dim sTemp As String

' convert to hex
sTemp = Hex$(lColor)

' handle system colors
If Len(sTemp) > 6 Then
If Left$(sTemp, 1) = "8" Then
lColor = Val("&H" & Mid$(sTemp, 2))
lColor = GetSysColor(lColor)
sTemp = Hex$(lColor)
End If
End If

' build format
sTemp = String(6 - Len(sTemp), "0") & sTemp
HTMLColor = """#" & Right$(sTemp, 2) & Mid$(sTemp, 3, 2) & Left$(sTemp, 2) & """"
End Function

'---------------------------
' Procedure : HTMLText
' DateTime : 30-1-2004
' Author : ComponentOne
' Purpose : converts a VB string into an HTML string
'---------------------------
Private Function HTMLText(ByVal sLine As String) As String

If Len(sLine) = 0 Then
HTMLText = "&nbsp;"
Else
HTMLText = Replace$(sLine, "&", "&amp;")
HTMLText = Replace$(HTMLText, "<", "&lt;")
HTMLText = Replace$(HTMLText, ">", "&gt;")
End If

End Function

'---------------------------
' Procedure : FlexGridToHTML
' DateTime : 7-4-2005
' Author : ComponentOne, adapted by Flyguy to be used with MSFlexGrid
' Purpose : Exporting MSFlexGrid to HTML
'---------------------------
Public Function FlexGridToHTML(FG As MSFlexGrid) As String
Dim sData As String, sLine As String
Dim dTblWidth As Double
Dim i As Long, lRow As Long, lCol As Long
Dim sSpan As String
Dim lRow1 As Long, lRow2 As Long, lCol1 As Long, lCol2 As Long
Dim dWidth As Double
Dim sText As String, sTemp As String
Dim sBackGround As String, lColor As Long
Dim sFont As String, sBorder As String, sFontFX As String
Dim sAlign As String, sCell As String
Dim bProcessCell As Boolean

With FG
.Redraw = False

' get total table width in pixels
dTblWidth = 0
For lCol = 0 To .Cols - 1
dTblWidth = dTblWidth + .ColWidth(lCol)
Next lCol
dTblWidth = EXTRAWIDTH * dTblWidth / Screen.TwipsPerPixelX

' save table header
sData = "<table border cellspacing=0 cellpadding=2 vAlign=center" & _
" bgcolor=" & HTMLColor(.BackColor) & _
" width=" & Format(Int(dTblWidth)) & _
">" & vbCrLf

' loop through the rows
For lRow = 0 To .Rows - 1

sLine = ""

' skip hidden rows
If .RowHeight(lRow) > 0 Then

' start row
sLine = "<tr>"

' loop through the columns
For lCol = 0 To .Cols - 1

' skip hidden cols
If .ColWidth(lCol) > 0 Then

.Col = lCol
.Row = lRow
bProcessCell = True

' handle merges
sSpan = ""
GetMergedCols FG, lRow, lCol, lCol1, lCol2
GetMergedRows FG, lRow, lCol, lRow1, lRow2
If lCol1 < lCol Then bProcessCell = False
If lRow1 < lRow Then bProcessCell = False

If bProcessCell Then
If lCol2 > lCol Then sSpan = " colspan=" & (lCol2 - lCol + 1)
If lRow2 > lRow Then sSpan = sSpan & " rowspan=" & (lRow2 - lRow + 1)

' get col width
dWidth = 0
For i = lCol1 To lCol2
dWidth = dWidth + .ColWidth(i)
Next
dWidth = EXTRAWIDTH * dWidth / Screen.TwipsPerPixelX

' get cell text
sText = HTMLText(.TextMatrix(lRow, lCol))

' get back color
sBackGround = ""
lColor = .CellBackColor
If lColor <> 0 Then
sBackGround = " bgcolor=" & HTMLColor(lColor)
ElseIf lRow < .FixedRows Or lCol < .FixedCols Then
sBackGround = " bgcolor=" & HTMLColor(.BackColorFixed)
End If

' get border color
sBorder = ""
If lRow < .FixedRows Or lCol < .FixedCols Then
sBorder = " bordercolor=" & HTMLColor(.GridColorFixed)
Else
sBorder = " bordercolor=" & HTMLColor(.GridColor)
End If

' get fore color and font name
sFont = " size=2"
sTemp = .CellFontName
If sTemp <> .FontName Then
sFont = " face=" & """" & sTemp & """"
End If
lColor = .CellForeColor
If lColor <> 0 Then sFont = " color=" & HTMLColor(lColor)

' get font effects
sFontFX = ""
If .CellFontBold Then sFontFX = sFontFX & "<B>"
If .CellFontItalic Then sFontFX = sFontFX & "<I>"
If .CellFontUnderline Then sFontFX = sFontFX & "<U>"

' get alignment
sAlign = ""
Select Case .CellAlignment
Case flexAlignCenterBottom
sAlign = " align=center valign=bottom"
Case flexAlignCenterCenter
sAlign = " align=center"
Case flexAlignCenterTop
sAlign = " align=center valign=top"
Case flexAlignLeftBottom
sAlign = " valign=bottom"
Case flexAlignLeftCenter
sAlign = ""
Case flexAlignLeftTop
sAlign = " valign=top"
Case flexAlignRightBottom
sAlign = " align=right valign=bottom"
Case flexAlignRightCenter
sAlign = " align=right"
Case flexAlignRightTop
sAlign = " align=right valign=top"
Case Else
If IsNumeric(.TextMatrix(lRow, lCol)) Then
sAlign = " align=right valign=bottom"
End If
End Select

' build HTML cell string
sTemp = """" & Format(dWidth / dTblWidth, "#%") & """"
sCell = "<td width=" & sTemp & sBackGround & sAlign & sBorder & sSpan & ">"
If sFont <> "" Then sCell = sCell & "<FONT" & sFont & ">"
sCell = sCell & sFontFX & sText
If InStr(sFontFX, "B") > 0 Then sCell = sCell & "</B>"
If InStr(sFontFX, "I") > 0 Then sCell = sCell & "</I>"
If InStr(sFontFX, "U") > 0 Then sCell = sCell & "</U>"
If sFont <> "" Then sCell = sCell & "</font>"

' end cell
sCell = sCell & "</td>"
sLine = sLine & sCell

End If ' ProcessCell
End If ' .ColWidth(lCol) > 0 Then

Next lCol

' end row
If Len(sLine) > 0 Then sData = sData & sLine & "</tr>" & vbCrLf

End If ' .RowHeight(lRow) > 0 Then
Next lRow

.Redraw = True
End With
' table end
sData = sData & "</table></font>"

' return success
FlexGridToHTML = sData
End Function

'---------------------------
' Procedure : GetMergedCols
' DateTime : 7-4-2005
' Author : Flyguy
'---------------------------
Private Sub GetMergedCols(FG As MSFlexGrid, ByVal Row As Long, _
ByVal Col As Long, ByRef lStart As Long, ByRef lEnd As Long)
Dim lCol As Long
Dim lCnt As Long

lStart = Col
lEnd = Col

With FG
If Row < .FixedRows Then
For lCol = Col - 1 To 0 Step -1
If .ColWidth(lCol) <> 0 Then
If .TextMatrix(Row, lCol) = .TextMatrix(Row, Col) Then
lCnt = lCnt + 1
Else
Exit For
End If
End If
Next lCol
If lCnt > 0 Then lStart = Col - lCnt

lCnt = 0
For lCol = Col + 1 To .Cols - 1
If .ColWidth(lCol) <> 0 Then
If .TextMatrix(Row, lCol) = .TextMatrix(Row, Col) Then
lCnt = lCnt + 1
Else
Exit For
End If
End If
Next lCol
If lCnt > 0 Then lEnd = Col + lCnt

End If
End With
End Sub

'--------------------------
' Procedure : GetMergedRows
' DateTime : 7-4-2005
' Author : Flyguy
'--------------------------
Private Sub GetMergedRows(FG As MSFlexGrid, ByVal Row As Long, _
ByVal Col As Long, ByRef lStart As Long, ByRef lEnd As Long)
Dim lRow As Long
Dim lCnt As Long

lStart = Row
lEnd = Row

With FG
If Col < .FixedCols Then
For lRow = Row - 1 To 0 Step -1
If .RowHeight(lRow) <> 0 Then
If .TextMatrix(lRow, Col) = .TextMatrix(Row, Col) Then
lCnt = lCnt + 1
Else
Exit For
End If
End If
Next lRow
If lCnt > 0 Then lStart = Row - lCnt

For lRow = Row + 1 To .Rows - 1
If .RowHeight(lRow) <> 0 Then
If .TextMatrix(lRow, Col) = .TextMatrix(Row, Col) Then
lCnt = lCnt + 1
Else
Exit For
End If
End If
Next lRow
If lCnt > 0 Then lEnd = Row + lCnt
End If

End With
End Sub

Snippet from MS knowledge base how to put HTML data on the clipboard, so you can paste in for example Word:

'---------------------------------------------------------------------------------------
' Module : modClipBoardHTML
' DateTime : 2-4-2004
' Author : Microsoft
' Purpose : HOWTO: Add HTML Code to the Clipboard by Using Visual Basic
' Revision :
'---------------------------------------------------------------------------------------

Option Explicit

Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, _
ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias _
"RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" ( _
ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
pDest As Any, pSource As Any, ByVal cbLength As Long)
Private Declare Function GetClipboardData Lib "user32" ( _
ByVal wFormat As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" ( _
ByVal lpData As Long) As Long

Private Const m_sDescription = _
"Version:1.0" & vbCrLf & _
"StartHTML:aaaaaaaaaa" & vbCrLf & _
"EndHTML:bbbbbbbbbb" & vbCrLf & _
"StartFragment:cccccccccc" & vbCrLf & _
"EndFragment:dddddddddd" & vbCrLf

Private m_cfHTMLClipFormat As Long

Private Function RegisterCF() As Long

'Register the HTML clipboard format
If (m_cfHTMLClipFormat = 0) Then
m_cfHTMLClipFormat = RegisterClipboardFormat("HTML Format")
End If
RegisterCF = m_cfHTMLClipFormat

End Function

Public Sub PutHTMLClipboard(sHtmlFragment As String, _
Optional sContextStart As String = "<HTML><BODY>", _
Optional sContextEnd As String = "</BODY></HTML>")

Dim sData As String

If RegisterCF = 0 Then Exit Sub

'Add the starting and ending tags for the HTML fragment
sContextStart = sContextStart & "<!--StartFragment -->"
sContextEnd = "<!--EndFragment -->" & sContextEnd

'Build the HTML given the description, the fragment and the context.
'And, replace the offset place holders in the description with values
'for the offsets of StartHMTL, EndHTML, StartFragment and EndFragment.
sData = m_sDescription & sContextStart & sHtmlFragment & sContextEnd
sData = Replace(sData, "aaaaaaaaaa", _
Format(Len(m_sDescription), "0000000000"))
sData = Replace(sData, "bbbbbbbbbb", Format(Len(sData), "0000000000"))
sData = Replace(sData, "cccccccccc", Format(Len(m_sDescription & _
sContextStart), "0000000000"))
sData = Replace(sData, "dddddddddd", Format(Len(m_sDescription & _
sContextStart & sHtmlFragment), "0000000000"))

'Add the HTML code to the clipboard
If CBool(OpenClipboard(0)) Then

Dim hMemHandle As Long, lpData As Long

hMemHandle = GlobalAlloc(0, Len(sData) + 10)

If CBool(hMemHandle) Then

lpData = GlobalLock(hMemHandle)
If lpData <> 0 Then

CopyMemory ByVal lpData, ByVal sData, Len(sData)
GlobalUnlock hMemHandle
EmptyClipboard
SetClipboardData m_cfHTMLClipFormat, hMemHandle

End If

End If

Call CloseClipboard
End If

End Sub

Public Function GetHTMLClipboard() As String

Dim sData As String

If RegisterCF = 0 Then Exit Function

If CBool(OpenClipboard(0)) Then

Dim hMemHandle As Long, lpData As Long
Dim nClipSize As Long

GlobalUnlock hMemHandle

'Retrieve the data from the clipboard
hMemHandle = GetClipboardData(m_cfHTMLClipFormat)

If CBool(hMemHandle) Then

lpData = GlobalLock(hMemHandle)
If lpData <> 0 Then
nClipSize = lstrlen(lpData)
sData = String(nClipSize + 10, 0)


Call CopyMemory(ByVal sData, ByVal lpData, nClipSize)

Dim nStartFrag As Long, nEndFrag As Long
Dim nIndx As Long

'If StartFragment appears in the data's description,
'then retrieve the offset specified in the description
'for the start of the fragment. Likewise, if EndFragment
'appears in the description, then retrieve the
'corresponding offset.
nIndx = InStr(sData, "StartFragment:")
If nIndx Then
nStartFrag = CLng(Mid(sData, _
nIndx + Len("StartFragment:"), 10))

End If
nIndx = InStr(sData, "EndFragment:")
If nIndx Then
nEndFrag = CLng(Mid(sData, nIndx + Len("EndFragment:"), 10))
End If

'Return the fragment given the starting and ending
'offsets
If (nStartFrag > 0 And nEndFrag > 0) Then
GetHTMLClipboard = Mid(sData, nStartFrag + 1, _
(nEndFrag - nStartFrag))
End If

End If

End If


Call CloseClipboard
End If

End Function

Sample to export a Flexgrid to Excel using Excel Automation, also exports font-styles, fore- and background colors.

Rows with a height of 0 and columns with a width of 0 are not exported.