Not a Member Yet,
Click here to Register

ID: 253
Viewed: 3065
Added: Jul 26, 2002
Version:
Snippet uploaded by: snippet
Written By: unknown
Demo: Sorry, no demo



User Rated at: 0 Stars
Rate This:

Thank you for your vote. Please wait...

It appears you already voted for this snippet

It appears your vote value was empty

The code On this page Is For a class module that you can Add To your project To enable editing of a flexgrid cells at runtime. Please note: this class module can only be used With VB6 (Or later ?) As it adds a textbox , other than that the principles would be similar For VB5.

How To use:
Copy the code from below, And Put it In a class module And Name the module appropriately (eg clsFlexGridEdit) . Then In your form you Add a reference To the class, eg:

Public clsFGEdit As clsFlexGridEdit
Then To enable editing you would invoke this code:
Set clsFGEdit = New clsFlexGridEdit
Set clsFGEdit.FlexGridControl = MSFlexGrid1

How it works:
When you Set the FlexGridControl Property of the class, the class Then also receives your flexgrid events. A textbox Is added To your flexgrid's container and it's events are handled within the class module.

The textbox Is moved With the flexgrid's cells while editing and moved back into view when the user presses any key. Note: the FlexGrid control has a strange "feature" that if you read the CellLeft or CellTop properties it forces that cell into view. This "feature" is used to move the textbox back into view after the flexgrid was scrolled, but also means that to determine if a cell is in view we have to calculate the column widths and row widths rather than read from the CellLeft or CellTop properties.

This class also lets you Set the Enter key And Tab key behaviour While editing. The Tab key behaviour Is invoked by setting the TabStop Property of all controls On the form To False, Then restoring their TabStop Property once editing Is complete. If you have many controls On the form, it might be better To subclass the textbox.

Highlight all by clicking in box
<!---Declaration--->
none

Highlight All
<!---Code--->
'Put this code In a class module
Option Explicit

Public Enum FlexEditKeyBehaviour
fgEditNone = 0
fgEditMoveRight = 1
fgEditMoveDown = 2
fgEditMoveup = 3
End Enum

Private Type cntlInfo
blnIsArray As Boolean
lngIndex As Long
strName As String
blntabStop As Boolean
End Type

Private WithEvents Fg As MSFlexGrid
Private WithEvents Tb As TextBox

Private strTbName As String
Private prntCntls() As cntlInfo
Private m_TbBorderStyle As AppearanceSettings
Private m_EnterKeyBehaviour As FlexEditKeyBehaviour
Private m_TabKeyBehaviour As FlexEditKeyBehaviour
Private m_blnMoving As Boolean

'_____________________________________________________________________
Public Property Set FlexGridControl(fgControl As MSFlexGrid)
RemoveOldTextBox
Set Fg = fgControl
On Error Resume Next
strTbName = "tbFgEdit"
Do
Err = 0
strTbName = strTbName & "1"
Fg.Parent.Controls.Add "VB.TextBox", strTbName, Fg.Container
Loop While Err <> 0
Set Tb = Fg.Parent.Controls(strTbName)
With Tb
.Visible = False
.BorderStyle = m_TbBorderStyle
Set .Font = Fg.Font
.TabStop = False
.ZOrder
End With
End Property
'_____________________________________________________________________
Public Property Let EditBoxBorderStyle(varBorderStyle As AppearanceSettings)
m_TbBorderStyle = varBorderStyle
If Not Tb Is Nothing Then Tb.BorderStyle = m_TbBorderStyle
End Property
'_____________________________________________________________________
Public Property Let EnterKeyBehaviour(varKeyBehaviour As FlexEditKeyBehaviour)
m_EnterKeyBehaviour = varKeyBehaviour
End Property
'_____________________________________________________________________
Public Property Let TabKeyBehaviour(varKeyBehaviour As FlexEditKeyBehaviour)
' need to restore tabstops to parent controls if varKeyBehaviour = 0
If varKeyBehaviour = fgEditNone Then
If m_TabKeyBehaviour <> fgEditNone Then RestoreTabStops
End If
m_TabKeyBehaviour = varKeyBehaviour
End Property
'_____________________________________________________________________
Private Sub Class_Initialize()
ReDim prntCntls(0)
End Sub
'_____________________________________________________________________
Private Sub Class_Terminate()
RemoveOldTextBox
End Sub

'++++++++++++++++++++++++++++++
'flex grid events
'_____________________________________________________________________
Private Sub fg_DblClick()
fgInitEdit 32
End Sub
'_____________________________________________________________________
Private Sub fg_KeyPress(KeyAscii As Integer)
fgInitEdit KeyAscii
End Sub
'_____________________________________________________________________
Private Sub fg_GotFocus()
UpdateFg
End Sub
'_____________________________________________________________________
Private Sub fg_LeaveCell()
If Not m_blnMoving Then UpdateFg
End Sub
'_____________________________________________________________________
Private Sub fg_Scroll()
Dim dx As Long, dy As Long
' move tb with cell or hide if cell out of view
If Tb.Visible Then
With Fg
If .RowIsVisible(.Row) And .ColIsVisible(.Col) Then
dx = .Left + .Container.ScaleX(.CellLeft, vbTwips, .Container.ScaleMode)
dy = .Top + .Container.ScaleY(.CellTop, vbTwips, .Container.ScaleMode)
Tb.Move dx, dy
Else
Tb.Move -Tb.Width, -Tb.Height
End If
End With
End If
End Sub

'+++++++++++++++++++++++
' Text box events
'_____________________________________________________________________
Private Sub tb_KeyPress(KeyAscii As Integer)
' get rid of beeps.
Select Case KeyAscii
Case 9, 13, 27
KeyAscii = 0
End Select
End Sub
'_____________________________________________________________________
Private Sub tb_KeyDown(KeyCode As Integer, Shift As Integer)
Dim i As Long
'read cellTop & cellLeft properties to force into view
If (Tb.Left < 0) Or (Tb.Top < 0) Then
i = Fg.CellTop
i = Fg.CellLeft
End If

Select Case KeyCode

Case 9 ' tab key
MoveToCell m_TabKeyBehaviour

Case 13 ' ENTER key
MoveToCell m_EnterKeyBehaviour

Case 27 ' ESC
Tb.Visible = False
Fg.SetFocus

Case 38 ' Up.
MoveToCell fgEditMoveup

Case 40 ' Down.
MoveToCell fgEditMoveDown
End Select

End Sub
'_____________________________________________________________________
Private Sub Tb_LostFocus()
RestoreTabStops
End Sub
'_____________________________________________________________________
' +++++++++++++++++++++++
' Utility functions

Private Sub fgInitEdit(KeyAscii As Integer)
Dim sngL As Single, sngT As Single, sngW As Single, sngH As Single
Select Case KeyAscii
' A space means edit the current text.
Case 0 To 32
Tb = Fg.Text
Tb.SelStart = 0
Tb.SelLength = Len(Tb.Text)
' Anything else means replace the current text.
Case Else
Tb = Chr(KeyAscii)
Tb.SelStart = Len(Tb.Text)
End Select

With Fg.Container
sngL = .ScaleX(Fg.CellLeft, vbTwips, .ScaleMode)
sngT = .ScaleY(Fg.CellTop, vbTwips, .ScaleMode)
sngW = .ScaleX(Fg.CellWidth, vbTwips, .ScaleMode)
sngH = .ScaleY(Fg.CellHeight, vbTwips, .ScaleMode)
End With
' Show textbox at the right place.

Tb.Move Fg.Left + sngL, Fg.Top + sngT, sngW, sngH
Tb.Visible = True
Tb.SetFocus
If m_TabKeyBehaviour <> fgEditNone Then
RestoreTabStops
RemoveTabStops
End If
End Sub
'_____________________________________________________________________
Private Sub MoveToCell(varMoveBehaviour As FlexEditKeyBehaviour)
m_blnMoving = True
Select Case varMoveBehaviour

Case fgEditNone
Fg.SetFocus

Case fgEditMoveDown
Fg.Text = Tb.Text
If Fg.Row + 1 < Fg.Rows Then
Fg.Row = Fg.Row + 1
ElseIf Fg.Col + 1 < Fg.Cols Then
Fg.Col = Fg.Col + 1
Fg.Row = Fg.FixedRows
Else
Fg.Col = Fg.FixedCols
Fg.Row = Fg.FixedRows
End If
fgInitEdit 0

Case fgEditMoveRight
Fg.Text = Tb.Text
If Fg.Col + 1 < Fg.Cols Then
Fg.Col = Fg.Col + 1
ElseIf Fg.Row + 1 < Fg.Rows Then
Fg.Row = Fg.Row + 1
Fg.Col = Fg.FixedCols
Else
Fg.Col = Fg.FixedCols
Fg.Row = Fg.FixedRows
End If
fgInitEdit 0

Case fgEditMoveup
Fg.Text = Tb.Text
If Fg.Row > Fg.FixedRows Then
Fg.Row = Fg.Row - 1
ElseIf Fg.Col > Fg.FixedCols Then
Fg.Col = Fg.Col - 1
Fg.Row = Fg.Rows - 1
Else
Fg.Col = Fg.Cols - 1
Fg.Row = Fg.Rows - 1
End If
fgInitEdit 0

End Select
m_blnMoving = False
End Sub
'_____________________________________________________________________
Private Sub RemoveTabStops()
Dim cntl As Control, i As Long
On Error Resume Next
With Fg.Parent
ReDim prntCntls(.Controls.Count)
For Each cntl In .Controls
i = i + 1
If TypeName(.Controls(cntl.Name)) = "Object" Then
prntCntls(i).blnIsArray = True
prntCntls(i).lngIndex = cntl.Index
End If
prntCntls(i).strName = cntl.Name
prntCntls(i).blntabStop = cntl.TabStop
cntl.TabStop = False
Next
End With
End Sub
'_____________________________________________________________________
Private Sub RestoreTabStops()
Dim i As Long
If Fg Is Nothing Then Exit Sub
On Error Resume Next
With Fg.Parent
For i = 1 To UBound(prntCntls)
If prntCntls(i).blnIsArray Then
.Controls(prntCntls(i).strName)(prntCntls(i).lngIndex).TabStop = prntCntls(i).blntabStop
Else
.Controls(prntCntls(i).strName).TabStop = prntCntls(i).blntabStop
End If
Next
End With
ReDim prntCntls(0)
End Sub
'_____________________________________________________________________
Private Sub RemoveOldTextBox()
On Error Resume Next
If Not Fg Is Nothing Then
Set Tb = Nothing
Fg.Parent.Controls.Remove strTbName
Set Fg = Nothing
End If
End Sub
'_____________________________________________________________________
Private Sub UpdateFg()
If Tb.Visible = False Then Exit Sub
Fg.Text = Tb.Text
Tb.Visible = False
End Sub
'Put this code In a class module
Option Explicit

Public Enum FlexEditKeyBehaviour
fgEditNone = 0
fgEditMoveRight = 1
fgEditMoveDown = 2
fgEditMoveup = 3
End Enum

Private Type cntlInfo
blnIsArray As Boolean
lngIndex As Long
strName As String
blntabStop As Boolean
End Type

Private WithEvents Fg As MSFlexGrid
Private WithEvents Tb As TextBox

Private strTbName As String
Private prntCntls() As cntlInfo
Private m_TbBorderStyle As AppearanceSettings
Private m_EnterKeyBehaviour As FlexEditKeyBehaviour
Private m_TabKeyBehaviour As FlexEditKeyBehaviour
Private m_blnMoving As Boolean

'_____________________________________________________________________
Public Property Set FlexGridControl(fgControl As MSFlexGrid)
RemoveOldTextBox
Set Fg = fgControl
On Error Resume Next
strTbName = "tbFgEdit"
Do
Err = 0
strTbName = strTbName & "1"
Fg.Parent.Controls.Add "VB.TextBox", strTbName, Fg.Container
Loop While Err <> 0
Set Tb = Fg.Parent.Controls(strTbName)
With Tb
.Visible = False
.BorderStyle = m_TbBorderStyle
Set .Font = Fg.Font
.TabStop = False
.ZOrder
End With
End Property
'_____________________________________________________________________
Public Property Let EditBoxBorderStyle(varBorderStyle As AppearanceSettings)
m_TbBorderStyle = varBorderStyle
If Not Tb Is Nothing Then Tb.BorderStyle = m_TbBorderStyle
End Property
'_____________________________________________________________________
Public Property Let EnterKeyBehaviour(varKeyBehaviour As FlexEditKeyBehaviour)
m_EnterKeyBehaviour = varKeyBehaviour
End Property
'_____________________________________________________________________
Public Property Let TabKeyBehaviour(varKeyBehaviour As FlexEditKeyBehaviour)
' need to restore tabstops to parent controls if varKeyBehaviour = 0
If varKeyBehaviour = fgEditNone Then
If m_TabKeyBehaviour <> fgEditNone Then RestoreTabStops
End If
m_TabKeyBehaviour = varKeyBehaviour
End Property
'_____________________________________________________________________
Private Sub Class_Initialize()
ReDim prntCntls(0)
End Sub
'_____________________________________________________________________
Private Sub Class_Terminate()
RemoveOldTextBox
End Sub

'++++++++++++++++++++++++++++++
'flex grid events
'_____________________________________________________________________
Private Sub fg_DblClick()
fgInitEdit 32
End Sub
'_____________________________________________________________________
Private Sub fg_KeyPress(KeyAscii As Integer)
fgInitEdit KeyAscii
End Sub
'_____________________________________________________________________
Private Sub fg_GotFocus()
UpdateFg
End Sub
'_____________________________________________________________________
Private Sub fg_LeaveCell()
If Not m_blnMoving Then UpdateFg
End Sub
'_____________________________________________________________________
Private Sub fg_Scroll()
Dim dx As Long, dy As Long
' move tb with cell or hide if cell out of view
If Tb.Visible Then
With Fg
If .RowIsVisible(.Row) And .ColIsVisible(.Col) Then
dx = .Left + .Container.ScaleX(.CellLeft, vbTwips, .Container.ScaleMode)
dy = .Top + .Container.ScaleY(.CellTop, vbTwips, .Container.ScaleMode)
Tb.Move dx, dy
Else
Tb.Move -Tb.Width, -Tb.Height
End If
End With
End If
End Sub

'+++++++++++++++++++++++
' Text box events
'_____________________________________________________________________
Private Sub tb_KeyPress(KeyAscii As Integer)
' get rid of beeps.
Select Case KeyAscii
Case 9, 13, 27
KeyAscii = 0
End Select
End Sub
'_____________________________________________________________________
Private Sub tb_KeyDown(KeyCode As Integer, Shift As Integer)
Dim i As Long
'read cellTop & cellLeft properties to force into view
If (Tb.Left < 0) Or (Tb.Top < 0) Then
i = Fg.CellTop
i = Fg.CellLeft
End If

Select Case KeyCode

Case 9 ' tab key
MoveToCell m_TabKeyBehaviour

Case 13 ' ENTER key
MoveToCell m_EnterKeyBehaviour

Case 27 ' ESC
Tb.Visible = False
Fg.SetFocus

Case 38 ' Up.
MoveToCell fgEditMoveup

Case 40 ' Down.
MoveToCell fgEditMoveDown
End Select

End Sub
'_____________________________________________________________________
Private Sub Tb_LostFocus()
RestoreTabStops
End Sub
'_____________________________________________________________________
' +++++++++++++++++++++++
' Utility functions

Private Sub fgInitEdit(KeyAscii As Integer)
Dim sngL As Single, sngT As Single, sngW As Single, sngH As Single
Select Case KeyAscii
' A space means edit the current text.
Case 0 To 32
Tb = Fg.Text
Tb.SelStart = 0
Tb.SelLength = Len(Tb.Text)
' Anything else means replace the current text.
Case Else
Tb = Chr(KeyAscii)
Tb.SelStart = Len(Tb.Text)
End Select

With Fg.Container
sngL = .ScaleX(Fg.CellLeft, vbTwips, .ScaleMode)
sngT = .ScaleY(Fg.CellTop, vbTwips, .ScaleMode)
sngW = .ScaleX(Fg.CellWidth, vbTwips, .ScaleMode)
sngH = .ScaleY(Fg.CellHeight, vbTwips, .ScaleMode)
End With
' Show textbox at the right place.

Tb.Move Fg.Left + sngL, Fg.Top + sngT, sngW, sngH
Tb.Visible = True
Tb.SetFocus
If m_TabKeyBehaviour <> fgEditNone Then
RestoreTabStops
RemoveTabStops
End If
End Sub
'_____________________________________________________________________
Private Sub MoveToCell(varMoveBehaviour As FlexEditKeyBehaviour)
m_blnMoving = True
Select Case varMoveBehaviour

Case fgEditNone
Fg.SetFocus

Case fgEditMoveDown
Fg.Text = Tb.Text
If Fg.Row + 1 < Fg.Rows Then
Fg.Row = Fg.Row + 1
ElseIf Fg.Col + 1 < Fg.Cols Then
Fg.Col = Fg.Col + 1
Fg.Row = Fg.FixedRows
Else
Fg.Col = Fg.FixedCols
Fg.Row = Fg.FixedRows
End If
fgInitEdit 0

Case fgEditMoveRight
Fg.Text = Tb.Text
If Fg.Col + 1 < Fg.Cols Then
Fg.Col = Fg.Col + 1
ElseIf Fg.Row + 1 < Fg.Rows Then
Fg.Row = Fg.Row + 1
Fg.Col = Fg.FixedCols
Else
Fg.Col = Fg.FixedCols
Fg.Row = Fg.FixedRows
End If
fgInitEdit 0

Case fgEditMoveup
Fg.Text = Tb.Text
If Fg.Row > Fg.FixedRows Then
Fg.Row = Fg.Row - 1
ElseIf Fg.Col > Fg.FixedCols Then
Fg.Col = Fg.Col - 1
Fg.Row = Fg.Rows - 1
Else
Fg.Col = Fg.Cols - 1
Fg.Row = Fg.Rows - 1
End If
fgInitEdit 0

End Select
m_blnMoving = False
End Sub
'_____________________________________________________________________
Private Sub RemoveTabStops()
Dim cntl As Control, i As Long
On Error Resume Next
With Fg.Parent
ReDim prntCntls(.Controls.Count)
For Each cntl In .Controls
i = i + 1
If TypeName(.Controls(cntl.Name)) = "Object" Then
prntCntls(i).blnIsArray = True
prntCntls(i).lngIndex = cntl.Index
End If
prntCntls(i).strName = cntl.Name
prntCntls(i).blntabStop = cntl.TabStop
cntl.TabStop = False
Next
End With
End Sub
'_____________________________________________________________________
Private Sub RestoreTabStops()
Dim i As Long
If Fg Is Nothing Then Exit Sub
On Error Resume Next
With Fg.Parent
For i = 1 To UBound(prntCntls)
If prntCntls(i).blnIsArray Then
.Controls(prntCntls(i).strName)(prntCntls(i).lngIndex).TabStop = prntCntls(i).blntabStop
Else
.Controls(prntCntls(i).strName).TabStop = prntCntls(i).blntabStop
End If
Next
End With
ReDim prntCntls(0)
End Sub
'_____________________________________________________________________
Private Sub RemoveOldTextBox()
On Error Resume Next
If Not Fg Is Nothing Then
Set Tb = Nothing
Fg.Parent.Controls.Remove strTbName
Set Fg = Nothing
End If
End Sub
'_____________________________________________________________________
Private Sub UpdateFg()
If Tb.Visible = False Then Exit Sub
Fg.Text = Tb.Text
Tb.Visible = False
End Sub
;


No Comments to show

Please completely fill out the form below if you want to review this snippet. All reviews are subject to validation.


Replying to a Comment...


Adding your comment. Please wait...

Thanks for adding your comment!. After further review it will be added.

There was a problem adding your comment. Please try again.

Please complete all the fields in the form before sending.

© 2002 - 2024 snippetlibrary.com All Rights Reserved. Conditions
Do NOT follow this link or you will be banned from the site!