How to implement additional support for wheel mice in VB6
With Visual Basic 6 now starting to look "long in the tooth" and no sign of a clear successor for developing desktop and networked systems, programmers are left to find solutions to missing functionality. The wheel mouse has established itself as a useful rodent and while Windows 2000 and XP provides some limited support for your applications two key controls have not been updated. The MSFlexgrid control has no mouse wheel support and incredibly the scrollbar control has been left out as well. However you can add suitable code to your applications to fill this gap.
Just a note of caution. This solution makes use of a "hook" into the Windows message stream directed at your program form. If you introduce an error into the WindowProc() function (detailed below) then you will may crash the Visual Basic IDE. Please make sure that you save your program before testing and that you try and eliminate any errors in the specified routine. Once up and running this solution is entirely stable.
First declare the Windows functions and the variables and constants shown. These are perhaps best added to a code module.
Code:
Private Declare Function CallWindowProc Lib "user32.dll" Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As Long, _
ByVal hWnd As Long, _
ByVal Msg As Long, _
ByVal Wparam As Long, _
ByVal Lparam As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" ( _
ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Public Const MK_CONTROL = &H8
Public Const MK_LBUTTON = &H1
Public Const MK_RBUTTON = &H2
Public Const MK_MBUTTON = &H10
Public Const MK_SHIFT = &H4
Private Const GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A
Dim LocalHwnd As Long
Dim LocalPrevWndProc As Long
Dim MyForm As Form
Now copy the following functions into the same code module.
Private Function WindowProc(ByVal Lwnd As Long, ByVal Lmsg As Long, ByVal Wparam As Long, ByVal Lparam As Long) As Long
Dim MouseKeys As Long
Dim Rotation As Long
Dim Xpos As Long
Dim Ypos As Long
If Lmsg = WM_MOUSEWHEEL Then
MouseKeys = Wparam And 65535
Rotation = Wparam / 65536
Xpos = Lparam And 65535
Ypos = Lparam / 65536
MyForm.MouseWheel MouseKeys, Rotation, Xpos, Ypos
End If
WindowProc = CallWindowProc(LocalPrevWndProc, Lwnd, Lmsg, Wparam, Lparam)
End Function
Public Sub WheelHook(PassedForm As Form)
On Error Resume Next
Set MyForm = PassedForm
LocalHwnd = PassedForm.hWnd
LocalPrevWndProc = SetWindowLong(LocalHwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub WheelUnHook()
Dim WorkFlag As Long
On Error Resume Next
WorkFlag = SetWindowLong(LocalHwnd, GWL_WNDPROC, LocalPrevWndProc)
Set MyForm = Nothing
End Sub
To activate the hook into the Windows message stream that detects the mouse wheel "event" you should call the WheelHook() Sub from the relevant Form Activate event. You should also remember to call the WheelUnHook() Sub from the Deactivate event. This cleans up by deactivating the hook into the relevant message stream but also means that you can apply this technique to multiple forms in the same application.
You will note that the WindowProc() function calls a routine on the form passed to the WheelHook() Sub as an argument. This routine is (arbitrarily) called MouseWheel() and has a number of arguments. You have to provide this Sub but there are two sample ones you might like to make use of below.
The first is intended to work with an MSFlexgrid control:
Code:
Public Sub MouseWheel(ByVal MouseKeys As Long, ByVal Rotation As Long, ByVal Xpos As Long, ByVal Ypos As Long)
Dim NewValue As Long
Dim Lstep As Single
On Error Resume Next
With MsFlexgrid1
Lstep = .Height / .RowHeight(0)
Lstep = Int(Lstep)
If Lstep < 10 Then
Lstep = 10
End If
If Rotation > 0 Then
NewValue = .TopRow - Lstep
If NewValue < 1 Then
NewValue = 1
End If
Else
NewValue = .TopRow + Lstep
If NewValue > .Rows - 1 Then
NewValue = .Rows - 1
End If
End If
. TopRow = NewValue
End With
End Sub
This version is for a vertical scroll bar
Code:
Public Sub MouseWheel(ByVal MouseKeys As Long, ByVal Rotation As Long, ByVal Xpos As Long, ByVal Ypos As Long)
Dim NewValue As Long
On Error Resume Next
With VScroll
If Rotation > 0 Then
NewValue = .Value - .LargeChange
If NewValue < .Min Then
NewValue = .Min
End If
Else
NewValue = .Value + .LargeChange
If NewValue > .Max Then
NewValue = .Max
End If
End If
. Value = NewValue
End With
End Sub
Remember that (perhaps counter intuitively) the horizontal scroll control may need to respond to mouse wheel action as well.
Simplification
You could decide that you are not going to make use of the additional mouse information such as the X and Y position and cut them from the call to your version of the MouseWheel() Sub
Taking it further
If your form has multiple controls without direct mouse wheel support then you could use the MouseMove events to track the control currently under the mouse cursor and then apply the wheel action to the appropriate control. Alternately you could use a click event upon the control in question to "capture" the mouse wheel actions.
Last edited by Flyguy; 01-28-2016 at 02:53 AM.
Reason: Dead link
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
Autoresize of columns in MSHFlexGrid with multiple bands
Code:
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
'Dieser Source stammt von [url]http://www.activevb.de[/url]
'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 --------------
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
Code:
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.
Code:
'---------------------------------------------------------------------------------------
' 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
The power of the FillStyle property and a cell replacement function.
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.
Code:
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
Code:
'---------------------------------------------------------------------------------------
' 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:
Code:
'---------------------------------------------------------------------------------------
' 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:
Code:
'---------------------------------------------------------------------------------------
' 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
'---------------------------
' 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 = " "
Else
HTMLText = Replace$(sLine, "&", "&")
HTMLText = Replace$(HTMLText, "<", "<")
HTMLText = Replace$(HTMLText, ">", ">")
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:
Code:
'---------------------------------------------------------------------------------------
' 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
Setting the FlexGrid Scrollbars to indicate visible page sizes...
I know I've seen posts elsewhere asking how to do this, with some API suggestions - but never code posted: so here's mine.
SetScrollPageSize needs to be called whenever
*the data on a grid is refreshed/populated
*on any form/grid resize,
*and on any column resize event if you allow column sizing.
I personally subclass the grid to get a column resize and then PostMessage a WM_SIZE event back to the form.
Code:
Private Const SB_HORZ As Long = 0
Private Const SB_VERT As Long = 1
Private Const SIF_RANGE As Long = 1
Private Const SIF_PAGE As Long = 2
Private Type SCROLLINFO
cbSize As Long
fMask As Long
nMin As Long
nMax As Long
nPage As Long
nPos As Long
nTrackPos As Long
End Type
Private Declare Function SetScrollInfo Lib "user32" (ByVal hWnd As Long, ByVal fnBar As Long, ByRef lpsi As SCROLLINFO, ByVal fRedraw As Boolean) As Long
Public Function FlexPageSize(Grid As MSHFlexGrid) As Long
FlexPageSize = Grid.Height \ Grid.RowHeight(0) - Grid.FixedRows
End Function
Public Function FlexPageSizeHorizontal(Grid As MSHFlexGrid) As Long
Const EXTRA_PAD As Long = 1 'extra padding / undersizing to make sure we can scroll to last column
Dim i As Long
Dim ColCount As Long
For i = Grid.LeftCol To Grid.Cols - Grid.FixedCols
If Not Grid.ColIsVisible(i) Then
FlexPageSizeHorizontal = Max(ColCount - EXTRA_PAD, 0)
Exit Function
End If
ColCount = ColCount + 1
Next i
FlexPageSizeHorizontal = Max(ColCount - 1 - EXTRA_PAD, 0)
End Function
' SetScrollPageSize
'
' Overrides a flexgrids scrollbars to properly indicate the grid's view/page size
'
Public Function SetScrollPageSize(Grid As MSHFlexGrid) As Long
Dim si As SCROLLINFO
si.cbSize = Len(si)
si.fMask = SIF_PAGE Or SIF_RANGE
si.nMin = Grid.FixedCols
si.nMax = Grid.Cols - Grid.FixedCols
si.nPage = Max(FlexPageSizeHorizontal(Grid) - 1, 1)
SetScrollPageSize = SetScrollInfo(Grid.hWnd, SB_HORZ, si, True)
si.nMin = Grid.FixedRows
si.nMax = Grid.Rows - Grid.FixedRows
si.nPage = Max(FlexPageSize(Grid) - 1, 1)
SetScrollPageSize = SetScrollInfo(Grid.hWnd, SB_VERT, si, True)
End Function
Last edited by dexmix; 06-20-2014 at 09:10 AM.
Reason: swapped vert/horz SetScroll
The ASP.NET 2.0 Anthology
101 Essential Tips, Tricks & Hacks - Free 156 Page Preview. Learn the most practical features and best approaches for ASP.NET. subscribe
Searching the MSFlexGrid
Saving / Load MSFlexGrid Settings / Data
Linear Mode
