在程序运行时执行外部文本文件中的代码
本程序利用 ScriptControl 对象（以下简称 SC）加载和执行外部代码。
程序运行后，用户可以利用窗口中的文本框输入和编辑外部代码，也可以从文本文件中读入外部代码。
程序运行后，你可以将本文后面的示例外部代码粘贴到文本框，再单击“加载代码”将文本框中的代码加载到代码执行对象（SC）中，然后选择其他按钮查看执行效果：
读出文件：读出外部文件代码到文本框
保存文件：将文本框的内容保存到文本文件中
加载代码：将文本框的代码加载到代码执行对象（SC）中
执行过程：执行下拉列表框中选中的外部代码的一个过程
光标行：执行光标所在行的代码
选中代码：执行选中的代码
终止：终止定时器 Timer1
示例外部代码应用例子：
1.将光标放到文本框“Form1.Picture1.Picture = Form1.Icon”这行上，单击按钮“光标行”，SC 将执行这行代码，执行结果是在 Picture1 中显示图像。
2.在下拉列表框中选中“My1”过程，单击按钮“执行过程”，SC 将执行这个外部过程的所有代码，此过程的主要作用是：调用函数 Fun1 进行加法计算，显示一个消息框，修改窗口标题，修改窗口背景色。
3.在下拉列表框中选中“TimerStart”过程，单击按钮“执行过程”，SC 将启动窗体的定时器 Timer1，通过调用另一个外部过程 MoveKj 演示移动图片的动画。
ScriptControl 对象可以执行的外部代码的语法 VBScript 与 VB 语法绝大部分相同，但要注意：
1.定义变量时，外部代码不需要类型说明， CS 会自动转换,例如：
错误的外部变量定义：Dim ctA As Long,ctL As Integer,ctT As Integer
应改为： dim ctA,ctL,ctT
2.外部代码要访问窗体以及窗体中的控件，不能省略窗体名，也不支持关键字 Me 来代替窗体，因为此关键字指对象自身。
下面两条语句在外部代码中是错误的：
Caption = "新窗口标题"
Picture1.Picture = Me.Icon
应改为；
Form1.Caption = "新窗口标题"
Form1.Picture1.Picture = Form1.Icon
' '以下代码在 VB6 调试通过：
'在窗体添加以下 12 个控件：
' 1 个定时器：Timer1
' 1 个图片框：Picture1
' 1 个下拉列表框：Combo1
' 2 个文本框：Text1，Text2
' 7 个按钮：Command1，Command2，Command3，Command4，Command5，Command6，Command7
'在属性窗口将 Text1 的 MultiLine 属性设置为 True， ScrollBars 属性设置为 3， HideSelection 属性设置为 False。
'其他控件不必设置位置大小等任何属性，全部采用默认设置。
'本人原创，转载请注明来源：http://hi.baidu.com/100bd/blog/item/e03cd0cc26a5185c0eb34565.html
Dim ctChange As Boolean, SC
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Const EM_LineIndex = &HBB
Private Sub Form_Load()
App.Title = "外部代码执行器": Me.Caption = App.Title
Command1.Caption = "读出文件(&R)": Command1.ToolTipText = "读出外部文件代码到文本框"
Command2.Caption = "保存文件(&S)": Command2.ToolTipText = "将文本框的内容保存到文本文件中"
Command3.Caption = "加载代码(&L)": Command3.ToolTipText = "将文本框的代码加载到代码执行对象（SC）中"
Command4.Caption = "执行过程(&D)": Command4.ToolTipText = "执行下拉列表框中选中的过程"
Command5.Caption = "光标行(&G)": Command5.ToolTipText = "执行光标所在行的代码"
Command6.Caption = "选中代码(&X)": Command6.ToolTipText = "执行选中的代码"
Command7.Caption = "终止(&Z)": Command7.ToolTipText = "终止定时器"
Timer1.Enabled = False: Timer1.Interval = 100
Text1.Text = "": Combo1.Text = "": ctChange = False
Text2.Text = App.Path & "\Code-1.txt" '设置默认代码文件
End Sub
Private Sub Form_Activate()
Picture1.ZOrder: Picture1.ToolTipText = Picture1.Name
Picture1.Move Command7.Left + Command7.Width * 1.1, Command7.Top, 390, 390
Command1_Click '将文件读入到文本框 Text1 中，文件名由 Text2 决定
Command3_Click '将 Text1 中的代码加载到 SC
End Sub
Private Sub Form_Resize()
'自动调整控件位置
Dim S As Single, W As Single, H As Single, L As Single, T As Single
S = Me.TextHeight("A")
On Error Resume Next
L = S: T = S: W = Me.ScaleWidth - L * 2
Text2.Move S, S, W, S * 1.5
T = T + S * 2: W = S * 6.5: H = S * 2.5
Command1.Move L, T, W, H
Command2.Move L + W + S * 0.3, T, W, H
Command3.Move L + (W + S * 0.3) * 2, T, W, H
Command4.Move L + (W + S * 0.3) * 3, T, W, H
Command5.Move L + (W + S * 0.3) * 4, T, W, H
Command6.Move L + (W + S * 0.3) * 5, T, W, H
Command7.Move L + (W + S * 0.3) * 6, T, W, H
Command8.Move L + (W + S * 0.3) * 7, T, W, H
T = T + S * 3: W = Me.ScaleWidth - L * 2
Combo1.Move L, T, W
T = T + Combo1.Height + S * 0.5
Text1.Move L, T, W, Me.ScaleHeight - T - S
End Sub
Private Sub Command1_Click()
'将文件读入到文本框 Text1 中，文件名由 Text2 决定
Call ReadSaveF(Text1, Text2.Text)
End Sub
Private Sub Command2_Click()
'将文本框 Text1 的内容保存到文件中，文件名由 Text2 决定
If Not ReadSaveF(Text1, Text2.Text, True) Then Exit Sub
MsgBox "文件保存成功：" & vbCrLf & vbCrLf & Text2.Text, vbInformation
End Sub
Private Sub Command3_Click()
Call LoadCode
End Sub
Private Function LoadCode() As Boolean
'将 Text1 中的代码加载到 SC，成功返回 True
Dim I As Long, nStr As String
On Error GoTo Cuo
Timer1.Enabled = False: Combo1.Clear
DoEvents
Set SC = Nothing
Set SC = CreateObject("ScriptControl")
SC.Language = "VBScript"
SC.AddObject Form1.Name, Form1
If Trim(Text1.Text) = "" Then nStr = "代码为空": GoTo Cuo1
SC.AddCode Text1.Text
For I = 1 To SC.Procedures.Count
Combo1.AddItem SC.Procedures(I).Name
Next
If Combo1.ListCount > 0 Then Combo1.ListIndex = 0
ctChange = False: LoadCode = True
Exit Function
Cuo:
TextSelect SC.Error.Line, SC.Error.Column
nStr = "位置：行 " & SC.Error.Line & " 列 " & SC.Error.Column
nStr = nStr & vbCrLf & "信息：" & SC.Error.Description
Cuo1:
MsgBox "代码有错，无法将代码加载到 SC 对象：" & vbCrLf & vbCrLf & nStr, vbInformation
Combo1.Text = "▲还没有加载的代码"
End Function
Private Sub Text1_Change()
ctChange = True
End Sub
Private Sub TextSelect(nLine As Long, nColumn As Long)
'选中 行 nLine 列 nColumn
Dim S As Long, S1 As Long, nStr As String
S = SendMessage(Text1.hwnd, EM_LineIndex, nLine - 1, ByVal 0&) '第 nLine 行的首字符位置（字节）
nStr = LeftB(StrConv(Text1.Text, vbFromUnicode), S)
dd = StrConv(nStr, vbUnicode)
d1 = Right(dd, 10)
S = Len(StrConv(nStr, vbUnicode)) + nColumn ' - 1
S1 = InStr(S + 1, Text1.Text, vbCrLf)
If S1 = 0 Then S1 = Len(Text1.Text)
Text1.SelStart = S
Text1.SelLength = S1 - S
On Error Resume Next
Text1.SetFocus
End Sub
Private Sub Command4_Click()
RunCode Combo1.Text '执行由 Combo1 选中的代码
End Sub
Private Sub Command4_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Command4.ToolTipText = "执行下拉列表框中选中的外部过程：" & Combo1.Text
End Sub
Private Sub Command7_Click()
Timer1.Enabled = False
End Sub
Private Sub Timer1_Timer()
Dim CodeName As String, I As Long
CodeName = LCase(Timer1.Tag)
For I = 1 To SC.Procedures.Count
If CodeName = LCase(SC.Procedures(I).Name) Then GoTo OK
Next
GoTo Cuo:
OK:
Timer1.Enabled = RunCode(Timer1.Tag)
Exit Sub
Cuo:
MsgBox nStr & "窗体定时器控件 Timer1 无法启动，" & vbCrLf & vbCrLf & "找不到欲执行的外部过程：" & Timer1.Tag, vbInformation
Timer1.Enabled = False
End Sub
Private Sub Command5_Click()
'执行光标所在行的语句
Dim nStr As String, S As Long, S1 As Long, S2 As Long
S = Text1.SelStart
S1 = InStrRev(Text1.Text, vbCrLf, S + 1)
If S1 < 1 Then S1 = 1 Else S1 = S1 + 2
S2 = InStr(S + 1, Text1.Text, vbCrLf)
If S2 = 0 Then S2 = Len(Text1.Text) + 1
nStr = Mid(Text1.Text, S1, S2 - S1)
Text1.SelStart = S1 - 1: Text1.SelLength = S2 - S1
On Error GoTo Cuo
SC.ExecuteStatement nStr
Exit Sub
Cuo:
MsgBox "单独执行当前行的代码出错：" & vbCrLf & vbCrLf & SC.Error.Description, vbInformation
End Sub
Private Sub Command6_Click()
'执行选中的代码
On Error GoTo Cuo
SC.ExecuteStatement Text1.SelText
Exit Sub
Cuo:
MsgBox "单独执行选中代码出错：" & vbCrLf & vbCrLf & SC.Error.Description, vbInformation
End Sub
Private Function RunCode(CodeName As String) As Boolean
Dim nStr As String
If ctChange Then
If vbYes = MsgBox("代码已修改，重新加载代码吗？", vbInformation + vbYesNo, "加载代码") Then
If Not LoadCode() Then Exit Function
End If
End If
On Error GoTo Cuo
SC.Error.Clear
SC.Run CodeName
RunCode = True
Exit Function
Cuo:
TextSelect SC.Error.Line, SC.Error.Column
nStr = "代码执行错误：" & Err.Description
nStr = nStr & vbCrLf & vbCrLf & "位置：行 " & SC.Error.Line & " 列 " & SC.Error.Column
nStr = nStr & vbCrLf & vbCrLf & "过程：" & CodeName
MsgBox nStr & vbCrLf & vbCrLf, vbInformation
End Function
Private Function ReadSaveF(nText As TextBox, F As String, Optional IsSave As Boolean) As Boolean
'读写文件，成功返回 True，否则返回 False
'IsSave=True：将文本框 nText 的内容写入文件。 IsSave=False： 读出文件到文本框 nText
Dim H As Long, b() As Byte, S As Long, nTtr As String
H = FreeFile '获得一个未使用的文件号
On Error GoTo Exit1
If IsSave Then '保存到文件
If Dir(F, 7) <> "" Then SetAttr F, 0: Kill F '删除原来的文件
Open F For Binary As #H '用二进制方式打开一个文件
Put #H, , nText.Text
Close #H
Else '从文件内容读入
S = FileLen(F)
If S < 1 Then ReadSaveF = True: Exit Function
ReDim b(1 To S)
Open F For Binary As #H '用二进制方式打开一个文件
Get #H, , b
Close #H
nText.Text = StrConv(b, vbUnicode) '字符串转变为 vbUnicode 字符
End If
ReadSaveF = True
Exit Function
Exit1:
Close #H
If IsSave Then nStr = "保存文件" Else nStr = "读取文件"
MsgBox nStr & "失败：" & vbCrLf & vbCrLf & F, vbInformation
End Function
以下代码为“示例外部代码”，不是本程序代码，不要复制到程序代码中。程序运行后，可以将下面的“示例外部代码”粘贴到程序界面的文本框中，再单击“加载代码”将文本框中的代码加载到代码执行对象（SC）中，然后选择其他按钮查看执行效果。
' ' '运行时设置代码例子：示例外部代码
Dim ctA, ctL, ctT
Sub My1()
ctA = ctA + Fun1(2, 3) '调用函数 Fun1 计算 2+3
MsgBox "运行时设置代码：ctA = " & ctA, vbInformation, "我的代码"
Form1.Caption = "新窗口标题"
If Form1.BackColor = 255 Then Form1.BackColor = Form1.Command1.BackColor Else Form1.BackColor = 255
End Sub
Sub OpenNotepad
'打开记事本
Dim nShell
Set nShell = CreateObject("WSCript.shell")
nShell.run "notepad.exe"
Set nShell = Nothing
End Sub
Function Fun1(a, b)
Fun1 = a + b
End Function
Sub TimerStart()
'启动窗体的 Timer1 控件，演示移动图片的动画
Form1.Picture1.AutoSize = True
Form1.Picture1.Picture = Form1.Icon '在 Picture1 显示图片
Form1.Timer1.Tag = "MoveKj" '设置窗体的 Timer1 控件调用的外部过程
Form1.Timer1.Enabled = True: Form1.Timer1.Interval = 50
End Sub
Sub TimerEnd()
Form1.Timer1.Enabled = False '终止窗体的 Timer1 控件
End Sub
Sub MoveKj()
'移动图片的动画
Dim Kj
If ctL = 0 Then ctL = 60: ctT = 60
Set Kj = Form1.Picture1
If Kj.Left < 0 Then ctL = Abs(ctL)
If Kj.Left + Kj.Width > Form1.ScaleWidth Then ctL = -Abs(ctL)
If Kj.Top < 0 Then ctT = Abs(ctT)
If Kj.Top + Kj.Height > Form1.ScaleHeight Then ctT = -Abs(ctT)
Kj.Move Kj.Left + ctL, Kj.Top + ctT
End Sub
'本人原创，转载请注明来源：http://hi.baidu.com/100bd/blog/item/e03cd0cc26a5185c0eb34565.html
ScriptControl 对象详细用法，参见：ScriptControl 控件
ScriptControl 使用的语法和和函数，参见： VBScript 语法-函数（ScriptControl 控件）
联系客服
