I have a form myForm with a text box myText.
In the onLoad function, I have written code that is supposed to append all the rows from a recordset, a database's lockfile, into the myText text box.
What actually happens is, only the first field of four fields is appended into the textbox.
Dim cn As New ADODB.Connection
Dim cn2 As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim i, j As Long
cn.Provider = "Microsoft.Jet.OLEDB.4.0"
cn.Open "Data Source=Z:\myDatabase.mdb"
cn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;" _
& "Data Source=Z:\myDatabase.mdb"
Set rs = cn.OpenSchema(adSchemaProviderSpecific, , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
Me.myText.SetFocus
Me.myText.text = ""
Do While Not rs.EOF
Me.myText.text = Me.myText.text & rs.Fields(0) & vbTab & rs.Fields(1) & vbTab & _
rs.Fields(2) & vbTab & rs.Fields(3) & vbCrLf
rs.MoveNext
Loop
I tried
Debug.Print rs.Fields(0) & vbTab & rs.Fields(1) & vbTab & rs.Fields(2) & vbTab & rs.Fields(3)
and all four fields showed in the immediate window.
EDIT:
I took out the vbtab, since it's not supported and the file itself already has spaces, and I changed Me.myText.text in
Me.myText.text = Me.myText.text & rs.Fields(0) & rs.Fields(1) & _
rs.Fields(2) & rs.Fields(3) & vbCrLf
to Me.myText.
Now my code seems to work in the beginning. When I debug step by step the text box fills like it's supposed to, but when Code exits the do while loop, only the first field of the first row shows in the text box.
debug.print Me.myText before exiting the loop shows all the rows. After exiting the loop still shows all the rows. But in the form, the textbox is only showing the first record, first field.
The form and the textbox both do not have any events other than this event, which is on the forms load.
What is wrong?
Use the property .Value (which is the default property for textbox) , not .Text
so Me.myText.Text ==> Me.myText.Value or Me.myText
The textbox support multi line with vbCrLf.
tab with vbTab is not supported
define myvbTab= " " as a tab separator instead of vbTab
Modify the following fragment of your code:
myvbTab= " "
dim row_data
Do While Not rs.EOF
row_data = rs.Fields(0) & myvbTab& rs.Fields(1) & _
myvbTab & rs.Fields(2) & myvbTab& rs.Fields(3) & vbCrLf
Me.myText= Me.myText & row_data
' be sure that data is displayed, to know if control characters in row_data
Debug.Print row_data
rs.MoveNext
Loop
Edit:
To isolate the problem can you run that code:(independent of reading recordset)
Me.myText.Value = "start "
Dim tabChar As String
tabChar = Chr(9) '" "
Me.myText = Me.myText & "one" & tabChar & "two" & vbCrLf
Me.myText = Me.myText & "three" & tabChar & "four" & vbCrLf
it should display
start one two
three four
I'm writing this script to help with logging when my workplace re-images computers. The problem is that I am somewhat inexperienced with VBS and troubleshooting VBS scripts.
This script is built to take in an argument and log the section indicated by the argument. Ex: Someone passes in /1 and then the script logs section 1.
Here is the full script(with some elements redacted).
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set WshShell = WScript.CreateObject("WScript.Shell")
Set objNetwork = CreateObject("WScript.Network")
Dim strDriveLetter, strRemotePath, strusername, strpassword, strRemoteNewPath
WScript.sleep 5000
Dim iRetVal
Dim sCmd
Dim begImg, begDrivers, begAppInstalls, finalCheck, finalConfig, complete
set begImg = WScript.Arguments
set begDrivers = WScript.Arguments
set begAppInstalls = WScript.Arguments
set finalCheck = WScript.Arguments
set finalConfig = WScript.Arguments
set complete = WScript.Arguments
'my solution
set sequence = Wscript.Arguments
sCmd = "Net use L: /del"
iRetVal = WshShell.Run(sCmd, 0, true)
strDriveLetter = "L:"
strRemotePath = "\\FileServ1\LogShare"
strRemoteNewPath = "\\FileServ1\LogShare"
strusername = "domain\admin"
strpassword = "password"
objNetwork.MapNetworkDrive strDriveLetter, strRemotePath, , strusername, strpassword
'|------------------------------------|
'| Get Serial Number |
'| Variable objSN = Machine Serial # |
'|------------------------------------|
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colBIOS = objWMIService.ExecQuery _
("Select * from Win32_BIOS")
For each objBIOS in colBIOS
objSN = objBIOS.SerialNumber
Next
' This appears to be the first part 1
'|--------------------------------------|
'| Create Text File with Machine S/N |
'|--------------------------------------|
'8 is ForAppending
If sequence = 1 Then
Set trs = objFSO.OpenTextFile(strDriveLetter & "\" & objSN & ".txt", 8, True)
trs.WriteLine ""
trs.WriteLine "*************************************************************************"
trs.WriteLine(Now & " BEGINNING IMAGING SESSION ON: " & objSN)
trs.WriteLine(Now & " mapped " & strRemotePath & " as " & strDriveLetter)
trs.WriteLine(Now & " Beginning to apply image...")
trs.WriteLine ""
End If
If Err.Number <> 0 Then
trs.WriteLine("<<<<<<<<<<<<<<<<<<<<<----------ERROR---------->>>>>>>>>>>>>>>>>>>>>")
trs.WriteLine(Now & ": Error: " & Err.Number )
trs.WriteLine(Now & ": Error (Hex): " & Hex(Err.Number ))
trs.WriteLine(Now & ": Source: " & Err.Source )
trs.WriteLine(Now & ": Description: " & Err.Description )
Err.Clear
trs.WriteLine("<<<<<<<<<<<<<<<<<<<<<----------ERROR---------->>>>>>>>>>>>>>>>>>>>>")
End If
' Part 2
'|--------------------------------------|
'| BEGIN DRIVER AND WINDOWS UPDATES |
'|--------------------------------------|
If sequence = 2 Then
trs.WriteLine(Now & " IMAGE APPLIED; BEGINNING DRIVERS AND WINDOWS UPDATES...")
trs.WriteLine ""
End If
If Err.Number <> 0 Then
trs.WriteLine("<<<<<<<<<<<<<<<<<<<<<----------ERROR---------->>>>>>>>>>>>>>>>>>>>>")
trs.WriteLine(Now & ": Error: " & Err.Number )
trs.WriteLine(Now & ": Error (Hex): " & Hex(Err.Number ))
trs.WriteLine(Now & ": Source: " & Err.Source )
trs.WriteLine(Now & ": Description: " & Err.Description )
Err.Clear
trs.WriteLine("<<<<<<<<<<<<<<<<<<<<<----------ERROR---------->>>>>>>>>>>>>>>>>>>>>")
End If
'Part 3
'|----------------------------------------------------------|
'| APPLY UPDATES AND DRIVERS, GO TO APPLICATION INSTALLS |
'|----------------------------------------------------------|
If sequence = 3 Then
trs.WriteLine(Now & " INITIAL UPDATES AND DRIVERS APPLIED; PROCEEDING TO APPLICATION INSTALLS...")
End If
If Err.Number <> 0 Then
trs.WriteLine("<<<<<<<<<<<<<<<<<<<<<----------ERROR---------->>>>>>>>>>>>>>>>>>>>>")
trs.WriteLine(Now & ": Error: " & Err.Number )
trs.WriteLine(Now & ": Error (Hex): " & Hex(Err.Number ))
trs.WriteLine(Now & ": Source: " & Err.Source )
trs.WriteLine(Now & ": Description: " & Err.Description )
Err.Clear
trs.WriteLine("<<<<<<<<<<<<<<<<<<<<<----------ERROR---------->>>>>>>>>>>>>>>>>>>>>")
End If
'Part 4
'|--------------------------------------|
'| STARTING FINAL CHECKS |
'|--------------------------------------|
If sequence = 4 Then
trs.WriteLine(Now & " APPLICATIONS COMPLETE; STARTING FINAL CHECK FOR UPDATES...")
trs.WriteLine ""
End If
If Err.Number <> 0 Then
trs.WriteLine("<<<<<<<<<<<<<<<<<<<<<----------ERROR---------->>>>>>>>>>>>>>>>>>>>>")
trs.WriteLine(Now & ": Error: " & Err.Number )
trs.WriteLine(Now & ": Error (Hex): " & Hex(Err.Number ))
trs.WriteLine(Now & ": Source: " & Err.Source )
trs.WriteLine(Now & ": Description: " & Err.Description )
Err.Clear
trs.WriteLine("<<<<<<<<<<<<<<<<<<<<<----------ERROR---------->>>>>>>>>>>>>>>>>>>>>")
End If
'Part 5
'|--------------------------------------|
'| FINAL CONFIGURATIONS |
'|--------------------------------------|
'8 is ForAppending
'Set trs = objFSO.OpenTextFile(strDriveLetter & "\" & objSN & ".txt", 8, True) - I might need to delete this to make sure its on the same txt file
If sequence = 5 Then
trs.WriteLine(Now & " UPDATES COMPLETE; PROCEEDING TO FINAL CONFIGURATIONS...")
trs.WriteLine ""
End If
If Err.Number <> 0 Then
trs.WriteLine("<<<<<<<<<<<<<<<<<<<<<----------ERROR---------->>>>>>>>>>>>>>>>>>>>>")
trs.WriteLine(Now & ": Error: " & Err.Number )
trs.WriteLine(Now & ": Error (Hex): " & Hex(Err.Number ))
trs.WriteLine(Now & ": Source: " & Err.Source )
trs.WriteLine(Now & ": Description: " & Err.Description )
Err.Clear
trs.WriteLine("<<<<<<<<<<<<<<<<<<<<<----------ERROR---------->>>>>>>>>>>>>>>>>>>>>")
End If
'Part 6
'this should be the final part
'|--------------------------------------|
'| IMAGING SESSION COMPLETE |
'|--------------------------------------|
If sequence = 6 Then
trs.WriteLine(Now & " FINAL CONFIGURATION COMPLETE; IMAGING SESSION COMPLETE...")
trs.WriteLine "*************************************************************************"
'Use netbeans to remove the following 4 spaces if necessary
trs.WriteLine ""
trs.WriteLine ""
trs.WriteLine ""
trs.WriteLine ""
End If
If Err.Number <> 0 Then
trs.WriteLine("<<<<<<<<<<<<<<<<<<<<<----------ERROR---------->>>>>>>>>>>>>>>>>>>>>")
trs.WriteLine(Now & ": Error: " & Err.Number )
trs.WriteLine(Now & ": Error (Hex): " & Hex(Err.Number ))
trs.WriteLine(Now & ": Source: " & Err.Source )
trs.WriteLine(Now & ": Description: " & Err.Description )
Err.Clear
trs.WriteLine("<<<<<<<<<<<<<<<<<<<<<----------ERROR---------->>>>>>>>>>>>>>>>>>>>>")
End If
trs.close
wscript.quit
Here is my input: cscript OneScriptRuleThemAll.vbs /1
Here is the output and error message: OneScriptToRuleThemAll.vbs(55, 1) Microsoft VBScript runtime error: Wrong number of arguments or invalid property assignment
From what I can tell I am not putting in the wrong number of arguments and I don't see the problem with my property assignments.
Any and all help would be appreciated.
I believe the error is occurring on the line If sequence = 1 Then For your intent to work, you need to change it to If sequence.Item(0) = 1 Then
Your arguments can continue to go from 1 to 6.
It looks to me that the if statements are not being used to take the input of the parameters properly. Why is there an error check after each if? it seems like it could just be one big if statement.
Your arguments are a collection so are in the form
Set Arg = WScript.Arguments
If LCase(Arg(0)) = "menu" or LCase(Arg(0)) = "m" then
ShowMenu
...
1st is 0, 2nd is 1, etc
For example. I get all strings that i need and write it to the file.
---------- .\A.txt
//...etc
const-string/jumbo v3, "startedinbetween"
const-string/jumbo v5, "startedinbetween"
const-string/jumbo v3, "firsttimeappstarted"
const-string/jumbo v3, "firsttimeappstarted"
//...etc
Then i change this strings something like this
---------- .\A.txt
//...etc
const-string/jumbo v3, "1"
const-string/jumbo v5, "2"
const-string/jumbo v3, "3"
const-string/jumbo v3, "4"
//...etc
Is it possible to find it again in source file and replace with changed strings provided that the the order didnt cnanged? Like preg_replace or grep.
"const-string/jumbo v3, 'startedinbetween'" => "const-string/jumbo v3, '1'"
"const-string/jumbo v3, 'startedinbetween'" => "const-string/jumbo v3, '2'"
"const-string/jumbo v3, 'firsttimeappstarted'" => "const-string/jumbo v3, '3'"
//etc
Here's a Find and replace program.
On Error Resume Next
Set ShellApp = CreateObject("Shell.Application")
ReportErrors "Creating Shell.App"
set WshShell = WScript.CreateObject("WScript.Shell")
ReportErrors "Creating Wscript.Shell"
Set objArgs = WScript.Arguments
ReportErrors "Creating Wscript.Arg"
Set regEx = New RegExp
ReportErrors "Creating RegEx"
Set fso = CreateObject("Scripting.FileSystemObject")
ReportErrors "Creating FSO"
If objArgs.Count = 0 then
wscript.echo "No parameters", 16, "Serenity's ReplaceRegExp"
ReportErrors "Help"
ElseIf objArgs.Count = 1 then
wscript.echo "Only one parameter", 16, "Serenity's ReplaceRegExp"
ReportErrors "Help"
ElseIf objArgs.Count = 2 then
Set srcfile = fso.GetFile(objArgs(0))
ReportErrors "srcFile"
If err.number = 0 then Set TS = srcFile.OpenAsTextStream(1, 0)
If err.number <> 0 then
wscript.echo err.description & " " & srcFile.path, 48, "Serenity's Search"
err.clear
else
ReportErrors "TS" & " " & srcFile.path
Src=ts.readall
If err.number = 62 then
err.clear
else
ReportErrors "ReadTS" & " " & srcFile.path
regEx.Pattern = objArgs(1)
regEx.IgnoreCase = True
regEx.Global = True
If regEx.Test(Src) = True then
wscript.echo "Found in " & srcfile.path, 64, "Serenity's Search"
End If
End If
End If
ReportErrors "Check OK" & " " & srcFile.path
Elseif objArgs.count = 3 then
Set srcfile = fso.GetFile(objArgs(0))
ReportErrors "srcFile"
If err.number = 0 then Set TS = srcFile.OpenAsTextStream(1, 0)
If err.number <> 0 then
wscript.echo err.description & " " & srcFile.path, 48, "Serenity's Search"
err.clear
else
ReportErrors "TS" & " " & srcFile.path
Src=ts.readall
If err.number = 62 then
err.clear
else
ReportErrors "ReadTS" & " " & srcFile.path
regEx.Pattern = objArgs(1)
regEx.IgnoreCase = True
regEx.Global = True
NewSrc= regEx.Replace(Src, objArgs(2))
If NewSrc<>Src then
wscript.echo "Replacement made in " & srcfile.path, 64, "Serenity's Search"
TS.close
Set TS = srcFile.OpenAsTextStream(2, 0)
ts.write newsrc
ReportErrors "Writing file"
End If
End If
End If
ReportErrors "Check OK" & " " & srcFile.path
Else
wscript.echo "Too many parameters", 16, "Serenity's ReplaceRegExp"
ReportErrors "Help"
ReportErrors "All Others"
End If
Sub ReportErrors(strModuleName)
If err.number<>0 then wscript.echo "An unexpected error occurred. This dialog provides details on the error." & vbCRLF & vbCRLF & "Error Details " & vbCRLF & vbCRLF & "Script Name" & vbTab & Wscript.ScriptFullName & vbCRLF & "Module" & vbtab & vbTab & strModuleName & vbCRLF & "Error Number" & vbTab & err.number & vbCRLF & "Description" & vbTab & err.description, vbCritical + vbOKOnly, "Something unexpected"
Err.clear
End Sub
You can use two native batch scripts to modify files, called repl.bat and findrepl.bat and they can both use Windows regular expressions.
Helper batch file findrepl.bat (by aacini) - download from: https://www.dropbox.com/s/rfdldmcb6vwi9xc/findrepl.bat
Helper batch file repl.bat (by dbenham) - download from: https://www.dropbox.com/s/qidqwztmetbvklt/repl.bat
They have features that are found in grep and sed.
I am writing email sending code in Classic ASP using CDOSYS, but what i found when i try to write variables concatenation with CDOSYS parameters its gives me error.
I could not write code in following way-
mail.Configuration.Fields.Item ("http://schemas.microsoft.com/cdo/configuration/sendusername") = "admin#" & website
it givees me following error while execution - CDO.Message.1 error '80040213'
while following code works fine as its having single variable-
http://schemas.microsoft.com/cdo/configuration/sendusername") = websiteemail
Note:- Reason to use in that way because my client having many sites and previously we used CDONTS and ASPEMAILS and it used to work fine.
Here is the function I created:
function email(s_from,s_reply_to,s_recipients,s_bcc,s_subject,s_msg,s_type,s_msg_error_add,s_remote_host)
if (s_msg_error_add<>"") then s_msg_error_add = "<hr>" & vbCrLf & s_msg_error_add
if (s_remote_host="default") then s_remote_host = application("s_mail_server")
if (s_remote_host="") then s_remote_host = "localhost"
s_remote_host=lcase(s_remote_host)
's_recipients looks like "Scott <scott#domain.net>; Sue <andy#domain.net>" etc
s_from = replace(s_from,","," ",1,-1,1)
s_from = replace(s_from," "," ",1,-1,1)
s_from = replace(s_from,"[","<",1,-1,1)
s_from = replace(s_from,"]",">",1,-1,1)
if (s_reply_to<>"") then
s_reply_to = replace(s_reply_to,","," ",1,-1,1)
s_reply_to = replace(s_reply_to," "," ",1,-1,1)
s_reply_to = replace(s_reply_to,"[","<",1,-1,1)
s_reply_to = replace(s_reply_to,"]",">",1,-1,1)
end if
s_recipients = replace(s_recipients,",",";",1,-1,1)
s_recipients = replace(s_recipients," "," ",1,-1,1)
s_recipients = replace(s_recipients,"[","<",1,-1,1)
s_recipients = replace(s_recipients,"]",">",1,-1,1)
if (s_bcc<>"") then
s_bcc = replace(s_bcc,","," ",1,-1,1)
s_bcc = replace(s_bcc," "," ",1,-1,1)
s_bcc = replace(s_bcc,"[","<",1,-1,1)
s_bcc = replace(s_bcc,"]",">",1,-1,1)
end if
err.clear
Dim MailerConfig
Dim Mailer
Dim strRet
dim sch
strRet = ""
sch = "http://schemas.microsoft.com/cdo/configuration/"
Set MailerConfig = CreateObject("CDO.Configuration")
Set Mailer = CreateObject("CDO.Message")
With MailerConfig.Fields
'.Item(sch & "sendusing") = 2 'send using port - if err then this is really "SendUsingMethod"
'.Item(sch & "sendusingmethod") = 2 'send using port - if err then this is really "SendUsingMethod"
.Item(sch & "smtpconnectiontimeout") = 900
'.Item(sch & "smtpauthenticate") = 1 'use basic (clear-text) authentication
.Item(sch & "smtpserver") = s_remote_host
'.Item(sch & "smtpserverport") = 25
'.Item(sch & "sendusername") = SMAUTHUSER
'.Item(sch & "sendpassword") = SMAUTHPASS
.Update
End With
Mailer.Configuration = MailerConfig
'Mailer.Fields(cdoImportance) = 1
'Mailer.Fields("urn:schemas:mailheader:X-MSMail-Priority") = 1
'Mailer.Fields("urn:schemas:mailheader:X-Mailer") = ""
'Mailer.Fields.Update
'-- Set the Mail Properties
'on error resume next
Mailer.From = s_from
Mailer.To = s_recipients
if (s_reply_to<>"" and s_reply_to<>"na") then Mailer.ReplyTo = s_reply_to
b_redirect=false
if (err.number<>0 and err.number<>13) then
session("msg") = "Error in i_fn_email_cdo.asp line 72, Error: " & err.number & "<br>" & err.description
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
if (s_bcc<>"" AND s_bcc<>"na" AND s_bcc<>"n/a") then Mailer.BCC = s_bcc
if (err.number<>0 and err.number<>13) then
session("msg") = "Error in i_fn_email_cdo.asp line 79, Error: " & err.number & "<br>" & err.description
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
Mailer.Subject = s_subject
if (err.number<>0 and err.number<>13) then
session("msg") = "Error in i_fn_email_cdo.asp line 86, Error: " & err.number & "<br>" & err.description
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
if (s_type="html") then
Mailer.AutoGenerateTextBody = True
s_msg = replace(s_msg,vbCrLf,"<br>",1,-1,1)
else
Mailer.AutoGenerateTextBody = False
end if
if (err.number<>0 and err.number<>13) then
session("msg") = "Error in i_fn_email_cdo.asp line 103, Error: " & err.number & "<br>" & err.description
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
Mailer.MimeFormatted = False
if (err.number<>0 and err.number<>13) then
session("msg") = "Error in i_fn_email_cdo.asp line 110, Error: " & err.number & "<br>" & err.description
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
if (s_type = "text") then
Mailer.TextBody = fn_dirty(s_msg)
else
's_msg_html = replace(s_msg,vbCrLf,"<br>",1,-1,1)
s_msg_html = s_msg
Mailer.HTMLBody = fn_dirty(s_msg_html)
end if
if (err.number<>0 and err.number<>13) then
session("msg") = "Error in i_fn_email_cdo.asp line 123, Error: " & err.number & "<br>" & err.description
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
'-- Fire off the email message
Mailer.Send
if (err.number<>0 and err.number<>13) then
Select Case err.Number
Case -2147220973
strRet = " Failure to Send Report Message - Server Not Found" & vbCrLf & " Error: " & err.Number & " - " & err.Description
Case -2147220975
strRet = " Failure to Send Report Message - Server Authentication Failed" & vbCrLf & " Error: " & err.Number & " - " & err.Description
Case Else
strRet = " Failure to Send Report Message - Error: " & err.Number & " - " & err.Description
End Select
msg = "<br>Error in i_fn_email_cdo.asp: " & strRet & "<br><br>"
msg = msg & "remote host = " & s_remote_host & "<br>"
s_from = replace(s_from,"<","[",1,-1,1)
s_from = replace(s_from,">","]",1,-1,1)
s_reply_to = replace(s_reply_to,"<","]",1,-1,1)
s_reply_to = replace(s_reply_to,">","[",1,-1,1)
s_recipients = replace(s_recipients,"<","[",1,-1,1)
s_recipients = replace(s_recipients,">","]",1,-1,1)
s_bcc = replace(s_bcc,"<","[",1,-1,1)
s_bcc = replace(s_bcc,">","]",1,-1,1)
msg = msg & "from = " & s_from & "<br>"
msg = msg & "to = " & s_recipients & "<br>"
msg = msg & "subject = " & s_subject & "<br>"
msg = msg & "recipients = " & s_recipients & "<br><br>"
if (s_type = "text") then
msg = msg & s_msg
else
msg = msg & s_msg_html
end if
msg = msg & "<br>"
msg = msg & s_msg_error_add
session("msg") = msg
Set Mailer = Nothing
set MailerConfig = nothing
if (b_redirect) then response.redirect ("error_report.asp?send_mail=yes")
end if
Set Mailer = Nothing
set MailerConfig = nothing
email = true
end function
My organization has extremely restrictive and rigid rules our code must comply with in order to obtain certification and accreditation. For the last decade or so we have developed nearly a hundred VS macros that format code, generate comments blocks, enforce style rules, etc.
Our macros are not the kind you record some mouse movements; they all depend on the EnvDTE* VS automation objects. With VS 2012 dropping macros we are at a loss as to whether or not we will even be able to upgrade, without imposing a drastic impact on the team.
I am aware that the direction Microsoft is going is the VS Addins route and I am willing to investigate that route but I am having trouble finding code samples or documentation on how a VS Add-In can interact with the active code file in Visual Studio.
For example, here is a macro we use all the time that applies our Try wrapper design pattern to all methods that are capable of throwing unhandled exceptions
''' <summary>
''' Wraps active method in Try* access wrappers.
''' </summary>
Sub InsertSingleMethodTryWrappers()
Dim textSelection As TextSelection
Dim codeElement As CodeElement
textSelection = DTE.ActiveWindow.Selection
DTE.UndoContext.Open("Generate Try Wrappers") 'Allow for single Undo operation to rollback all changes
Try
codeElement = textSelection.ActivePoint.CodeElement(vsCMElement.vsCMElementFunction)
If Not (codeElement Is Nothing) Then
Dim textSelection2 As TextSelection
Dim codeFunction As CodeFunction
'Dim codeFunction2 As CodeFunction2
Dim editPoint As EditPoint
Dim codeParameter As CodeParameter
Dim parameters As CodeElements
Dim codeElement2 As CodeElement
Dim isVirtual As Boolean = False
Dim strVirtual As String = String.Empty
Dim strTypeName As String = String.Empty
'' Cast the codeElement to codeFunction object
codeFunction = codeElement
'' Move cursor to the start of the method
textSelection.MoveToPoint(codeFunction.GetStartPoint(vsCMPart.vsCMPartHeader))
'' Should be able to use codeFunction.Kind.ToString to retrieve the function type
'' vsCMFunctionVirtual if the method is virtual but there is a bug in the API
'' that returns vsCMFunctionFunction even if the function is virtual (C# parsing bug?)
''
'' vsCMFunction Type
'' http://msdn.microsoft.com/en-us/library/envdte.vscmfunction(v=vs.80).aspx
''
'' This frustrating bug means that we have to parse the header to determine if virtual
textSelection.EndOfLine(True)
If (textSelection.Text.IndexOf("virtual") > 0) Then
isVirtual = True
strVirtual = " virtual"
End If
textSelection.StartOfLine()
'' Try not to screw up comments and attributes
editPoint = GetNoneCommentOrAttribHeaderEditPoint(textSelection)
If editPoint Is Nothing Then
MsgBox("Could not find a line above the method that isn't a comment or attribute", _
MsgBoxStyle.Critical + MsgBoxStyle.OkOnly, "Error")
Exit Sub
End If
'' Create an EditPoint to inject Try* methods
'editPoint = textSelection.TopPoint.CreateEditPoint()
'editPoint.LineUp() 'Move up 1 line
editPoint.EndOfLine() 'Go to end of line above signature
editPoint.Insert(Environment.NewLine) 'Insert blank line for cleanliness
editPoint.Insert(Environment.NewLine) 'Insert blank line for cleanliness
editPoint.LineUp() 'Move up 1 line
parameters = codeFunction.Parameters
Dim strAccess As String : strAccess = GetAccessModifierString(codeFunction.Access) 'Access Modifier
Dim strName As String : strName = codeElement.Name 'Member Name
Dim strType As String : strType = codeFunction.Type.AsString 'Type Name
'' Get the un-qualified object name
If (strType.IndexOf(".") > 0) Then
Dim arrType() As String = strType.Split(".")
strTypeName = arrType(arrType.Length - 1)
Else
strTypeName = strType
End If
''' Create parameter type/name arrayList
Dim arrParams As System.Collections.ArrayList
arrParams = New System.Collections.ArrayList()
For Each codeElement2 In parameters
codeParameter = codeElement2
arrParams.Add(codeParameter.Type.AsString.Trim & " " & codeParameter.Name.Trim & ", ")
Next
Dim strParams As String
Dim strParamNames As String
'' Capture a string with parameter names and types and one just of names
For Each strParam As String In arrParams
strParams += strParam
strParamNames += strParam.Split(" ")(1)
Next
'' Trim excess comma for members of type void
If strType = "void" Then
If Not String.IsNullOrEmpty(strParams) Then
If strParams.TrimEnd.EndsWith(",") Then
strParams = strParams.TrimEnd()
strParams = strParams.Remove(strParams.Length - 1, 1)
End If
End If
End If
'' -- Try* swallow methods --
'' we don't care what the exception is, we just want to know success or failure
Dim strTrySwallowSignature As String
Dim strTrySwallowBody As String
Dim strTryOutParams As String
Dim strOutDef As String
Dim strOutSig As String
'' Members of type 'void' get no out parameters
If Not strType = "void" Then
strTryOutParams = "out " & strTypeName & " outObjType"
strOutDef = "outObjType = null;"
strOutSig = " out outObjType,"
End If
strTrySwallowSignature = vbTab & vbTab & strAccess & strVirtual & " bool Try" & strName & "(" & strParams & strTryOutParams & ")"
strTrySwallowBody = vbCrLf & vbTab & vbTab & "{" _
& vbCrLf & vbTab & vbTab & vbTab & "Exception exception;" _
& vbCrLf & vbTab & vbTab & vbTab & strOutDef _
& vbCrLf & vbTab & vbTab & vbTab & "return Try" & strName & "(" & strParamNames & strOutSig & " out exception);" _
& vbCrLf & vbTab & vbTab & "}"
'' -- Try* re-throw methods --
'' We want to know success or failure as well as the exception if it failed
Dim strTryReThrowSignature As String
Dim strTryReThrowBody As String
'' Members of type 'void' only get out exception parameter
If Not strType = "void" Then
strTryOutParams = "out " & strTypeName & " outObjType, out Exception exception"
'strOutDef = "outObjType = new " & strTypeName & "();"
strOutDef = "outObjType = null;"
Else
strTryOutParams = "out Exception exception"
End If
strTryReThrowSignature = vbTab & vbTab & strAccess & strVirtual & " bool Try" & strName & "(" & strParams & strTryOutParams & ")"
strTryReThrowBody = vbCrLf & vbTab & vbTab & "{" _
& vbCrLf & vbTab & vbTab & vbTab & "bool result = false;" _
& vbCrLf & vbTab & vbTab & vbTab & "exception = null;" _
& vbCrLf & vbTab & vbTab & vbTab & strOutDef _
& vbCrLf & vbTab & vbTab & vbTab & "try" _
& vbCrLf & vbTab & vbTab & vbTab & "{" _
& vbCrLf & vbTab & vbTab & vbTab & vbTab & "// insert code here " _
& vbCrLf & vbTab & vbTab & vbTab & vbTab & "//result = true; " _
& vbCrLf & vbTab & vbTab & vbTab & vbTab & "throw new NotImplementedException();" _
& vbCrLf & vbTab & vbTab & vbTab & "}" _
& vbCrLf & vbTab & vbTab & vbTab & "catch (Exception e)" _
& vbCrLf & vbTab & vbTab & vbTab & "{" _
& vbCrLf & vbTab & vbTab & vbTab & vbTab & "exception = e;" _
& vbCrLf & vbTab & vbTab & vbTab & "}" _
& vbCrLf & vbTab & vbTab & vbTab & "return result;" _
& vbCrLf & vbTab & vbTab & "}"
editPoint.Insert(strTrySwallowSignature)
editPoint.Insert(strTrySwallowBody)
editPoint.Insert(vbCrLf & vbCrLf)
editPoint.Insert(strTryReThrowSignature)
editPoint.Insert(strTryReThrowBody)
editPoint.Insert(vbCrLf)
End If
Catch Ex As Exception
MsgBox(Ex.Message)
Finally
DTE.UndoContext.Close()
End Try
End Sub
Can someone direct me to how a VS 2012 Add-in can manipulate the active/open code file (using EnvDTE* or whatever object model is available for 2012)?
Well that turned out to be really simple. Turns out the Macro object model is part of the VS model so no problem.
http://msdn.microsoft.com/en-us/library/za2b25t3%28v=vs.110%29.aspx
http://msdn.microsoft.com/en-us/library/ms228776.aspx
I should have know Microsoft wouldn't have left us Macro-dependant developers out in the cold like that!