Extract specific portion of document path to document variable

[bstephens]

Hi,

Does anyone know how to do a string (or array) manipulation that will always return the below described portion of a filename and save it to a document variable.

An example illustrates what I mean best:

Suppose you had a document in any of the following scenarios:


S:\2011\4444.01\abc100.doc, or

S:\2011\55555.01\agreement\abc200.doc, or

S:\2011\55555.01\pleading\abc300.doc, or

S:\2011\4444.01\agreement\abc400.doc, or

\\FSERVER1\J\2011\4444.01\abc500.doc

\\FSERVER1\J\2011\55555.01\abc500.doc
The function would always return the value of either "4444.01" or "55555.01" after extracting it from the path (which in our case represents the "client number").

Some of the client numbers are four digits, and some are five digits, and I am trying to get it to work for both cases. So in general, the "client number" always takes the following generalized form:


[four integers] "." [two integers], or

[five integers] "." [two integers]
My objective in storing this value is to always have the client number come up in a { DOCVARIABLE clientNumber } field stored several places in the document, and would like to be able to extract it automatically from .path without having to type it in manually each time. Problem is, sometimes users create subfolders under the client folder (ex: "agreement" "pleading", etc.), and we have users accessing from mapped drives, and as the equivalent unc path through a search server.

Anyone have a good function to extract the portion of a filepath that always takes either of the above described generalized forms?

Best,
Brian

[bstephens]

Anyone have ideas how to improve this string extract portion?

Function MatchingSubstring(inputString As String, PatternString As String, _
Optional returnLength As Double = -1, Optional Incidence As Long) As String
Dim i As Long
If returnLength < 0 Then returnLength = Len(PatternString)
If Incidence < 1 Then Incidence = 1
For i = 1 To Len(inputString)
If Mid(inputString, i) Like PatternString & "*" Then
Incidence = Incidence - 1
If Incidence = 0 Then
MatchingSubstring = Mid(inputString, i, returnLength)
End If
End If
Next i
End Function

Sub ExtractSting()
Var2 = MatchingSubstring(ActiveDocument.Path, "####*.##")
If Right(Var2, 1) = "\" Then
MsgBox (Left(Var2, Len(Var2) - 1))
Else: MsgBox (Var2)
End If
End Sub

[Frosty]

I can't get your existing function to work. There are a number of different ways to go about this, but this might be the simplest (and allow you to add in additional patterns).

The main concept is the use of the Like operator (which is sort of a SQL-lite function in VBA).

Public Function fExtractClientMatter(sDocPath As String) As String
Dim aryFilePath() As String
Dim sClientMatter As String
Dim bFound As Boolean
Dim i As Integer

'get our array
aryFilePath = Split(sDocPath, "\")
'find the right element of the array containing the client matter
For i = 0 To UBound(aryFilePath)
sClientMatter = aryFilePath(i)
'if any of our patterns match, we're done
If sClientMatter Like "####.##" Then
bFound = True
Exit For
ElseIf sClientMatter Like "#####.##" Then
bFound = True
Exit For
End If
Next
'return it
If bFound Then
fExtractClientMatter = sClientMatter
End If
End Function

[Frosty]

Just to make it clear: any time you do pattern-analysis, you open yourself to failure in certain circumstances.

The above code will survive even if you have subfolders under your client matter number which also match either of the patterns (since it goes from the lowest element of the array to the highest, i.e., left to right)

However, it will fail if you have something in the document path string which is at the left. Alternatively, you could read right to left (by switching the for loop to go from Ubound(aryFilePath) to 0, but that carries risks too).

Hope this helps.

[bstephens]

Thanks Frosty, the below code accomplished what I was trying to do, luckily the organization of the directories is very static. One thing, I forgot to add, but which the below handles is that sometimes the client number is expressed with an .xx as the last two elements (so to use an example) "4400.xx" or "75105.xx", so I had to factor that in too.

The below works, I guess it also shows my skill level (pretty wacky), let me know if you have suggestions to improve it/clean it up.

For any who are interested, here is also the field code reference I am actually using in the document


{ CREATEDATE \@ “yyyy” \* MERGEFORMAT}-{ DOCVARIABLE varClientNumber \* MERGEFORMAT}-{ DOCVARIABLE varDocNumber \* MERGEFORMAT }

'Writes a custom document variable for the client number

Sub WriteVariableClientNumber()

Dim vPath As Variant
Dim sName As String
Dim sName2 As String
Dim oVars As Variables
Dim oSection As Section
Dim oHeader As HeaderFooter
Dim oFooter As HeaderFooter
Dim oField As Field
Set oVars = ActiveDocument.Variables

Var2 = MatchingSubstring(ReverseString(ActiveDocument.Path), "??.####*")
If Right(Var2, 1) = "\" Then
Var2 = (Left(Var2, Len(Var2) - 1))
ElseIf Var2 = "" Then
With ActiveDocument
Var2 = Left(ReverseString(Mid(.Path, InStr(.Path, "\"), Len(.Path))), Len(.Path) - 3)
End With
End If

With ActiveDocument
If Len(.Path) = 0 Then .Save
vPath = Split(.FullName, "\")
sName = vPath(UBound(vPath) - 1)
sName = ReverseString(Var2)
sName2 = Left(.Name, InStrRev(.Name, ".") - 1)

oVars("varClientNumber").Value = sName
oVars("varDocNumber").Value = sName2

For Each oField In .Fields
If oField.Type = wdFieldDocVariable Then
oField.Update
End If
Next oField
For Each oSection In ActiveDocument.Sections
For Each oHeader In oSection.Headers
If oHeader.Exists Then
For Each oField In oHeader.Range.Fields
If oField.Type = wdFieldDocVariable Then
oField.Update
End If
Next oField
End If
Next oHeader
For Each oFooter In oSection.Footers
If oFooter.Exists Then
For Each oField In oFooter.Range.Fields
If oField.Type = wdFieldDocVariable Then
oField.Update
End If
Next oField
End If
Next oFooter
Next oSection
End With
End Sub

'Pattern matching function
Function MatchingSubstring(InputString As String, PatternString As String, _
Optional returnLength As Double = -1, Optional Incidence As Long) As String
Dim i As Long
If returnLength < 0 Then returnLength = Len(PatternString)
If Incidence < 1 Then Incidence = 1
For i = 1 To Len(InputString)
If Mid(InputString, i) Like PatternString & "*" Then
Incidence = Incidence - 1
If Incidence = 0 Then
MatchingSubstring = Mid(InputString, i, returnLength)
End If
End If
Next i
End Function

'Reverses a string
Public Function ReverseString(ByVal InputString As String) _
As String

Dim lLen As Long, lCtr As Long
Dim sChar As String
Dim sAns As String

lLen = Len(InputString)
For lCtr = lLen To 1 Step -1
sChar = Mid(InputString, lCtr, 1)
sAns = sAns & sChar
Next

ReverseString = sAns

End Function