然后编译成GridText.dll.即可.如果应用到该类,则在工程中引用该DLL,再参考上面的例子和说明.
‘以下部他是正式代码,仅供参考和学习交流用.CJWA@21CN.COM
Option Explicit
Dim LostFlag As Boolean
Dim M_DltL As Long '左增量
Dim M_DltT As Long '顶增量
Dim M_DltW As Long '宽增量
Dim M_DltH As Long '高增量
'/以下属性不能显示给用户.
Public M_MoveFlag As Boolean
Public M_EditRow As Long
Public M_EditCol As Long
Private M_AutoSize As Boolean '自动大小
Private M_PageEnabled As Boolean '翻页是否有效
Private M_ArrowEnabled As Boolean '箭头是否有效
Private M_EnterAction As Boolean '回车键的行为.
Private M_EditFix As Boolean '是否可编辑固定行
Private M_EnterNextRow As Boolean '如果是向右移到了网格的尽头,是否跳转下一行
Dim M_Picture As VB.PictureBox
'/事件声明
Private WithEvents Ev_GridObj As VBControlExtender '定义一个针对MSHFLEXGRID的通用事件.
Private WithEvents Ev_Text As VB.TextBox '定义一个TEXT事件
'/
'/******************属性******************
'BindGrid 绑定表格,如:SET BindGrid=Mshflexgrid1.(该属性是最重要的属性.必须首先设置)
Public Property Get BindGrid() As Object
Set BindGrid = Ev_GridObj
End Property
Public Property Set BindGrid(ByRef NewGrid As Object)
If UCase$(TypeName(NewGrid)) = UCase$("MSHFlexGrid") Then
Set Ev_GridObj = NewGrid '事件
Else
Set Ev_GridObj = Nothing
MsgBox "该属性只能与 MSHFlexGrid 绑定!" & Chr$(13) & "Cjwa@21cn.com" & Chr$(13) & "(0668)224", vbOKOnly, "错误!"
End If
End Property
'BindText 绑定文本框,如:SET BindText=ev_text.(该属性是最重要的属性.必须首先设置)
Public Property Get BindText() As Object
Set BindGrid = Ev_GridObj
End Property
Public Property Set BindText(ByRef NewText As Object)
If UCase$(TypeName(NewText)) = UCase$("TextBox") Then
Set Ev_Text = NewText '事件
Ev_Text.Text = ""
Ev_Text.Visible = False
Else
Set BindText = Nothing
MsgBox "该属性只能与 TextBox 绑定!" & Chr$(13) & "Cjwa@21cn.com" & Chr$(13) & "(0668)224", vbOKOnly, "错误!"
End If
End Property
'BindPicture 绑定图片框,如:SET BindPicture=PictureBox1.(该属性是最重要的属性.必须首先设置)
Public Property Get BindPicture() As Object
Set BindPicture = M_Picture
End Property
Public Property Set BindPicture(ByRef NewPicture As Object)
If UCase$(TypeName(NewPicture)) = UCase$("PictureBox") Then
Set M_Picture = NewPicture '事件
M_Picture.Visible = False
Else
Set BindPicture = Nothing
MsgBox "该属性只能与 PictureBox 绑定!" & Chr$(13) & "Cjwa@21cn.com" & Chr$(13) & "(0668)224", vbOKOnly, "错误!"
End If
End Property
'EditFixed 是否可以编辑固定行.
Public Property Get EditFixed() As Boolean
EditFixed = M_EditFix
End Property
Public Property Let EditFixed(ByVal NewValue As Boolean)
M_EditFix = NewValue
End Property
'EnterAction 回车键的行为
Public Property Get EnterAction() As Boolean
EnterAction = M_EnterAction
End Property
Public Property Let EnterAction(ByVal NewValue As Boolean)
M_EnterAction = NewValue
End Property
'EnterNextRow 如果是向右移到了网格的尽头,是否跳转下一行.(EnterAction=True)
Public Property Get EnterNextRow() As Boolean
EnterNextRow = M_EnterNextRow
End Property
Public Property Let EnterNextRow(ByVal NewValue As Boolean)
M_EnterNextRow = NewValue
End Property
'PageEnabled 是否可以翻页
Public Property Get PageEnabled() As Boolean
PageEnabled = M_PageEnabled
End Property
Public Property Let PageEnabled(ByVal NewValue As Boolean)
M_PageEnabled = NewValue
End Property
'ArrowEnabled 是否可以用箭头移动编辑框.
Public Property Get ArrowEnabled() As Boolean
ArrowEnabled = M_ArrowEnabled
End Property
Public Property Let ArrowEnabled(ByVal NewValue As Boolean)
M_ArrowEnabled = NewValue
End Property
'DltL 输入框左边距微调量
Public Property Get DltL() As Long
DltL = M_DltL
End Property
Public Property Let DltL(ByVal NewValue As Long)
M_DltL = NewValue
End Property
'DltT 输入框顶距边距微调量
Public Property Get DltT() As Long
DltT = M_DltT
End Property
Public Property Let DltT(ByVal NewValue As Long)
M_DltT = NewValue
End Property
'DltW 输入框宽度微调量.
Public Property Get DltW() As Long
DltW = M_DltW
End Property
Public Property Let DltW(ByVal NewValue As Long)
M_DltW = NewValue
End Property
'DltH 输入框高度微调量.
Public Property Get DltH() As Long
DltH = M_DltH
End Property
Public Property Let DltH(ByVal NewValue As Long)
M_DltH = NewValue
End Property
'AutoSize 当网格的行距或列距改变时,是否可以自动调整编辑框的位置.
Public Property Get AutoSize() As Boolean
AutoSize = M_AutoSize
End Property
Public Property Let AutoSize(ByVal NewValue As Boolean)
M_AutoSize = NewValue
End Property
'***********************方法**************************
'/在Scroll 事件中
Private Sub GridScroll()
On Error Resume Next
Ev_Text.Visible = False
End Sub
'/在KeyDown事件中
Private Sub TextKeyDown(KeyCode As Integer)
Dim EtxtSel As Long
On Error Resume Next
EtxtSel = Ev_Text.SelStart
If EtxtSel = 0 Then
If KeyCode = vbKeyLeft Then
Call CodeMove(KeyCode)
Exit Sub
End If
End If
If EtxtSel = Len(Ev_Text.Text) Then
If KeyCode = vbKeyRight Then
Call CodeMove(KeyCode)
Exit Sub
End If
End If
If KeyCode = vbKeyDown Or KeyCode = vbKeyUp Or _
KeyCode = vbKeyTab Or KeyCode = vbKeyReturn Or _
KeyCode = vbKeyPageUp Or KeyCode = vbKeyPageDown _
Or KeyCode = vbKeyHome Or KeyCode = vbKeyEnd Then
Call CodeMove(KeyCode)
End If
End Sub
Private Sub Class_Initialize()
M_AutoSize = False
M_PageEnabled = True '翻页是否有效
M_ArrowEnabled = True '箭头是否有效
M_EnterAction = True '回车键的行为.
M_EditFix = False '是否可编辑固定行
M_MoveFlag = True
M_EnterNextRow = True
End Sub
'/受绑定的MSHFLEXGRID中的事件.
Private Sub Ev_GridObj_ObjectEvent(Info As EventInfo)
'/通用事件接口
Select Case UCase$(Info.Name)
Case UCase$("MouseDown")
Call GridMouseDown
Case UCase$("Scroll")
Call GridScroll
Case UCase$("GotFocus")
Case UCase$("MouseUp")
Case UCase$("LeaveCell") '选择改变前发生.
Case UCase$("EnterCell") '选择改变后发生.
Case UCase$("RowColChange") '最后发生.
End Select
End Sub
'/TextChange
'/返回参数:
'/说明:编辑框的改变事件.
Private Sub Ev_Text_Change()
Dim OleWidth As Long
Dim NewWidth As Long
If Not (Ev_GridObj Is Nothing) Then
If Ev_GridObj.Visible And Ev_Text.Visible And M_AutoSize Then
With M_Picture
.Font.Name = Ev_Text.Font.Name
.Font.Bold = Ev_Text.Font.Bold
.Font.Italic = Ev_Text.Font.Italic
.Font.Underline = Ev_Text.Font.Underline
OleWidth = Ev_GridObj.ColWidth(M_EditCol)
NewWidth = .TextWidth(Ev_Text + "A") '这里你可以适当调整一下.有一个字符的差别
End With
With Ev_GridObj
If NewWidth > OleWidth Then
.ColWidth(.Col) = NewWidth
Ev_Text.Width = NewWidth
End If
End With
End If
Ev_GridObj.TextMatrix(M_EditRow, M_EditCol) = Ev_Text
End If
End Sub
'/用键盘事件移动编辑框
Private Sub CodeMove(KeyCode As Integer)
Dim FixRows As Long, FixCols As Long
Dim VisRow As Long
On Error Resume Next
M_MoveFlag = False
VisRow = CLng(Ev_GridObj.Height \\ (Ev_GridObj.RowHeight(Ev_GridObj.Rows - 1) + 37.5))
If M_EditFix Then
FixRows = 0: FixCols = 0
Else
FixRows = Ev_GridObj.FixedRows: FixCols = Ev_GridObj.FixedCols
End If
With Ev_GridObj
Select Case KeyCode
Case Is = vbKeyUp
If M_ArrowEnabled Then
If M_EditRow > FixRows Then
M_EditRow = M_EditRow - 1
Else
M_MoveFlag = True
Exit Sub
End If
Else
M_MoveFlag = True
Exit Sub
End If
Case Is = vbKeyDown
If M_ArrowEnabled Then
If M_EditRow < Ev_GridObj.Rows - 1 Then
M_EditRow = M_EditRow + 1
Else
M_MoveFlag = True
Exit Sub
End If
Else
M_MoveFlag = True
Exit Sub
End If
Case Is = vbKeyLeft
If M_ArrowEnabled Then
If M_EditCol > FixCols Then
M_EditCol = M_EditCol - 1
Else
M_MoveFlag = True
Exit Sub
End If
Else
M_MoveFlag = True
Exit Sub
End If
Case Is = vbKeyRight
If M_ArrowEnabled Then
If M_EditCol < Ev_GridObj.Cols - 1 Then
M_EditCol = M_EditCol + 1
Else
M_MoveFlag = True
Exit Sub
End If
Else
M_MoveFlag = True
Exit Sub
End If
Case Is = vbKeyTab
If M_EditCol < Ev_GridObj.Cols - 1 Then
M_EditCol = M_EditCol + 1
Else
M_MoveFlag = True
Exit Sub
End If
Case Is = vbKeyReturn
If EnterAction Then '向下移
If M_EditRow < Ev_GridObj.Rows - 1 Then
M_EditRow = M_EditRow + 1
Else
M_MoveFlag = True
Exit Sub
End If
Else '向右移
If M_ArrowEnabled Then
If M_EditCol < Ev_GridObj.Cols - 1 Then
M_EditCol = M_EditCol + 1
ElseIf M_EditCol = Ev_GridObj.Cols - 1 Then
If M_EnterNextRow Then
If M_EditRow < Ev_GridObj.Rows - 1 Then
M_EditCol = FixCols
M_EditRow = M_EditRow + 1
Else
M_MoveFlag = True
Exit Sub
End If
End If
Else
M_MoveFlag = True
Exit Sub
End If
Else
M_MoveFlag = True
Exit Sub
End If
End If
Case Is = vbKeyPageUp
If PageEnabled Then
If M_EditRow > FixCols + VisRow Then
M_EditRow = M_EditRow - VisRow
Else
M_EditRow = FixRows
End If
Else
M_MoveFlag = True
Exit Sub
End If
Case Is = vbKeyPageDown
If PageEnabled Then
If M_EditRow < Ev_GridObj.Rows - VisRow Then
M_EditRow = M_EditRow + VisRow
Else
M_EditRow = Ev_GridObj.Rows - 1
End If
Else
M_MoveFlag = True
Exit Sub
End If
Case Is = vbKeyHome
If PageEnabled Then
M_EditRow = FixRows
Else
M_MoveFlag = True
Exit Sub
End If
Case Is = vbKeyEnd
If PageEnabled Then
M_EditRow = Ev_GridObj.Rows - 1
Else
M_MoveFlag = True
Exit Sub
End If
End Select
DoEvents
Call GridMouseDown
If KeyCode = vbKeyRight Then
Ev_Text.SelStart = Len(Ev_Text.Text)
End If
If KeyCode = vbKeyLeft Then
Ev_Text.SelStart = 0
End If
End With
End Sub
Private Sub GridMouseDown()
Dim L As Long, T As Long
Dim W As Long, H As Long
Dim FixRows As Long
Dim FixCols As Long
Dim ValTmp As String
Dim FldName As String
On Error Resume Next
FixRows = Ev_GridObj.FixedRows: FixCols = Ev_GridObj.FixedCols
Ev_GridObj.SetFocus
DoEvents
With Ev_GridObj
If M_MoveFlag Then
M_EditRow = Ev_GridObj.MouseRow
M_EditCol = Ev_GridObj.MouseCol
If Not M_EditFix Then
If M_EditRow <= FixRows - 1 Then
M_EditRow = FixRows
End If
If M_EditCol <= FixCols - 1 Then
M_EditCol = FixCols
End If
End If
End If
Ev_GridObj.Row = M_EditRow: Ev_GridObj.Col = M_EditCol
DoEvents
Ev_Text.Text = .Text
L = .Left + .CellLeft
W = .cellwidth
T = .Top + .CellTop
H = .CellHeight
'/移动编辑框.
Ev_Text.Move L + DltL, T + DltT, W + DltW, H + DltH
Ev_Text.Font.Name = .CellFontName
Ev_Text.ForeColor = .ForeColor
Ev_Text.BackColor = .BackColor
Ev_Text.Font.Size = .Font.Size
Ev_Text.Visible = True
Ev_Text.SetFocus
End With
M_MoveFlag = True
End Sub
'下载本文
