Hi Carlos,
To change something within the VBE at runtime, you could either look up a kb entry I have (that I wrote before I knew about the script control, my second example), you could also look at http://pubs.logicalexpressions.com/P...cle.asp?ID=307 for some details. Just search google for VBA Extensibility. A fun example is one I wrote for someone a couple days ago, that allows you to change the default printer for windows.. paste this entire thing into a blank module, the ChoosePrinter function is the one with extensibility (creates a userform at runtime, then removes it)
'http://www.experts-exchange.com/Applications/MS_Office/Excel/Q_21584553.html
Option Explicit
Private Declare Function SetDefaultPrinter Lib "winspool.drv" Alias "SetDefaultPrinterA" _
(ByVal pszPrinter As String) As Long
Sub ChangePrinters()
Dim PrnNames(), CurPrn As String, NewPrn As String
GetPrinters PrnNames, CurPrn
NewPrn = ChoosePrinter(PrnNames, CurPrn)
If SetPrinter(NewPrn) = True Then
MsgBox "Printer change successful!"
Else
MsgBox "Printer change unsuccessful"
End If
End Sub
Function SetPrinter(ByVal ThePrinter As String) As Boolean
Dim SetPrinterResult As Long
SetPrinterResult = SetDefaultPrinter(ThePrinter)
If SetPrinterResult = 1 Then SetPrinter = True
End Function
Function ChoosePrinter(InputArray() As Variant, ByVal CurrPrn As String) As String
Dim jUF, i As Long, ArrayUB As Long, ChosenPrinter As String, TempArr, OutputArray
Set jUF = ThisWorkbook.VBProject.VBComponents.Add(3)
ArrayUB = UBound(InputArray)
For i = 0 To ArrayUB
With jUF.Designer.Controls.Add("forms.label.1")
.Caption = InputArray(i)
If InputArray(i) = CurrPrn Then
.Caption = .Caption & " (default)"
End If
.Width = 165
.Height = 20
.Top = i * 20 + 5
.Left = 20
.Name = "lab" & I
End With
With jUF.Designer.Controls.Add("forms.optionbutton.1")
.Left = 5
.Top = i * 20 + 5
.Width = 10
.Height = 10
.Name = "ob" & i
.Caption = ""
End With
Next 'I
With jUF
.Properties("Width") = 200
.Properties("Height") = IIf(ArrayUB < 8, (ArrayUB + 1) * 20 + 60, 200)
.Properties("KeepScrollBarsVisible") = 2
.Properties("ScrollBars") = 2
.Properties("Caption") = "Choose Printer"
.Properties("ScrollHeight") = (ArrayUB + 3) * 20
End With
With jUF.Designer.Controls.Add("forms.commandbutton.1")
.Left = 40
.Height = 20
.Top = (ArrayUB + 1) * 20 + 10
.Width = 100
.Caption = "Submit"
End With
jUF.CodeModule.AddFromString "Private Sub CommandButton1_Click()" & vbCrLf & _
" Dim i As Long, ThePrn As String" & vbCrLf & _
" For i = 0 To (Me.Controls.Count - 1) / 2 - 1" & vbCrLf & _
" If Me.Controls(""ob"" & i).Value = True Then" & vbCrLf & _
" ThePrn = Me.Controls(""lab"" & i).Caption" & vbCrLf & " Exit For" & vbCrLf & _
" End If" & vbCrLf & " Next 'i" & vbCrLf & _
" On Error Resume Next" & vbCrLf & " ActiveWorkbook.Names(""asdfasdfasdf7"").Delete" _
& vbCrLf & " Sheets(1).Names.Add ""asdfasdfasdf7"", ""={"""""" & ThePrn & """"""}""" & _
vbCrLf & " On Error GoTo 0" & vbCrLf & " Unload Me" & vbCrLf & "End Sub"
VBA.UserForms.Add(jUF.Name).Show
ThisWorkbook.VBProject.VBComponents.Remove ThisWorkbook.VBProject.VBComponents(jUF.Name)
On Error Resume Next
ChosenPrinter = ActiveWorkbook.Names("asdfasdfasdf7").RefersTo
On Error GoTo 0
If ChosenPrinter <> "" Then
ActiveWorkbook.Names("asdfasdfasdf7").Delete
ChosenPrinter = Mid(ChosenPrinter, InStr(1, ChosenPrinter, "{") + 2)
ChosenPrinter = Left(ChosenPrinter, InStr(1, ChosenPrinter, "}") - 2)
End If
ChoosePrinter = ChosenPrinter
End Function
Function GetPrinters(ByRef PrnNames() As Variant, ByRef CurPrn As String) As Boolean
Dim strComputer As String, objWMIService As Object, colItems As Object
Dim objItem As Object, i As Long
strComputer = "."
Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")
Set colItems = objWMIService.ExecQuery("Select * from Win32_Printer", , 48)
ReDim PrnNames(0)
For Each objItem In colItems
ReDim Preserve PrnNames(i)
PrnNames(i) = objItem.Name
If objItem.Attributes And 4 Then
CurPrn = objItem.Name
End If
i = i + 1
Next
End Function
Of course you can always ask you have any specific questions about it 
As for the second idea, I'll not only give you an example of loading code from a file, but other ways of using script control as well:
'These use late binding for script control, you could also just set a reference
' to "Microsoft Script Control x.x", and dim ScriptCont as ScriptControl
'Uses vbscript language while running, which can throw some people off as it
' is a little different than vba (don't dim a variable 'as type', etc)
Option Explicit
Sub Carlos1()
'just executing a statement, or group of statements. Does not need a subroutine
' or function declaration line
Dim ScriptCont As Object, ASnippetOfCode As String, ANum As Long
ANum = 3
ASnippetOfCode = "i=" & ANum & vbLf & "i=i*2" & vbLf & "msgbox i"
Set ScriptCont = CreateObject("msscriptcontrol.scriptcontrol")
ScriptCont.Language = "VBScript" 'could also be jscript, i think
ScriptCont.ExecuteStatement ASnippetOfCode
Set ScriptCont = Nothing
End Sub
Sub Carlos2()
'takes routine from the internet and runs it
Dim ScriptCont As Object, wSite As String, wSiteText As String
Set ScriptCont = CreateObject("msscriptcontrol.scriptcontrol")
wSite = "http://www.hastalavidas.com/mvidascode.txt"
wSiteText = GetWebie=IEsString(wSite)
ScriptCont.Language = "VBScript"
ScriptCont.AddCode wSiteText
ScriptCont.Run "MsgboxHi"
Set ScriptCont = Nothing
End Sub
Function GetWebIE(ByVal vWebSite As String) As String
Dim IE As InternetExplorer
Set IE = CreateObject("internetexplorer.application")
IE.Navigate2 vWebSite
Do While IE.ReadyState <> 4 'READYSTATE_COMPLETE
DoEvents
Loop
GetWebIE = IE.Document.body.innertext 'could also be .innerhtml
Set IE = Nothing
End Function
Sub Carlos3()
'first creates a text file, then loads that file. this also shows how
' you can use arguments if you wanted to
Dim ScriptCont As ScriptControl, vFF As Long, CodeStr As String, DummyFile As String
Dim SampleNum As Double
DummyFile = "C:\alskfjadpori.txt"
vFF = FreeFile
Open DummyFile For Output As #vFF
Print #vFF, "function SquareANumber(byval ANumber)"
Print #vFF, " squareanumber=anumber ^ 2"
Print #vFF, "end function"
Close #vFF
Open DummyFile For Binary As #vFF
CodeStr = Space$(LOF(vFF))
Get #vFF, , CodeStr
Close #vFF
Set ScriptCont = CreateObject("msscriptcontrol.scriptcontrol")
ScriptCont.Language = "vbscript"
SampleNum = 7
ScriptCont.AddCode CodeStr
MsgBox ScriptCont.Run("squareanumber", SampleNum)
Set ScriptCont = Nothing
Kill DummyFile
End Sub
Again, please let me know if you have any questions about this!
Matt
Reply With Quote
Originally Posted by mvidas
