Can VBA create code at run time 6

[crslack]

I am very novice at vba but I use some interpreted languages that allow the programmer to create statements at run time essentially by building a series of strings that comprise executable code then executing them.

Does vba have this sort of dynamic coding option?

 

[xlbo]

VBA can write VBA but it needs to be all held in the code. Should be some examples if you search the archives

Rgds, Geoff
[blue]Si hoc signum legere potes, operis boni in rebus Latinus alacribus et fructuosis potiri potes![/blue]
Want the [red]best[/red] answers to your questions ? faq222-2244

 

[crslack]

I tried a key word search but I can't find anything. Perhaps I am using the wrong key words or can't recognize what is obvious to others. Any suggestions on a search strategy?

 

[TonyJollans]

Hi crslack,

If you are a VBA novice then:

1) You may well not recognise what you want when you find it.

2) You probably shouldn't be trying to do this. Although it is possible to build code and then to run it, it is not straightforward. There is no equivalent of (and this is the only example I can think of quickly) the Rexx Interpret statement. VBA is compiled and not geared up for this kind of thing.

If you have a specific requirement perhaps you could post details of it. There may be another way to do it.

Enjoy,
Tony

------------------------------------------------------------------------------------------------------
We want to help you; help us to do it by reading FAQ222-2244 before you ask a question.

 

[xlbo]

Do a search for vbproject within the Access / MS fora
This thread in particular looks promising:
thread707-87839

The general consensus seems to be that it is best to save a prewritten text file and import it as a module. Other than that, if you really want to build dynamic statements, you can write to a module but it'll be a pain - trust me - I've been trying to do similar within XL but creating SQL strings on the fly - and it's a right pain in the a**

Rgds, Geoff
[blue]Si hoc signum legere potes, operis boni in rebus Latinus alacribus et fructuosis potiri potes![/blue]
Want the [red]best[/red] answers to your questions ? faq222-2244

 

[MichaelRed]

Actually, it didn't seem all THAT difficult or arcane to me. VBA (Code) is just text, so -as long as you know what your want to write & how to write it- it just becomes an exercise it including the snippets of the code in text strings and concatenating them as desired. See [Modules & Lines] in the ubiquitous {F1} (a.k.a. Help). There are even some (rather simplistic) examples.




MichaelRed
m.red@att.net

Searching for employment in all the wrong places

 

[Loomah]

crslack
This link may be of some interest to you

http://www.cpearson.com/excel/vbe.htm

I've never done this so I'm not in a position to comment on how easy or hard it is but the gist seems to be that you need to have the code written somewhere before you can insert it!?

Good Luck
;-)

If a man says something and there are no women there to hear him, is he still wrong?
The faqs ma'am, just the faqs. Get the best from these forums : faq222-2244

 

[crslack]

I am truly a vba novice but I am not a programming novice. I appreciate everyone's good intentions. I did search for modules & lines but nothing looked like it would allow for code creation. One example that produced

activesheet.range("A1&quot = "Hello world"

would be manna from heaven.

 

[gizzy17]

I took this from the link that Loomah provided and modified it to work. First, I had to create a new module so that it already existed when I had it generate the code and two, CodeModule was not a valid type so I changed this to varient. The site also provided code an how to add modules so this could also be done in your code as well if you needed it.

Here is my example (don't forget to create module1 before adding this to one of the sheets).

Sub addProcedure()
Dim vbCodeMod As Variant
Dim lineNum As Long

Set vbCodeMod = ThisWorkbook.VBProject.VBComponents("Module1&quot.CodeModule
With vbCodeMod
lineNum = .CountOfLines + 1
.InsertLines lineNum, _
"Sub MyNewProcedure()" & Chr(13) & _
" activesheet.range(""A1"&quot.value = ""Hello World"" " & Chr(13) & _
"End Sub"
End With

Application.Run "MyNewProcedure"

End Sub

 

[MichaelRed]

gizzy17,

Q.E.D.




MichaelRed
m.red@att.net

Searching for employment in all the wrong places

 

[gizzy17]

Michael Red,

What is Q.E.D.????

Gizzy

 

[xlbo]

Quad Erat Demonstrandum - literally "As has been demonstrated / proven"

Rgds, Geoff
[blue]Si hoc signum legere potes, operis boni in rebus Latinus alacribus et fructuosis potiri potes![/blue]
Want the [red]best[/red] answers to your questions ? faq222-2244

 

[crslack]

Gizzy17,

Thank you very much. This is manna indeed. You should make this a FAQ.

crslack

 

[gizzy17]

crslack,

I think that you should thank Loomah more than me as he is the one that found the link that I used to create the example. I wouldn't have been able to do it otherwise.

 

[crslack]

ps remember to set Tools/Macro/Security/Trusted sources to trust access to Visual Basic project.

Again thanks for this dead-on tip

crslack

 

[Tranman]

crslack,
Here's a vb program I wrote (it's pretty ugly, but I was in a heck of a hurry). Anyway, what it does is creates a new Word document, then adds a module to it, and adds a couple of subs to the module, including one that is run after creation, which inserts a reference to the ADO, and another one that processes commands from click event procedures which it creates in the ThisDocument Module.

The program creates hyperlinks in the document that are used to look up report images in a Filenet system, and command buttons that delete associated rows from an Oracle database.

It's probably way more than you are looking for, but maybe it will give you some idea of some more possibilities.

Tranman

Option Explicit
Public appW As New Word.Application
Public doc As Word.Document
Public lngRBegin As Long
Public lngREnd As Long
Public rng As Range
Public rngAccNo As Range
Public rngBtn As Range
Public strDBName As String
Public strDBYear As String
Public strDocName As String
Public strInFN As String
Public strOutFN As String
Public strWord As String

Private Sub Form_Load()
ParseCmd
OpenFiles
ProcFile
Close
doc.SaveAs strOutFN
appW.Quit
Set appW = Nothing
Set doc = Nothing
Set rng = Nothing
Set rngAccNo = Nothing
Set rngBtn = Nothing
End
End Sub

Private Sub ParseCmd()
Dim intSpPos As Integer
Dim strCmdLine As String
strCmdLine = Command()
'MsgBox strCmdLine, vbOKOnly, "COMMAND LINE"
strCmdLine = Trim(strCmdLine)
If strCmdLine = "" Then Exit Sub
intSpPos = InStr(1, strCmdLine, " ", vbTextCompare)
strInFN = Left(strCmdLine, intSpPos - 1)
strDBName = Mid(strCmdLine, Len(strCmdLine) - intSpPos, 8)
strDBYear = Right(strCmdLine, 4)
End Sub

Private Sub OpenFiles()
strOutFN = Left(strInFN, Len(strInFN) - 3) & "DOC"
Open strInFN For Input As #1
Set doc = appW.Documents.Add
appW.Visible = False
appW.Options.CheckGrammarAsYouType = False
appW.Options.CheckSpellingAsYouType = False
Options.CheckGrammarWithSpelling = False
doc.PageSetup.LeftMargin = 36
doc.PageSetup.RightMargin = 36
doc.PageSetup.TopMargin = 36
doc.PageSetup.BottomMargin = 36
Set rng = doc.Range
rng.Font.Name = "courier new"
rng.Font.Size = 8

End Sub

Private Sub ProcFile()
Dim dblWordStart As Double
Dim intLen As Integer
Dim intResult As Integer
Dim lngLineCtr As Long
Dim rngDel As Range
Dim sCode1 As String
Dim shp1 As Word.InlineShape
Dim strDelSub As String
Dim strRefADO As String
Dim strIn As String
Dim strStop As String
Dim strAddr As String
Dim VBComp As VBComponent

'Add NewMod module to the Word Document
Set VBComp = doc.VBProject.VBComponents.Add(vbext_ct_StdModule)
VBComp.Name = "NewMod"

'Add the delete sub to the Word Document
lngLineCtr = 2
lngLineCtr = lngLineCtr + 1

VBComp.CodeModule.InsertLines lngLineCtr, "Public sub DeleteAcc(strYear As String, strAccNbr As String)" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, "Dim conOR as New ADODB.Connection" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, "Dim conSQL as New ADODB.Connection" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, "Dim intResponse As Integer" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, "Dim lngRecAff As Long" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, "Dim rsOR As New ADODB.Recordset" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, "Dim strFullAccNo As String" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, "Dim strShortAccNo as String" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " intResponse = MsgBox(""Are you certain you wish to delete accident"" & vbNewLine & vbNewLine & "" "" & strYear & strAccNbr & vbNewLine & vbNewLine & "" from KARS and FILENET?"", vbYesNo, ""DELETE ACCIDENT?"&quot"
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " Select Case intResponse"
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " Case vbNo"
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " Exit Sub"
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " End Select"
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " conOR.Open ""Provider=MSDAORA.1;Password=kn0b23;User ID=KARS;Data Source=KARSTEST;Persist Security Info=True""" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " rsOR.Open ""Select ACCIDENT_KEY from ACCIDENTS where ACCIDENT_KEY LIKE '""" & " & strYear & strAccNbr &" & """%'"",conOR,adOpenDynamic,adLockOptimistic" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " Select Case rsOR.EOF" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " Case True" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " MsgBox ""Accident Number "" & strYear & strAccNbr & ""? not found in the KARS Database."", vbOKOnly, ""ACCIDENT NOT FOUND""" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " Case False" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " strFullAccNo = rsOR.Fields(""ACCIDENT_KEY"&quot" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " strShortAccNo = Left(strFullAccNo,11)" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " conOR.Execute ""Delete from ACCIDENTS where ACCIDENT_KEY = '"" & strFullAccNo & ""'""" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " conOR.Execute ""Commit""" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " conSQL.Open ""Provider=SQLOLEDB.1;Password=gad12;Persist Security Info=True;User ID=gaduser;Initial Catalog=Accidents;Data Source=DT00MH25""" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " conSQL.Execute ""Update V_FN_ACCIDENTS Set DEL_DUP = 1 Where ACCIDENT_ID = '"" & strShortAccNo & ""'"", lngRecAff" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " conSQL.Close" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " Set conSQL = Nothing" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " Select Case lngRecAff"
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " Case 0"
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " Application.Selection.InlineShapes(1).Delete"
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " Application.Selection.InsertAfter ""NO IMAGE """
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " Application.ScreenRefresh"
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " Case Else"
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " Application.Selection.InlineShapes(1).Delete"
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " Application.Selection.InsertAfter ""DELETED """
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " Application.ScreenRefresh"
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " End Select"
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " End Select" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " rsOR.Close" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " conOR.Close" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " Set rsOR = nothing" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, " Set conOR = nothing" & vbCrLf
lngLineCtr = lngLineCtr + 1
VBComp.CodeModule.InsertLines lngLineCtr, "End sub"

'Add a sub to add ADO reference to the NewMod Module
strRefADO = "Public Sub AddRef()" & vbCrLf & _
"Dim doc As Document" & vbCrLf & _
" Set doc = ActiveDocument" & vbCrLf & _
" doc.VBProject.References.AddFromFile ""C:\PROGRAM FILES\COMMON FILES\SYSTEM\ADO\MSADO15.DLL""" & vbCrLf & _
" Set doc = Nothing" & vbCrLf & _
"End Sub"
VBComp.CodeModule.AddFromString strRefADO
'Run the AddRef Sub to add ADO reference to the Word Application
appW.Run "AddRef"

'Bypass (FF) at start of file
Line Input #1, strIn

Do While Not EOF(1)
Line Input #1, strIn
intLen = Len(strIn)
strIn = Replace(strIn, Chr(13), "&quot
strIn = Replace(strIn, Chr(10), "&quot
Select Case Left(strIn, 2)
Case "D1"
'Add the row of information and the <cr>
rng.InsertAfter Chr(13)
rng.InsertAfter &quot; &quot; & Right(strIn, Len(strIn) - 2)
rng.InsertAfter Chr(13)

'Delete 10 characters (spaces) from the area after the Accident Number
Set rngDel = appW.ActiveDocument.Sentences.Last.Words(7)
rngDel.Start = rngDel.Start + 10
rngDel.End = rngDel.Start
rngDel.Delete wdCharacter, 10

'Add the delete button (must be done BEFORE the hyperlink)
strWord = Trim(appW.ActiveDocument.Sentences.Last.Words(7).Text)
Set rngBtn = appW.ActiveDocument.Sentences.Last.Words(7)
dblWordStart = rngBtn.Start + 10
rngBtn.Start = dblWordStart
rngBtn.End = rngBtn.Start
Set shp1 = doc.Content.InlineShapes.AddOLEControl(ClassType:=&quot;forms.commandbutton.1&quot;, Range:=rngBtn)
shp1.OLEFormat.Object.Caption = &quot;Delete&quot;
shp1.Height = 7
shp1.Width = 47
shp1.AlternativeText = strWord

'Convert the Accident Number into a hyperlink
strWord = Trim(appW.ActiveDocument.Sentences.Last.Words(7).Text)
intLen = Len(Trim(strWord))
dblWordStart = appW.ActiveDocument.Sentences.Last.Words(7).Start
Set rngAccNo = appW.ActiveDocument.Sentences.Last.Words(7)
rngAccNo.End = dblWordStart + intLen
strAddr = SetupAddr(Left(strWord, 7))
doc.Hyperlinks.Add rngAccNo, strAddr

'Add a procedure for the click event of the inlineshape for D1 record
'**Note: The click event resides in the This Document module
strWord = Left(strWord, 7)
sCode1 = &quot;Private Sub &quot; & shp1.OLEFormat.Object.Name & &quot;_Click()&quot; & vbCrLf & _
&quot; CONST strAccNo = &quot;&quot;&quot; & strWord & &quot;&quot;&quot;&quot; & vbCrLf & _
&quot; CONST strYear = &quot;&quot;&quot; & strDBYear & &quot;&quot;&quot;&quot; & vbCrLf & _
&quot; Call DeleteAcc(strYear, strAccNo)&quot; & vbCrLf & _
&quot;End Sub&quot;
doc.VBProject.VBComponents(&quot;ThisDocument&quot.CodeModule.AddFromString sCode1

Case &quot;D2&quot;
'Add the row of information and the <cr>
rng.InsertAfter &quot; &quot; & Right(strIn, Len(strIn) - 2)
rng.InsertAfter Chr(13)

'Delete 10 characters (spaces) from the area after the Accident Number
Set rngDel = appW.ActiveDocument.Sentences.Last.Words(6)
rngDel.Start = rngDel.Start + 10
rngDel.End = rngDel.Start
rngDel.Delete wdCharacter, 10

'Add the delete button (must be done BEFORE the hyperlink)
strWord = Trim(appW.ActiveDocument.Sentences.Last.Words(6).Text)
Set rngBtn = appW.ActiveDocument.Sentences.Last.Words(6)
dblWordStart = rngBtn.Start + 10
rngBtn.Start = dblWordStart
rngBtn.End = rngBtn.Start
Set shp1 = doc.Content.InlineShapes.AddOLEControl(ClassType:=&quot;forms.commandbutton.1&quot;, Range:=rngBtn)
shp1.OLEFormat.Object.Caption = &quot;TestDelete&quot;
shp1.Height = 7
shp1.Width = 47
shp1.AlternativeText = strWord

'Convert the Accident Number into a hyperlink
strWord = appW.ActiveDocument.Sentences.Last.Words(6).Text
intLen = Len(Trim(strWord))
dblWordStart = appW.ActiveDocument.Sentences.Last.Words(6).Start
Set rngAccNo = appW.ActiveDocument.Sentences.Last.Words(6)
rngAccNo.End = dblWordStart + intLen
strAddr = SetupAddr(Left(strWord, 7))
doc.Hyperlinks.Add rngAccNo, strAddr

'Add a procedure for the click event of the inlineshape for D2 record
'**Note: The click event resides in the This Document module
strWord = Left(strWord, 7)
sCode1 = &quot;Private Sub &quot; & shp1.OLEFormat.Object.Name & &quot;_Click()&quot; & vbCrLf & _
&quot; CONST strAccNo = &quot;&quot;&quot; & strWord & &quot;&quot;&quot;&quot; & vbCrLf & _
&quot; CONST strYear = &quot;&quot;&quot; & strDBYear & &quot;&quot;&quot;&quot; & vbCrLf & _
&quot; Call DeleteAcc(strYear, strAccNo)&quot; & vbCrLf & _
&quot;End Sub&quot;
doc.VBProject.VBComponents(&quot;ThisDocument&quot.CodeModule.AddFromString sCode1

Case &quot;E &quot;
'E record gets hyperlink only because it was not added to the database due
'to constraint violation
rng.InsertAfter Chr(13)
rng.InsertAfter &quot; &quot; & Right(strIn, Len(strIn) - 2)
rng.InsertAfter Chr(13)
strWord = appW.ActiveDocument.Sentences.Last.Words(2).Text
intLen = Len(Trim(strWord))
dblWordStart = appW.ActiveDocument.Sentences.Last.Words(2).Start
Set rngAccNo = appW.ActiveDocument.Sentences.Last.Words(2)
rngAccNo.End = dblWordStart + intLen
strAddr = SetupAddr(Left(strWord, 7))
appW.ActiveDocument.Hyperlinks.Add rngAccNo, strAddr
Case Else
rng.InsertAfter strIn
rng.InsertAfter Chr(13)
End Select
Loop
Set rngDel = Nothing
Set shp1 = Nothing
Set VBComp = Nothing
End Sub

Private Function SetupAddr(FNAccNo As String) As String
Dim con As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim strLibId As String
Dim strSQL As String
Dim strPath As String
con.Open &quot;Provider=SQLOLEDB.1;Password=gad12;Persist Security Info=True;User ID=gaduser;Initial Catalog=Accidents;Data Source=DT00MH25&quot;
strSQL = &quot;Select LIB_ID FROM V_FN_ACCIDENTS WHERE ACCIDENT_ID = '&quot; & strDBYear & FNAccNo & &quot;'&quot;
rs.Open strSQL, con, adOpenDynamic, adLockOptimistic
strPath = &quot;

http://dmsweb01.ksdot.org/idmws/doccontent.dll?library=accidents^dt00mh25&id=&quot;

strPath = strPath & rs.Fields(&quot;LIB_ID&quot

SetupAddr = strPath
rs.Close
con.Close
Set con = Nothing
Set rs = Nothing

End Function