|
欢迎访问我的博客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 < 255 And 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 < J Then
InsKey = .Item(I).FormulaName
Set TmpFormulaObj = .Item(J)
.Remove J
.Add TmpFormulaObj.FormulaName, TmpFormulaObj.FormulaString, InsKey, , TmpFormulaObj.FormulaName
'For m = 1 To .Count
' Debug.Print .Item(m).FormulaName, .Item(m).FormulaString
'Next
SwFlag = True
Exit For
End If
Else
SwFlag = False
End If
Next
If SwFlag = True Then
Exit For
End If
Next
'SwFlag = False
Loop Until SwFlag = False
FormulaSort = ""
For J = 1 To .Count
FormulaSort = FormulaSort & .Item(J).FormulaName & "=" & .Item(J).FormulaString & vbCrLf
Next
End With
End Function
'表格计算引擎
Sub Calculate()
Dim FOBJS As New MyFormulas, VarName As String, VBCode As String
With FOBJS
For J = 1 To Sheet.Count '将单元格公式存入FOBJS对象
Txt = Sheet(J).Formula
If Txt & Sheet(J).Text <> "" 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”程序运行结果如图。
在text3文本框中显示了上面对应的vbs脚本，其实这个对于开发过程中的调试过程比较有用，但在调试成功之后就可以将其屏蔽删除了。
当然上面的程序还有一定的缺陷，如对于公式循环性的判断，对错误的处理等没有相应的处理代码，本文只是对表格计算功能实现方法进行了简单的研究和介绍，个人要做一个功能比较齐全的电子表格控件是比较困难的，推荐大家还是使用商业的控件比较快捷。
 点击下载源码
欢迎访问我的博客http://dongxingsofthome.blog.hexun.com/8667925_d.html 欢迎访问我的博客http://dongxingsofthome.blog.hexun.com/8667925_d.html |
[复制链接]
发表于 2007-8-8 15:08:00
置顶卡
变色卡
显身卡
楼主