Need help enhancing a Visual Studio Macro - regex

Here's my current Macro
Public Module CopyrightCode
Sub AddCopyrightHeader()
Dim doc As Document
Dim docName As String
Dim companyName As String = "Urban Now"
Dim authorName As String = "Chase Florell"
Dim authorEmail As String = "chase#infinitas.ws"
Dim copyrightText As String = "' All code is Copyright © " & vbCrLf & _
"' - Urban Now (http://mysite.com)" & vbCrLf & _
"' - Infinitas Advantage (http://infinitas.ws)" & vbCrLf & _
"' All Rights Reserved"
' Get the name of this object from the file name
doc = DTE.ActiveDocument
' Get the name of the current document
docName = doc.Name
' Set selection to top of document
DTE.ActiveDocument.Selection.StartOfDocument()
DTE.ActiveDocument.Selection.NewLine()
Dim sb As New StringBuilder
sb.Append("' --------------------------------")
sb.Append(vbCrLf)
sb.Append("' <copyright file='" & docName & "' company='" & companyName & "'>")
sb.Append(vbCrLf)
sb.Append(copyrightText)
sb.Append(vbCrLf)
sb.Append("' </copyright>")
sb.Append(vbCrLf)
sb.Append("' <author>" & authorName & "</author>")
sb.Append(vbCrLf)
sb.Append("' <email>" & authorEmail & "</email>")
sb.Append(vbCrLf)
sb.Append("' <lastedit>" & FormatDateTime(Date.Now, vbLongDate) & "</lastedit>")
sb.Append(vbCrLf)
sb.Append("' ---------------------------------")
' Write first line
DTE.ActiveDocument.Selection.LineUp()
DTE.ActiveDocument.Selection.Text = sb.ToString
End Sub
End Module
What I need to do is first do a file search for the line ' <lastedit>Monday, July 05, 2010</lastedit> (obviously as a REGEX because the date will always be different)
and if it exists, replace the date with today's date, and if it doesn't run the full insert.
Then what I want to hook up is every time I close a file, the Macro runs to update the edit date.

I'm not sure what you're doing, but if that is XML (as it looks like), you should be using XQuery or whatever to locate/update the lastedit node, since that'll handle the assorted complexities of comments and nesting and so on.
If you're confident of what the input text will be and are certain there's no nasties in there, you can match that specific date format quick and dirty:
<lastedit>\w{6,9}, \w{3,9} \d\d, \d{4}</lastedit>
Or, even quicker and dirtier:
<lastedit>[^<]+<lastedit>
It depends what your needs are, how confident you are of what the file contents will be, and so on.
Oh. So I was curious and went and looked up how Visual Studio actually does it's regex stuff, and well... whoever did the VS regex needs to be whacked round the head.
Translate the above standard regex into VS regex, you get these:
\<lastedit\>:i+, :i+ :d:d, :d:d:d:d\</lastedit\>
and
\<lastedit\>[^<]+</lastedit\>
Maybe. It's hard to read the documentation because Microsoft don't appear to want to write websites that work in modern browsers.
Of course, that assumes macros use this insane regex instead of the normal .NET regex - if it's the latter than the top stuff will be fine and you can ignore this craziness. :)
To implement, try something like this:
Dim reLastEdit As Regex = New Regex("<lastedit>[^<]+<lastedit>")
Dim matches AS MatchCollection = reLastEdit.Matches(Input)
If matches.Count > 0
Then
' Change Header
Dim NewLastEdit As String = "<lastedit>" & FormatDateTime(Date.Now, vbLongDate) & "</lastedit>"
reLastEdit.Replace(Input,NewLastEdit)
Else
' Add Header
EndIf
Or similar. Info here: http://msdn.microsoft.com/en-us/library/system.text.regularexpressions.regex_methods.aspx

Related

Can i make Excel save after a specific day of the week?

My idea is that i want my workbook to save automatically when the workbook is opend after every sunday. so if i open the workbook at monday morning it will save the workbook at a folder with a new weeknr in the name every week.
my first thought was doing it with IF statements but im not sure thats the way.
If you wish to go the VBA route, you can start with something like this:
First save your initial woorkbook as filename.xlsm (excel with macros enabled). Otherwise nothing will work.
Then enter VBA editor using ALT-F11. Click "This project folder" and make an _open event macro.
Order of action as here:
You can use this code as a skeleton:
Const myBaseName As String = "opopen"
Const myBasePath As String = "c:\temp\"
Private Sub Workbook_Open()
' get a new date
d = Format(Now(), "yyyymmdd_hhnnss")
newname = myBasePath & myBaseName & "_" & d & ".xlsm"
MsgBox "NEW NAME IS ==> " & newname, vbOKOnly, "Information"
ActiveWorkbook.SaveAs newname
End Sub
Obviously you can / should add some logic to make this change file only once per week. Use some date formatting to get week number, check file existence etc.
In my example, I make a new filename based on time, accurate to seconds - to prove the concept.
The weeknumber can be acquired using
Dim wk As Integer
wk = Application.WorksheetFunction.WeekNum(Now())
wks = wk ' as string
If wk < 10 Then
wks = "0" & wk
End If
' use wks for weeknumbers, formatted to two digits.
First time you open this file you will have to confirm activation of macros. If you do saveAs from VBA, you should know that
you immediately work with the new filename. You do not "save a copy as"
the new file will have VBA macros enabled as well
if you rename the file from Windows, you will have to reconfirm macros enabled.
Is this enough to get you started ?

Unable to get missingFiles.txt to add values

I've been working on this for awhile and have gotten lots of help (Thank you!). I believe I'm on the last step of my code. I need to write to a MissingFiles.txt file, I've added it in my Else clause but it never fires. Even when I know there are missing graphics. It does copy the files found in a try/catch. I was thinking maybe add the missingText file code in the catch part but that didn't do anything.
So I'm back to using the Else clause in my If System.IO.File.exists else part.
Private Sub btnMoveGraphics(sender As Object, e As EventArgs)
Dim imgLocation = txtSearchICN.Text
Dim MissingFiles = MoveLocation & "\Reports\MissingGraphicList.txt"
Dim fileNames = System.IO.Directory.GetFiles(imgLocation).Join(
GraphicList,
Function(p) Path.GetFileNameWithoutExtension(p),
Function(f) f,
Function(p, f) p)
' create the directory first (does nothing if it already exists)
Dim MoveImgTo = MovePath & "\Figures"
Directory.CreateDirectory(MoveImgTo)
' copy each file
For Each fileName In fileNames
Dim copyFilesTo = Path.Combine(MoveImgTo, Path.GetFileName(fileName))
If System.IO.File.Exists(fileName) Then
'The file exists
Debug.Write(vbCr & "ICN file name - " & fileName)
Try
System.IO.File.Copy(fileName, Path.Combine(MoveImgTo, Path.GetFileName(fileName)))
Catch ex As Exception
End Try
Else
Debug.Write(vbCr & "Missing file name - " & fileName)
'the file doesn't exist
Dim objWriter As New System.IO.StreamWriter(MissingFiles, IO.FileMode.Append)
objWriter.WriteLine(fileName)
objWriter.Close()
End If
Next
End Sub
There are several possible solutions to your question. They all involve two steps, (1) get the list of files in the imgLocation folder, and (2) compare that list with the GraphicList list.
One solution is to compare the two lists directly.
' Get the list of file
Dim fileNames as String() = System.IO.Directory.GetFiles(imgLocation)
' For each name in GraphicList, we want to check whether it is in fileNames.
For Each name As String In GraphicList
' See whether name appears in fileNames.
Dim found As Boolean = False
' Search name in fileNames.
For Each fileName As String In fileNames
' GraphicList consists of filename without extension, so we compare name
' with the filename without its extension.
If Path.GetFileNameWithoutExtension(fileName) = name Then
' The fileName name exists.
' ... do whatever code ...
' Set found to True so we do not process name as missing, and exit For.
found = True
Exit For
End If
Next
If Not found = True Then
' There is no fileName name.
' ... do whatever code ...
End If
Next
If the number of files you have are in the hundreds, then this solution will be efficient enough. However, if you have many more files, in the thousands or more, then there are more efficient solutions that involves using data structures such as dictionaries and sets.
Final note, instead of:
Dim objWriter As New System.IO.StreamWriter(MissingFiles, IO.FileMode.Append)
objWriter.WriteLine(fileName) ' <== Here it should be a name from GraphicFile because filename does not exist.
objWriter.Close()
You could simply write:
File.AppendAllText(MissingFiles, name & vbNewLine)

How to insert a new line after each occurrence of a particular format in a text field

I have a system that I can output a spreadsheet from. I then take this outputted spreadsheet and import it into MS Access. There, I run some basic update queries before merging the final result into a SharePoint 2013 Linked List.
The spreadsheet I output has an unfortunate Long Text field which has some comments in it, which are vital. On the system that hosts the spreadsheet, these comments are nicely formatted. When the spreadsheet it output though, the field turns into a long, very unpretty string like so:
09:00 on 01/03/2017, Firstname Surname. :- Have responded to request for more information. 15:12 on 15/02/2017, Firstname Surname. :- Need more information to progress request. 17:09 on 09/02/2017, Firstname Surname. :- Have placed request.
What I would like to do is run a query (either in MS Access or MS Excel) which can scan this field, detect occurrences of "##:## on ##/##/####, Firstname Surname. :-" and then automatically insert a line break before them, so this text is more neatly formatted. It would obviously skip the first occurrence of this format, as otherwise it would enter a new line at the start of the field. Ideal end result would be:
09:00 on 01/03/2017, Firstname Surname. :- Have responded to request
for more information.
15:12 on 15/02/2017, Firstname Surname. :- Need more information to progress request.
17:09 on 09/02/2017, Firstname Surname. :- Have placed request.
To be honest, I haven't tried much myself so far, as I really don't know where to start. I don't know if this can be done without regular expressions, or within a simple query versus VBA code.
I did start building a regular expression, like so:
[0-9]{2}:[0-9]{2}\s[o][n]\s[0-9]{2}\/[0-9]{2}\/[0-9]{4}\,\s
But this looks a little ridiculous and I'm fairly certain I'm going about it in a very unnecessary way. From what I can see from the text, detecting the next occurrence of "##:## on ##/##/####" should be enough. If I take a new line after this, that will suffice.
You have your RegExp pattern, now you need to create a function to append found items with your extra delimiter.
look at this function. It takes, your long string and finds your date-stamp using your pattern and appends with your delimiter.
Ideally, i would run each line twice and add delimiters after each column so you have a string like,
datestamp;firstname lastname;comment
you can then use arr = vba.split(text, ";") to get your data into an array and use it as
date-stamp = arr(0)
name = arr(1)
comment = arr(2)
Public Function FN_REGEX_REPLACE(iText As String, iPattern As String, iDelimiter As String) As String
Dim objRegex As Object
Dim allmatches As Variant
Dim I As Long
On Error GoTo FN_REGEX_REPLACE_Error
Set objRegex = CreateObject("vbscript.regexp")
With objRegex
.Multiline = True
.Global = True
.IgnoreCase = True
.Pattern = iPattern
If .test(iText) Then
Set allmatches = .Execute(iText)
If allmatches.count > 0 Then
For I = 1 To allmatches.count - 1 ' for i = 0 to count will start from first match
iText = VBA.Replace(iText, allmatches.item(I), iDelimiter & allmatches.item(I))
Next I
End If
End If
End With
FN_REGEX_REPLACE = Trim(iText)
Set objRegex = Nothing
On Error GoTo 0
Exit Function
FN_REGEX_REPLACE_Error:
MsgBox Err.description
End Function
use above function as
mPattern = "[0-9]{2}:[0-9]{2}\s[o][n]\s[0-9]{2}\/[0-9]{2}\/[0-9]{4}\,"
replacedText = FN_REGEX_REPLACE(originalText,mPattern,vbnewline)
Excel uses LF for linebreaks, Access uses CRLF.
So it should suffice to run a simple replacement query:
UPDATE myTable
SET LongTextField = Replace([LongTextField], Chr(10), Chr(13) & Chr(10))
WHERE <...>
You need to make sure that this runs only once on newly imported records, not repeatedly on all records.

Regular Expression Rules in Outlook 2007?

Is it possible to create rules in Outlook 2007 based on a regex string?
I'm trying to add a filter for messages containing a string such as: 4000-10, a four digit number followed by a dash and then a two digit number, which can be anything from 0000-00 to 9999-99.
I was using this as a regex: \b[0-9]{4}\-[0-9]{2}\b but the filter isn't working. I've tried a few other modifications as well with no luck. I wasn't able to find anything concrete online about whether Outlook even supports entering regexes into a rule, though, so I figured I would ask here in case I'm wasting my time.
EDIT: Thanks to Chris's comment below, I was able to implement this filter via a macro. I thought I would share my code below in case it is able to help anyone else:
Sub JobNumberFilter(Message As Outlook.MailItem)
Dim MatchesSubject, MatchesBody
Dim RegEx As New RegExp
'e.g. 1000-10'
RegEx.Pattern = "([0-9]{4}-[0-9]{2})"
'Check for pattern in subject and body'
If (RegEx.Test(Message.Subject) Or RegEx.Test(Message.Body)) Then
Set MatchesSubject = RegEx.Execute(Message.Subject)
Set MatchesBody = RegEx.Execute(Message.Body)
If Not (MatchesSubject Is Nothing And MatchesBody Is Nothing) Then
'Assign "Job Number" category'
Message.Categories = "Job Number"
Message.Save
End If
End If
End Sub
I do not know if a regex can be used directly in a rule, but you can have a rule trigger a script and the script can use regexes. I hate Outlook.
First, you have to open the script editor via Tools - Macro - Open Visual Basic Editor (Alt-F11 is the shortcut).
The editor will open. It should contain a project outline in a small panel in the top-left corner. The project will be listed as VBAProject.OTM. Expand this item to reveal Microsoft Office Outlook Objects. Expand that to reveal ThisOutlookSession. Double-click ThisOutlookSession to open the code editing pane (which will probably be blank).
Next select Tools menu | References and enable the RegExp references called something like "Microsoft VBScript Regular Expressions 5.5"
You can now create a subroutine to perform your filtering action. Note that a subroutine called by a rule must have a single parameter of type Outlook.MailItem. For example:
' note that Stack Overflow's syntax highlighting doesn't understand VBScript's
' comment character (the single quote) - it treats it as a string delimiter. To
' make the code appear correctly, each comment must be closed with another single
' quote so that the syntax highlighter will stop coloring everything as a string.'
Public Enum Actions
ACT_DELIVER = 0
ACT_DELETE = 1
ACT_QUARANTINE = 2
End Enum
Sub MyNiftyFilter(Item As Outlook.MailItem)
Dim Matches, Match
Dim RegEx As New RegExp
RegEx.IgnoreCase = True
' assume mail is good'
Dim Message As String: Message = ""
Dim Action As Actions: Action = ACT_DELIVER
' SPAM TEST: Illegal word in subject'
RegEx.Pattern = "(v\|agra|erection|penis|boner|pharmacy|painkiller|vicodin|valium|adderol|sex med|pills|pilules|viagra|cialis|levitra|rolex|diploma)"
If Action = ACT_DELIVER Then
If RegEx.Test(Item.Subject) Then
Action = ACT_QUARANTINE
Set Matches = RegEx.Execute(Item.Subject)
Message = "SPAM: Subject contains restricted word(s): " & JoinMatches(Matches, ",")
End If
End If
' other tests'
Select Case Action
Case Actions.ACT_QUARANTINE
Dim ns As Outlook.NameSpace
Set ns = Application.GetNamespace("MAPI")
Dim junk As Outlook.Folder
Set junk = ns.GetDefaultFolder(olFolderJunk)
Item.Subject = "SPAM: " & Item.Subject
If Item.BodyFormat = olFormatHTML Then
Item.HTMLBody = "<h2>" & Message & "</h2>" & Item.HTMLBody
Else
Item.Body = Message & vbCrLf & vbCrLf & Item.Body
End If
Item.Save
Item.Move junk
Case Actions.ACT_DELETE
' similar to above, but grab Deleted Items folder as destination of move'
Case Actions.ACT_DELIVER
' do nothing'
End Select
End Sub
Private Function JoinMatches(Matches, Delimeter)
Dim RVal: RVal = ""
For Each Match In Matches
If Len(RVal) <> 0 Then
RVal = RVal & ", " & Match.Value
Else
RVal = RVal & Match.Value
End If
Next
JoinMatches = RVal
End Function
Next, you have to create a rule (Tools - Rules and Alerts) to trigger this script. Click the New Rule button on the dialog to launch the wizard. Select a template for the rule. Choose the "Check messages when they arrive" template from the "Start from a blank rule" category. Click Next.
Choose the "On this machine only" condition (intuitive isn't it?) and click next.
Choose the "run a script" option. At the bottom of the wizard where it shows your new rule, it should read:
Apply this rule after the message arrives
on this machine only
run a script
The phrase "a script" is a clickable link. Click it and Outlook will display a dialog that should list the subroutine you created earlier. Select your subroutine and click the OK button.
You can click Next to add exceptions to the rule or click Finish if you have no exceptions.
Now, as though that process was not convoluted enough, this rule will deactivate every time you stop and restart Outlook unless you sign the script with a code signing key.
If you don't already have a code signing key, you can create one with OpenSSL.
Did I mention that I hate Outlook?
Microsoft Outlook does not support regular expressions. You can perform wildcard searches, although for some inexplicable reason the wildcard character is %, not *.

Does VBscript have modules? I need to handle CSV

I have a need to read a CSV file, and the only language I can use is VBscript.
I'm currently just opening the file and splitting on commas, and it's working OK because there aren't any quoted commas in fields. But I'm aware this is an incredibly fragile solution.
So, is there such a thing as a VBscript module I can use? Somewhere to get a tried-and-tested regular expression that would only split on commas not in quotes?
Any suggestions gratefully received.
VBScript does not have a module system comparable to Perl. However you can open CSV files with ADO and access them like a database table. The code would go something like this:
(The funny comments are solely to fix SO's broken VB syntax highlighting)
Dim conn ''// As ADODB.Connection
Dim rs ''// As ADODB.RecordSet
Dim connStr ''// As String
Dim dataDir ''// As String
dataDir = "C:\" '"
connStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & dataDir & ";Extended Properties=""text"""
Set conn = CreateObject("ADODB.Connection")
conn.Open(connStr)
Set rs = conn.Execute("SELECT * FROM [data.txt]")
''// do something with the recordset
WScript.Echo rs.Fields.Count & " columns found."
WScript.Echo "---"
WScript.Echo rs.Fields("Col1Name").Value
If Not rs.EOF Then
rs.MoveNext
WScript.Echo rs.Fields("Col3Name").Value
End If
''// explicitly closing stuff is somewhat optional
''// in this script, but consider it a good habit
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
Creating a schema.ini file that exactly describes your input is optimal. If you don't, you force the text driver to guess, and all bets are off if it guesses the wrong thing. The schema.ini must reside in the same directory where your data is.
Mine looked like this:
[data.txt]
Format=Delimited(;)
DecimalSymbol=.
ColNameHeader=True
MaxScanRows=0
Col1=Col1Name Long
Col2=Col2Name Long
Col3=Col3Name Text
Col4=Col4Name Text
and with this data.txt:
a;b;c;d
1;2;"foo bar";"yadayada"
1;2;"sample data";"blah"
I get this output:
C:\>cscript -nologo data.vbs
4 columns found.
---
1
sample data
C:\>
Worth a read in this regard: Much ADO About Text Files off the MSDN.
You can try creating an Excel ODBC Data Source to CSV (Called DSN I think. Its in Control Panel -> Administrative Tools -> ODBC Data Sources. Then on, you can query it using SQL.
I am still unsure if you can get what you want. I mean inserting a string with commas in it as a value for a particular cell.
A regexp:
'Credits go to http://www.codeguru.com/cpp/cpp/algorithms/strings/article.php/c8153/
r.Pattern = ",(?=(?:[^""]*""[^""]*"")*(?![^""]*""))"
It will find all commas that are not inside quotes.
Alternatively, you can use this function which I just adapted for vbs.
call test
Function ParseCSV(StringToParse, Quotes)
Dim i, r(), QuotedItemStart, prevpos
ReDim r(0)
prevpos = 1
For i = 1 To Len(StringToParse)
If Mid(StringToParse, i, 1) = "," Then
If QuotedItemStart = 0 Then
r(UBound(r)) = Trim(Mid(StringToParse, prevpos, i - prevpos))
ReDim Preserve r(UBound(r) + 1)
prevpos = i + 1
End If
Else
If InStr(1, Quotes, Mid(StringToParse, i, 1)) Then
If QuotedItemStart Then
r(UBound(r)) = Trim(Mid(StringToParse, QuotedItemStart, i - QuotedItemStart))
ReDim Preserve r(UBound(r) + 1)
QuotedItemStart = 0
prevpos = i + 2
i = i + 1
Else
QuotedItemStart = i + 1
End If
End If
End If
Next
If prevpos < Len(StringToParse) Then r(UBound(r)) = Trim(Mid(StringToParse, prevpos))
ParseCSV = r
End Function
Sub Test()
Dim i, s
s = ParseCSV("""This is, some text!"",25,""Holy holes!"", 286", """")
For i = LBound(s) To UBound(s)
msgbox s(i)
Next
msgbox "Items: " & CStr(UBound(s) - LBound(s) + 1)
End Sub
To answer the other half of your question, I have a vague recollection that you can use Windows Script Host spread across several WSF files. I have never done it myself, link to MSDN. Not pure VBS, but it should work in 'just' windows, if that was the real constraint.
More links:
Scripting Guys
Wikipedia
'Tutorial'