请教如何做一个像电子表格那样的一个控件

wang_hui · 发表于 2007-8-8 15:08:00

ＶＢ下怎么样做一个你电子表格一样的控件，用来输入数据和显示计算结果？ＶＢ下有一个表格控件不太好用，请精通这方面的人指教！！！

ddx_2002 · 发表于 2007-8-13 21:11:00

欢迎访问我的博客http://dongxingsofthome.blog.hexun.com/8667925_d.html
[原创]在VB中用ScriptControl控件让MSHFlexGrid表格像Excel一样计算
用过Office的朋友都知道Excel的表格是一种具有计算功能的动态表格，这种直观的表格计算功能对于用户来说是相当的人性化了，因此，作为开发者在作一个表格的应用程序时当然十分希望自己的程序能具有这种功能，目前有FORMULA ONE、Spread及OfficeWeb组件等控件可以实现这种功能，有需要使用的朋友可以到网上搜索以下相关资料，很丰富的，因此本人不再对他们做介绍，以下文字将着重介绍如何用MSHFlexGrid和ScriptControl控件来实现这种类Excel的计算表格，由于篇幅有限对于MSHFlexGrid的美化编程不做介绍，大家可参考网上相关资料。
一、控件简介
1、MSHFlexGrid（MSHFlxGrd.ocx)
这种控件允许将文本或者图象放置于每个单元格之中，控件的Row与Col属性允许用户在代码中指定当前行和列，当然也可通过操作鼠标和键盘来改变这两个属性，而text属性指明当前单元格的文本。如果单元格的文本太长而不能完全显示出来的话，可以通过将WordWrap属性设置为true来达到显示的目的。
2、ScriptControl（msscript.ocx）控件来解释执行vbs脚本代码。
二、实现基本思路
用MSHFlexGrid和文本框组合使用作为表格数据输入输出的用户界面，将数据用自定义的表格对象来进行存储，这个对象必须包含单元格的地址、单元格内容、行列数、单元格的公式、单元格的格式化字符串等属性，对单元格公式进行处理形成VBS脚本代码，然后用ScriptControl计算出VBS代码的结果，将计算出的结果写入自定义的表格对象和MSHFlexGrid对应的表格内，至此一次计算完成。
三、程序代码
1、窗体：在窗体上放置一个Frame控件命名为“Frame1”，内部放置一个Text控件命名为“Text1”，放置一个MSHFlexGrid控件命名为“MSHFlexGrid1”，在表格控件内放置一个Text控件命名为“Text2”，在表格下方放置一个Text控件命名为“Text3”，在Text3下方放置一个按钮控件命名为“Command1”。

登录/注册后可看大图

窗体代码：
Dim EditChanged As Boolean, CurrRow As Integer, CurrCol As Integer, EditState As Boolean
Private Sub Command1_Click()
'设置单元格A1的格式为"K0+000.00"
Sheet("A1").FormatString = "K0+000.00": Call Calculate
End Sub
Private Sub Form_Load()
Dim I As Integer, J As Integer
Me.Caption = "模拟Excel计算表格"
CreateTableHead 100 '生成表头
With Text2
      .Appearance = 0
      .Visible = False: EditChanged = False
      .Font.Size = 11
End With
With MSHFlexGrid1
      Frame1.Caption = "单元格" & .TextMatrix(0, 1) & .TextMatrix(1, 0) & "的公式"
      '初始化表格对象
      For J = 1 To .Rows - 1
         For I = 1 To .Cols - 1
                        '单元格地址用A1形式表示,公式,单元格格式,单元格文本,行,列,索引关键字
            Sheet.Add .TextMatrix(0, I) & J, "", "", "", J, I, .TextMatrix(0, I) & J
         Next
      Next
End With

End Sub
Private Sub CreateTableHead(R As Integer)
With MSHFlexGrid1
      .Cols = 20
      .Rows = 20
      .Font.Size = 12
      .AllowUserResizing = flexResizeBoth
      s$ = " |"
      For J = 65 To 90
         s$ = s$ & Chr(J) & "|"
      Next
      s$ = Left(s$, Len(s$) - 1)
      s$ = s$ & ";|"
      For J = 1 To R
         s$ = s$ & J & "|"
      Next
      .FormatString = Left(s$, Len(s$) - 1)
      For J = 1 To 26
         .ColWidth(J) = 1000
      Next
End With
End Sub
Private Sub Label1_Click()
'打开某个网址
'ShellExecute Me.hwnd, "open", "http://dongxingsofthome.blog.hexun.com/", vbNullString, vbNullString, vbNormalFocus
Shell "C:\\Program Files\\Internet Explorer\\IEXPLORE.EXE http://dongxingsofthome.blog.hexun.com/8341928_d.html", vbMaximizedFocus
'给某个信箱发电子邮件
'ShellExecute hWnd, "open", "mailto:sst95@21cn.com", vbNullString, vbNullString, 0
End Sub
Private Sub MSHFlexGrid1_DblClick()
If MSHFlexGrid1.Text  "" Then
      EditState = True
Else
      EditState = False
End If
With MSHFlexGrid1
      Text2.Text = Sheet(.TextMatrix(0, .Col) & .Row).Formula
End With
Text2.Visible = True
With MSHFlexGrid1
      Text2.Top = .CellTop + 2010
      Text2.Left = .CellLeft + 90
      Text2.Height = .CellHeight - 20
      Text2.Width = .CellWidth + 30
      Text2.SetFocus
End With
End Sub
Private Sub MSHFlexGrid1_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 229 Then
      Text2.Text = ""
ElseIf KeyCode  37 And KeyCode  38 And KeyCode  39 And KeyCode  40 Then
      Text2.Text = ""
End If
If KeyCode = 46 Then '处理Delete键
      Text1.Text = ""
      With MSHFlexGrid1
         For J = .Row To .RowSel
            For I = .Col To .ColSel
                  .TextMatrix(J, I) = ""
                  Sheet.Item(.TextMatrix(0, I) & J).Formula = ""
            Next
         Next
      End With
End If
End Sub
Private Sub MSHFlexGrid1_KeyPress(KeyAscii As Integer)
If KeyAscii  27 And KeyAscii  8 Then
      If Chr(KeyAscii) = "=" Then
         Text2.Text = ""
      End If
      Text2.Text = Text2.Text & Chr(KeyAscii)
End If
If KeyAscii = 8 Then 'back
      Text2.Text = ""
End If
If KeyAscii  27 And KeyAscii  13 Then
      Text2.SelStart = Len(Text2.Text)
      Text2.Visible = True
      With MSHFlexGrid1
         Text2.Top = .CellTop + 2010
         Text2.Left = .CellLeft + 90
         Text2.Height = .CellHeight - 20
         Text2.Width = .CellWidth + 30
         Text2.SetFocus
      End With
End If
If KeyAscii = 13 Then
      MSHFlexGrid1.Row = MSHFlexGrid1.Row + 1: EditChanged = False
      With MSHFlexGrid1
         Frame1.Caption = "单元格" & .TextMatrix(0, .Col) & .TextMatrix(.Row, 0) & "的公式"
         Text1.Text = Sheet.Item(MSHFlexGrid1.TextMatrix(0, MSHFlexGrid1.Col) & MSHFlexGrid1.Row).Formula
      End With
End If
End Sub
Private Sub MSHFlexGrid1_RowColChange()
If EditChanged = True Then
      With MSHFlexGrid1
         .TextMatrix(CurrRow, CurrCol) = Text2.Text
         Sheet.Item(.TextMatrix(0, CurrCol) & CurrRow).Formula = Text2.Text
      End With
      Call Calculate
End If
Text2.Visible = False: EditChanged = False
Text1.Text = Sheet.Item(MSHFlexGrid1.TextMatrix(0, MSHFlexGrid1.Col) & MSHFlexGrid1.Row).Formula
End Sub
Private Sub MSHFlexGrid1_SelChange()
With MSHFlexGrid1
      Frame1.Caption = "单元格" & .TextMatrix(0, .Col) & .TextMatrix(.Row, 0) & "的公式"
      '在公式栏内显示单元格的公式
      Text1.Text = Sheet.Item(MSHFlexGrid1.TextMatrix(0, MSHFlexGrid1.Col) & MSHFlexGrid1.Row).Formula
End With
End Sub
Private Sub Text2_Change()
EditChanged = True
CurrRow = MSHFlexGrid1.Row
CurrCol = MSHFlexGrid1.Col
End Sub
Private Sub Text2_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode '处理光标键
      Case 37, 38, 39, 40
         If EditState = False Then
            Call SetCellContent(Text2.Text)
            Text2.Visible = False
            If KeyCode = 40 Then
                  MSHFlexGrid1.Row = MSHFlexGrid1.Row + 1
            ElseIf KeyCode = 37 Then
                  MSHFlexGrid1.Col = MSHFlexGrid1.Col - 1
            ElseIf KeyCode = 39 Then
                  MSHFlexGrid1.Col = MSHFlexGrid1.Col + 1
            ElseIf KeyCode = 38 Then
                  MSHFlexGrid1.Row = MSHFlexGrid1.Row - 1
            End If
         End If
         EditState = False
         MSHFlexGrid1.SetFocus
End Select
End Sub
Private Sub Text2_KeyPress(KeyAscii As Integer)
Select Case KeyAscii
      Case 13 '处理回车键Enter
            Call SetCellContent(Text2.Text)
            Text2.Visible = False
            MSHFlexGrid1.Row = MSHFlexGrid1.Row + 1
            MSHFlexGrid1.SetFocus
            EditState = False
            EditChanged = False
         MSHFlexGrid1.SetFocus
      Case 27 '处理ESC键
         Text2.Visible = False
         MSHFlexGrid1.SetFocus
         EditChanged = False
End Select
End Sub
2、模块：在模块窗口内将下面代码粘贴进去
Public Sheet As New Cells
Function FormulaSort(FOBJ As MyFormulas) As String '对公式代码进行排序
Dim SwFlag As Boolean '发生公式交换的标志
Dim TmpFormulaObj As New MyFormula '存放临时的公式对象，作为交换时使用
Dim InsKey As String
SwFlag = True
With FOBJ
Do
      'SwFlag = False
      If .Count = 0 Then
         Exit Do
      End If
      For J = 1 To .Count
         findstr = .Item(J).FormulaName
            For I = 1 To .Count
                  If InStr(1, .Item(I).FormulaString, findstr, vbTextCompare)  0 Then
                     If I  "" Then
            If IsDate(Txt) Then
                  .Add Sheet(J).Address, "#" & CDate(Sheet(J).Formula) & "#", , , Sheet(J).Address
                  VarName = VarName & Sheet(J).Address & ","
            ElseIf IsNumeric(Txt) Then
                  .Add Sheet(J).Address, Sheet(J).Formula, , , Sheet(J).Address
                  VarName = VarName & Sheet(J).Address & ","
            Else
                  If Left(Sheet(J).Formula, 1) = "=" Then
                     .Add Sheet(J).Address, Right(Sheet(J).Formula, Len(Sheet(J).Formula) - 1), , , Sheet(J).Address
                     VarName = VarName & Sheet(J).Address & ","
                  Else
                     .Add Sheet(J).Address, Chr(34) & Sheet(J).Formula & Chr(34), , , Sheet(J).Address
                     VarName = VarName & Sheet(J).Address & ","
                  End If
            End If
         End If
      Next
End With
'对上面存入的公式进行排序生成最终的源码
VBCode = FormulaSort(FOBJS)
If VBCode = "" Then
      Exit Sub
End If
VBCode = Left(VBCode, Len(VBCode) - 1) & vbCrLf: VarName = Left(VarName, Len(VarName) - 1)
VBCode = "Function SheetResult()" & vbCrLf _
         & "On Error Resume Next" & vbCrLf _
         & VBCode & _
         "SheetResult=Array(" & VarName & ")" & vbCrLf & _
         "End Function"
'将生成的代码，用Script解释器计算并返回计算结果
Form1.Script1.AddCode VBCode
Form1.Text3.Text = VBCode '显示排序后的单元格计算代码
Dim Tmp As Variant, VarNstr As Variant
VarNstr = Split(VarName, ",")
Tmp = Form1.Script1.Run("SheetResult")
'将计算结果返回到单元格中
For J = 1 To FOBJS.Count
      With Form1.MSHFlexGrid1
         If IsDate(Tmp(J - 1)) Or IsNumeric(Tmp(J - 1)) Then '如果是数字和日期则用格式化字符串进行格式化
            ts = Format(Tmp(J - 1), Sheet(VarNstr(J - 1)).FormatString)
            .TextMatrix(Sheet(VarNstr(J - 1)).Row, Sheet(VarNstr(J - 1)).Col) = ts
            Sheet(VarNstr(J - 1)).Text = ts
         Else
            .TextMatrix(Sheet(VarNstr(J - 1)).Row, Sheet(VarNstr(J - 1)).Col) = Tmp(J - 1)
            Sheet(VarNstr(J - 1)).Text = Tmp(J - 1)
         End If
      End With
Next
End Sub
'设定当前单元格和单元格对象的内容，并进行更新计算
Sub SetCellContent(Txt As String)
With Form1.MSHFlexGrid1
      .Text = Txt
      Sheet.Item(.TextMatrix(0, .Col) & .Row).Formula = Txt
End With
Call Calculate
End Sub
3、类模块代码：
（1）新建Cell类模块将下面代码粘贴到类模块中
'保持属性值的局部变量
Private mvarAddress As String '局部复制
Private mvarFormula As String '局部复制
Private mvarFormatString As String '局部复制
Private mvarText As String '局部复制
'保持属性值的局部变量
Private mvarRow As Integer '局部复制
Private mvarCol As Integer '局部复制
Public Property Let Col(ByVal vData As Integer)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Col = 5
mvarCol = vData
End Property

Public Property Get Col() As Integer
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Col
Col = mvarCol
End Property

Public Property Let Row(ByVal vData As Integer)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Row = 5
mvarRow = vData
End Property

Public Property Get Row() As Integer
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Row
Row = mvarRow
End Property

Public Property Let Text(ByVal vData As String)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Text = 5
mvarText = vData
End Property

Public Property Get Text() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Text
Text = mvarText
End Property

Public Property Let FormatString(ByVal vData As String)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.FormatString = 5
mvarFormatString = vData
End Property

Public Property Get FormatString() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.FormatString
FormatString = mvarFormatString
End Property

Public Property Let Formula(ByVal vData As String)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Formula = 5
mvarFormula = vData
End Property

Public Property Get Formula() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Formula
Formula = mvarFormula
End Property

Public Property Let Address(ByVal vData As String)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Address = 5
mvarAddress = vData
End Property

Public Property Get Address() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Address
Address = mvarAddress
End Property
（2）新建Cells类模块将下面代码粘贴到类模块中
'局部变量，保存集合
Private mCol As Collection
'保持属性值的局部变量
Private mvarRows As Integer '局部复制
Private mvarCols As Integer '局部复制
Public Property Let Cols(ByVal vData As Integer)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Cols = 5
mvarCols = vData
End Property

Public Property Get Cols() As Integer
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Cols
Cols = mvarCols
End Property

Public Property Let Rows(ByVal vData As Integer)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Rows = 5
mvarRows = vData
End Property

Public Property Get Rows() As Integer
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Rows
Rows = mvarRows
End Property

Public Function Add(Address As String, Formula As String, FormatString As String, Text As String, Row As Integer, Col As Integer, Optional sKey As String) As Cell
'创建新对象
Dim objNewMember As Cell
Set objNewMember = New Cell

'设置传入方法的属性
objNewMember.Address = Address
objNewMember.Formula = Formula
objNewMember.FormatString = FormatString
objNewMember.Text = Text
objNewMember.Row = Row
objNewMember.Col = Col
If Len(sKey) = 0 Then
      mCol.Add objNewMember
Else
      mCol.Add objNewMember, sKey
End If

'返回已创建的对象
Set Add = objNewMember
Set objNewMember = Nothing

End Function
Public Property Get Item(vntIndexKey As Variant) As Cell
'引用集合中的一个元素时使用。
'vntIndexKey 包含集合的索引或关键字，
'这是为什么要声明为 Variant 的原因
'语法：Set foo = x.Item(xyz) or Set foo = x.Item(5)
  Set Item = mCol(vntIndexKey)
End Property

Public Property Get Count() As Long
'检索集合中的元素数时使用。语法：Debug.Print x.Count
Count = mCol.Count
End Property

Public Sub Remove(vntIndexKey As Variant)
'删除集合中的元素时使用。
'vntIndexKey 包含索引或关键字，这是为什么要声明为 Variant 的原因
'语法：x.Remove(xyz)

mCol.Remove vntIndexKey
End Sub

Public Property Get NewEnum() As IUnknown
'本属性允许用 For...Each 语法枚举该集合。
Set NewEnum = mCol.[_NewEnum]
End Property

Private Sub Class_Initialize()
'创建类后创建集合
Set mCol = New Collection
End Sub

Private Sub Class_Terminate()
'类终止后破坏集合
Set mCol = Nothing
End Sub
（3）新建MyFormula类模块将下面代码粘贴到类模块中
'       ____  ___  ___  ___
'       / \/ \/ \/ \
'  ______\ ____\____\____\____\
'#/ __\\    \ \ \ \#######################################################
'| / \\____/\___/\___/\___/#######################################################
'| | |############################################################################
'#\__\____/############################################################################
'######################################################################################
'######################################################################################
'######################################################################################
'######                                                                         ######
'######                      版本：V1.01                                  ######
'######                      升级信息：2005年1月21日完成修改                ######
'######                      程序编写：董兴                                  ######
'######                      版权所有：董兴                                  ######
'######                      电子邮箱：DongXing@126.COM                      ######
'######                                                                         ######
'######################################################################################
'######################################################################################
'######################################################################################
'######                                                                         ######
'######                声明：本程序让您免费使用，并可自由传播，但对          ######
'######          使用本程序产生的任何后果概不负责。                         ######
'######                                                                         ######
'######################################################################################
'######################################################################################
'######################################################################################
'保持属性值的局部变量
Private mvarFormulaName As String '局部复制
Private mvarFormulaString As String  '局部复制
Public Property Let FormulaString(ByVal vData As String)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Y = 5
mvarFormulaString = vData
End Property

Public Property Get FormulaString() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Y
FormulaString = mvarFormulaString
End Property

Public Property Let FormulaName(ByVal vData As String)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.PName = 5
mvarFormulaName = vData
End Property

Public Property Get FormulaName() As String
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.PName
FormulaName = mvarFormulaName
End Property
（4）新建MyFormulas类模块将下面代码粘贴到类模块中
'       ____  ___  ___  ___
'       / \/ \/ \/ \
'  ______\ ____\____\____\____\
'#/ __\\    \ \ \ \#######################################################
'| / \\____/\___/\___/\___/#######################################################
'| | |############################################################################
'#\__\____/############################################################################
'######################################################################################
'######################################################################################
'######################################################################################
'######                                                                         ######
'######                      版本：V1.01                                  ######
'######                      升级信息：2005年1月21日完成修改                ######
'######                      程序编写：董兴                                  ######
'######                      版权所有：董兴                                  ######
'######                      电子邮箱：DongXing@126.COM                      ######
'######                                                                         ######
'######################################################################################
'######################################################################################
'######################################################################################
'######                                                                         ######
'######                声明：本程序让您免费使用，并可自由传播，但对          ######
'######          使用本程序产生的任何后果概不负责。                         ######
'######                                                                         ######
'######################################################################################
'######################################################################################
'######################################################################################
'局部变量，保存集合
Private mCol As Collection
Public Function Add(FormulaName As String, FormulaString As String, Optional sBefore As String, Optional sAfter As String, Optional sKey As String) As MyFormula
'创建新对象
Dim objNewMember As MyFormula
Set objNewMember = New MyFormula

'设置传入方法的属性
objNewMember.FormulaName = FormulaName
objNewMember.FormulaString = FormulaString
If Len(sKey) = 0 Then
      If Len(sBefore) = 0 And Len(sAfter)  0 Then
         mCol.Add objNewMember, , , sAfter
      ElseIf Len(sBefore)  0 And Len(sAfter) = 0 Then
         mCol.Add objNewMember, , sBefore
      Else
         mCol.Add objNewMember
      End If
Else
      If Len(sBefore) = 0 And Len(sAfter)  0 Then
         mCol.Add objNewMember, sKey, , sAfter
      ElseIf Len(sBefore)  0 And Len(sAfter) = 0 Then
         mCol.Add objNewMember, sKey, sBefore
      Else
         mCol.Add objNewMember, sKey
      End If
End If

'返回已创建的对象
Set Add = objNewMember
Set objNewMember = Nothing
End Function
Public Property Get Item(vntIndexKey As Variant) As MyFormula
'引用集合中的一个元素时使用。
'vntIndexKey 包含集合的索引或关键字，
'这是为什么要声明为 Variant 的原因
'语法：Set foo = x.Item(xyz) or Set foo = x.Item(5)
  Set Item = mCol(vntIndexKey)
End Property

Public Property Get Count() As Long
'检索集合中的元素数时使用。语法：Debug.Print x.Count
Count = mCol.Count
End Property

Public Sub Remove(vntIndexKey As Variant)
'删除集合中的元素时使用。
'vntIndexKey 包含索引或关键字，这是为什么要声明为 Variant 的原因
'语法：x.Remove(xyz)

mCol.Remove vntIndexKey
End Sub

Public Property Get NewEnum() As IUnknown
'本属性允许用 For...Each 语法枚举该集合。
Set NewEnum = mCol.[_NewEnum]
End Property

Private Sub Class_Initialize()
'创建类后创建集合
Set mCol = New Collection
End Sub

Private Sub Class_Terminate()
'类终止后破坏集合
Set mCol = Nothing
End Sub
保存工程并运行测试，在A1单元格中输入“=a2*b2”，A2中输入10，B2中输入150，A4中输入“=a1+3”程序运行结果如图。
[/url][url=http://dongxingsofthome.photo.hexun.com/17565264_d.html]

登录/注册后可看大图

在text3文本框中显示了上面对应的vbs脚本，其实这个对于开发过程中的调试过程比较有用，但在调试成功之后就可以将其屏蔽删除了。
当然上面的程序还有一定的缺陷，如对于公式循环性的判断，对错误的处理等没有相应的处理代码，本文只是对表格计算功能实现方法进行了简单的研究和介绍，个人要做一个功能比较齐全的电子表格控件是比较困难的，推荐大家还是使用商业的控件比较快捷。

登录/注册后可看大图

点击下载源码
欢迎访问我的博客http://dongxingsofthome.blog.hexun.com/8667925_d.html
欢迎访问我的博客http://dongxingsofthome.blog.hexun.com/8667925_d.html