Xtreme Visual Basic Talk

Xtreme Visual Basic Talk (http://www.xtremevbtalk.com/)
-   Code Library (http://www.xtremevbtalk.com/code-library/)
-   -   Flexgrid functions (http://www.xtremevbtalk.com/code-library/35110-flexgrid-functions.html)

Flyguy 09-05-2003 09:24 AM

Searching the MSFlexGrid
 
2 Attachment(s)
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.

Flyguy 09-05-2003 10:43 AM

Moving columns by dragging
 
1 Attachment(s)
A sample project to show how to implement column movement by dragging columns.

Flyguy 10-08-2003 05:09 PM

Using the Mouse Wheel in the FlexGrid
 
Not my own code but a link to some other webpage:

404 - File or directory not found.

Original link is dead, so here the article:
Copy and paste from: https://web.archive.org/web/20061025...elsupport.html

Quote:

Mouse Wheel

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.

Flyguy 10-29-2003 07:43 AM

Changing complete row / column background color:
Code:
FlexGridColumnColor MSFlexGrid1, 2, vbRed FlexGridRowColor MSFlexGrid1, 3, vbBlue
Code:
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

Flyguy 11-07-2003 10:24 AM

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

Flyguy 12-01-2003 08:04 AM

Printing MSFlexgrid using SendMessage API
 
The original code can be found on ActiveVB.de
Code:
'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 --------------

Flyguy 01-13-2004 06:01 PM

FlexSpread Class
 
1 Attachment(s)
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
Code:
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.
Code:
cFlexSpread.TextFormula(4, 3) = "=[1,1] * Sin([3,3]))"

Also added 3 events:
Code:
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

Flyguy 07-05-2004 06:00 PM

Saving / Load MSFlexGrid Settings / Data
 
1 Attachment(s)
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

Flyguy 07-10-2004 05:30 PM

Using the MSFlexGrid as a Calendar
 
2 Attachment(s)
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

Flyguy 08-16-2004 10:56 AM

The power of the FillStyle property and a cell replacement function.
 
1 Attachment(s)
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

Flyguy 12-27-2004 03:02 AM

MultiColumn sort: the Next Generation
 
Quote:

Originally Posted by Flyguy
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

Flyguy 02-15-2005 02:04 AM

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

Flyguy 04-07-2005 08:36 AM

Create HTML table from MSFlexGrid control:
Code:
'--------------------------- ' 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

Flyguy 04-07-2005 08:39 AM

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

Flyguy 02-20-2007 02:39 AM

Export to Excel using Excel Automation
 
3 Attachment(s)
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.

dexmix 06-20-2014 08:13 AM

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



All times are GMT -6. The time now is 04:44 AM.

Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2017, vBulletin Solutions, Inc.
Search Engine Optimisation provided by DragonByte SEO v2.0.15 (Lite) - vBulletin Mods & Addons Copyright © 2017 DragonByte Technologies Ltd.
All site content is protected by the Digital Millenium Act of 1998. Copyright©2001-2011 MAS Media Inc. and Extreme Visual Basic Forum. All rights reserved.
You may not copy or reproduce any portion of this site without written consent.