|
在程序運(yùn)行時(shí)執(zhí)行外部文本文件中的代碼 本程序利用 ScriptControl 對(duì)象（以下簡(jiǎn)稱 SC）加載和執(zhí)行外部代碼。
程序運(yùn)行后，用戶可以利用窗口中的文本框輸入和編輯外部代碼，也可以從文本文件中讀入外部代碼。 
程序運(yùn)行后，你可以將本文后面的示例外部代碼粘貼到文本框，再單擊“加載代碼”將文本框中的代碼加載到代碼執(zhí)行對(duì)象（SC）中，然后選擇其他按鈕查看執(zhí)行效果：
讀出文件：讀出外部文件代碼到文本框
保存文件：將文本框的內(nèi)容保存到文本文件中
加載代碼：將文本框的代碼加載到代碼執(zhí)行對(duì)象（SC）中
執(zhí)行過(guò)程：執(zhí)行下拉列表框中選中的外部代碼的一個(gè)過(guò)程
光標(biāo)行：執(zhí)行光標(biāo)所在行的代碼
選中代碼：執(zhí)行選中的代碼
終止：終止定時(shí)器 Timer1
示例外部代碼應(yīng)用例子：
1.將光標(biāo)放到文本框“Form1.Picture1.Picture = Form1.Icon”這行上，單擊按鈕“光標(biāo)行”，SC 將執(zhí)行這行代碼，執(zhí)行結(jié)果是在 Picture1 中顯示圖像。
2.在下拉列表框中選中“My1”過(guò)程，單擊按鈕“執(zhí)行過(guò)程”，SC 將執(zhí)行這個(gè)外部過(guò)程的所有代碼，此過(guò)程的主要作用是：調(diào)用函數(shù) Fun1 進(jìn)行加法計(jì)算，顯示一個(gè)消息框，修改窗口標(biāo)題，修改窗口背景色。
3.在下拉列表框中選中“TimerStart”過(guò)程，單擊按鈕“執(zhí)行過(guò)程”，SC 將啟動(dòng)窗體的定時(shí)器 Timer1，通過(guò)調(diào)用另一個(gè)外部過(guò)程 MoveKj 演示移動(dòng)圖片的動(dòng)畫(huà)。
ScriptControl 對(duì)象可以執(zhí)行的外部代碼的語(yǔ)法 VBScript 與 VB 語(yǔ)法絕大部分相同，但要注意：
1.定義變量時(shí)，外部代碼不需要類型說(shuō)明， CS 會(huì)自動(dòng)轉(zhuǎn)換,例如：
錯(cuò)誤的外部變量定義：Dim ctA As Long,ctL As Integer,ctT As Integer
應(yīng)改為： dim ctA,ctL,ctT
2.外部代碼要訪問(wèn)窗體以及窗體中的控件，不能省略窗體名，也不支持關(guān)鍵字 Me 來(lái)代替窗體，因?yàn)榇岁P(guān)鍵字指對(duì)象自身。
下面兩條語(yǔ)句在外部代碼中是錯(cuò)誤的：
Caption = "新窗口標(biāo)題"
Picture1.Picture = Me.Icon
應(yīng)改為；
Form1.Caption = "新窗口標(biāo)題"
Form1.Picture1.Picture = Form1.Icon
' '以下代碼在 VB6 調(diào)試通過(guò)：
'在窗體添加以下 12 個(gè)控件：
' 1 個(gè)定時(shí)器：Timer1
' 1 個(gè)圖片框：Picture1
' 1 個(gè)下拉列表框：Combo1
' 2 個(gè)文本框：Text1，Text2
' 7 個(gè)按鈕：Command1，Command2，Command3，Command4，Command5，Command6，Command7
'在屬性窗口將 Text1 的 MultiLine 屬性設(shè)置為 True， ScrollBars 屬性設(shè)置為 3， HideSelection 屬性設(shè)置為 False。
'其他控件不必設(shè)置位置大小等任何屬性，全部采用默認(rèn)設(shè)置。
'本人原創(chuàng)，轉(zhuǎn)載請(qǐng)注明來(lái)源：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 = "外部代碼執(zhí)行器": Me.Caption = App.Title
Command1.Caption = "讀出文件(&R)": Command1.ToolTipText = "讀出外部文件代碼到文本框"
Command2.Caption = "保存文件(&S)": Command2.ToolTipText = "將文本框的內(nèi)容保存到文本文件中"
Command3.Caption = "加載代碼(&L)": Command3.ToolTipText = "將文本框的代碼加載到代碼執(zhí)行對(duì)象（SC）中"
Command4.Caption = "執(zhí)行過(guò)程(&D)": Command4.ToolTipText = "執(zhí)行下拉列表框中選中的過(guò)程"
Command5.Caption = "光標(biāo)行(&G)": Command5.ToolTipText = "執(zhí)行光標(biāo)所在行的代碼"
Command6.Caption = "選中代碼(&X)": Command6.ToolTipText = "執(zhí)行選中的代碼"
Command7.Caption = "終止(&Z)": Command7.ToolTipText = "終止定時(shí)器"
Timer1.Enabled = False: Timer1.Interval = 100
Text1.Text = "": Combo1.Text = "": ctChange = False
Text2.Text = App.Path & "\Code-1.txt" '設(shè)置默認(rèn)代碼文件
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()
'自動(dòng)調(diào)整控件位置
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 的內(nèi)容保存到文件中，文件名由 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 "代碼有錯(cuò)，無(wú)法將代碼加載到 SC 對(duì)象：" & vbCrLf & vbCrLf & nStr, vbInformation
Combo1.Text = "▲還沒(méi)有加載的代碼"
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 行的首字符位置（字節(jié)）
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 '執(zhí)行由 Combo1 選中的代碼
End Sub
Private Sub Command4_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Command4.ToolTipText = "執(zhí)行下拉列表框中選中的外部過(guò)程：" & 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 & "窗體定時(shí)器控件 Timer1 無(wú)法啟動(dòng)，" & vbCrLf & vbCrLf & "找不到欲執(zhí)行的外部過(guò)程：" & Timer1.Tag, vbInformation
Timer1.Enabled = False
End Sub
Private Sub Command5_Click()
'執(zhí)行光標(biāo)所在行的語(yǔ)句
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 "單獨(dú)執(zhí)行當(dāng)前行的代碼出錯(cuò)：" & vbCrLf & vbCrLf & SC.Error.Description, vbInformation
End Sub
Private Sub Command6_Click()
'執(zhí)行選中的代碼
On Error GoTo Cuo
SC.ExecuteStatement Text1.SelText
Exit Sub
Cuo:
MsgBox "單獨(dú)執(zhí)行選中代碼出錯(cuò)：" & 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 = "代碼執(zhí)行錯(cuò)誤：" & Err.Description
nStr = nStr & vbCrLf & vbCrLf & "位置：行 " & SC.Error.Line & " 列 " & SC.Error.Column
nStr = nStr & vbCrLf & vbCrLf & "過(guò)程：" & CodeName
MsgBox nStr & vbCrLf & vbCrLf, vbInformation
End Function
Private Function ReadSaveF(nText As TextBox, F As String, Optional IsSave As Boolean) As Boolean
'讀寫(xiě)文件，成功返回 True，否則返回 False
'IsSave=True：將文本框 nText 的內(nèi)容寫(xiě)入文件。 IsSave=False： 讀出文件到文本框 nText
Dim H As Long, b() As Byte, S As Long, nTtr As String
H = FreeFile '獲得一個(gè)未使用的文件號(hào)
On Error GoTo Exit1
If IsSave Then '保存到文件
If Dir(F, 7) <> "" Then SetAttr F, 0: Kill F '刪除原來(lái)的文件
Open F For Binary As #H '用二進(jìn)制方式打開(kāi)一個(gè)文件
Put #H, , nText.Text
Close #H
Else '從文件內(nèi)容讀入
S = FileLen(F)
If S < 1 Then ReadSaveF = True: Exit Function
ReDim b(1 To S)
Open F For Binary As #H '用二進(jìn)制方式打開(kāi)一個(gè)文件
Get #H, , b
Close #H
nText.Text = StrConv(b, vbUnicode) '字符串轉(zhuǎn)變?yōu)?vbUnicode 字符
End If
ReadSaveF = True
Exit Function
Exit1:
Close #H
If IsSave Then nStr = "保存文件" Else nStr = "讀取文件"
MsgBox nStr & "失?。? & vbCrLf & vbCrLf & F, vbInformation
End Function
以下代碼為“示例外部代碼”，不是本程序代碼，不要復(fù)制到程序代碼中。程序運(yùn)行后，可以將下面的“示例外部代碼”粘貼到程序界面的文本框中，再單擊“加載代碼”將文本框中的代碼加載到代碼執(zhí)行對(duì)象（SC）中，然后選擇其他按鈕查看執(zhí)行效果。
' ' '運(yùn)行時(shí)設(shè)置代碼例子：示例外部代碼
Dim ctA, ctL, ctT
Sub My1()
ctA = ctA + Fun1(2, 3) '調(diào)用函數(shù) Fun1 計(jì)算 2+3
MsgBox "運(yùn)行時(shí)設(shè)置代碼：ctA = " & ctA, vbInformation, "我的代碼"
Form1.Caption = "新窗口標(biāo)題"
If Form1.BackColor = 255 Then Form1.BackColor = Form1.Command1.BackColor Else Form1.BackColor = 255
End Sub
Sub OpenNotepad
'打開(kāi)記事本
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()
'啟動(dòng)窗體的 Timer1 控件，演示移動(dòng)圖片的動(dòng)畫(huà)
Form1.Picture1.AutoSize = True
Form1.Picture1.Picture = Form1.Icon '在 Picture1 顯示圖片
Form1.Timer1.Tag = "MoveKj" '設(shè)置窗體的 Timer1 控件調(diào)用的外部過(guò)程
Form1.Timer1.Enabled = True: Form1.Timer1.Interval = 50
End Sub
Sub TimerEnd()
Form1.Timer1.Enabled = False '終止窗體的 Timer1 控件
End Sub
Sub MoveKj()
'移動(dòng)圖片的動(dòng)畫(huà)
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 '本人原創(chuàng)，轉(zhuǎn)載請(qǐng)注明來(lái)源：http://hi.baidu.com/100bd/blog/item/e03cd0cc26a5185c0eb34565.html ScriptControl 對(duì)象詳細(xì)用法，參見(jiàn)：ScriptControl 控件
ScriptControl 使用的語(yǔ)法和和函數(shù)，參見(jiàn)： VBScript 語(yǔ)法-函數(shù)（ScriptControl 控件）
|
