Left position property of Range in Word doc?

[realbear]

:think: HI
I have coded some VBA to scan through a Word document, defining .Start and .End of ranges in which to look at the textual content and possibily change the Formatting.
Everything functions very well, only sometimes, it scans text I didn't want it to scan. The substrate document is essentially laid out in 3 columns - though only by tabs (as a by product of publishing an MS Access Report in Word).
What would help would be a way to know the Left position of any range of text (it is only text in the right hand column that I might want to want to format: i.e. if the Left postion is large enough)

Is there any way to know the absolute Left position of a Range in a Word document?

Hope someone can help

realbear

[macropod]

Hi realbear,

Perhaps you could give some more detail on what it is you're trying to do, plus the code you've developed so far.

FWIW, since you don't have real columns, but just tab-delimited text, you can't test for columns per se. With up to 3 'columns' of data you could, however, simulate a column test by testing the number of tabs either side of the string you're looking for. For example a string followed by a tab but not preceded by one must be in the left 'column'.

[realbear]

:cloud9:
Hi

Herewith some code that analyses and colours in a Word document that demarks the start of some children with the ` character with each child (including the last in the sequence) ending in a semi colon ;

I attach some sample data (the original would be HIGHLY confidential - pathologically so!). I have also since decided that I can change the MS Access report (generating the sample data) to include a flag character in the partner's (e.g. ? ) which, if found in the range short circuits the ColourInKids() procedure
Dim doc As Range, KidsStart As Long, KidsEnd As Long
Sub ColouredKids()
Set doc = ActiveDocument.Range
ScourAllKids
End Sub
Sub ScourAllKids()
Dim KidBlip As Range
Set KidBlip = ActiveDocument.Range
KidBlip.Find.Execute findtext:="`"
While KidBlip.Find.Found
KidsStart = KidBlip.Start + 1
EstablishExtentOfKids
ColourInKids
KidBlip.Find.Execute findtext:="`"
Wend
GetRidOf "`;"
GetRidOf "`"
ColourSpecificText "17+", wdViolet
ColourSpecificText "12-16", wdBlue
ColourSpecificText "5-11", wdGreen
ColourSpecificText "under 5s", wdRed

End Sub
Sub EstablishExtentOfKids() 'look for NEXT Blip
Dim Kids As Range
Set Kids = ActiveDocument.Range(KidsStart, doc.End)
Kids.Find.Execute findtext:="`"
'if THERE say end of Kids is JUST BEFORE it
If Kids.Find.Found Then
KidsEnd = Kids.Start - 1
Else 'if NOT THERE say end of Kids is end of doc
KidsEnd = doc.End
End If
End Sub
Sub ColourInKids()
Dim Kids As Range, NextKid As Range, strKidDOB, KidDOB As Date
Dim AnyMorekids As Boolean
Set NextKid = ActiveDocument.Range(doc.Start, doc.Start)
AnyMorekids = True
While AnyMorekids
Set NextKid = GetNextKid()
If Not NextKid Is Nothing Then
'If InStr(1, NextKid.Text, "NANCY 31/07/1990") Then Stop
strKidDOB = FindDateof(NextKid)
KidDOB = CDate(strKidDOB)
NextKid.Font.ColorIndex = AgeRangeColour(KidDOB)
KidsStart = NextKid.End + 1 'IIf(NextKid.End < doc.End - 1, NextKid.End + 1, doc.End - 2)
Else
If KidsEnd < doc.End Then
Set NextKid = ActiveDocument.Range(KidsEnd, KidsEnd)
AnyMorekids = NextKid.Start < KidsEnd
Else
AnyMorekids = False
End If
End If

Wend
End Sub
Function GetNextKid()
Dim SemiStart As Long, semicolon As Range
Set semicolon = ActiveDocument.Range(KidsStart, KidsEnd)
semicolon.Find.Execute findtext:=";"
If semicolon.Find.Found Then
Set GetNextKid = ActiveDocument.Range(KidsStart, semicolon.Start)
Else
Set GetNextKid = Nothing
End If
End Function
Function FindDateof(kid As Range)
Dim NextWd As Range, w As Long, wd As String
For w = 1 To kid.Words.Count
wd = kid.Words(w)
If IsNumeric(wd) Then
If kid.Words.Count - w >= 3 Then
If NextFourWdsMakesDate(kid, w) Then
FindDateof = FiveWdsStartingAt(w, kid)
Exit Function
End If
End If
End If
Next
End Function
Function NextFourWdsMakesDate(kid As Range, w As Long)
NextFourWdsMakesDate = kid.Words(w + 1) & kid.Words(w + 3) = "//" And IsNumeric(kid.Words(w + 2) & kid.Words(w + 4))
End Function
Function FiveWdsStartingAt(w As Long, kid As Range)
FiveWdsStartingAt = kid.Words(w) & kid.Words(w + 1) & kid.Words(w + 2) & kid.Words(w + 3) & kid.Words(w + 4)
End Function
Function AgeRangeColour(DOB As Date) As Long
Dim DOBasDaysAgo As Long
DOBasDaysAgo = CLng(Date - DOB)
If DOBasDaysAgo >= 17 * 365 Then
AgeRangeColour = wdViolet
Else
If DOBasDaysAgo < 17 * 365 And DOBasDaysAgo >= 12 * 365 Then
AgeRangeColour = wdBlue
Else
If DOBasDaysAgo < 12 * 365 And DOBasDaysAgo >= 5 * 365 Then
AgeRangeColour = wdGreen
Else
AgeRangeColour = wdRed
End If
End If
End If
End Function
Sub GetRidOf(old_text)
With ActiveDocument.Range.Find
.Font.ColorIndex = wdAuto
.Text = old_text
'Match whole word
.MatchWholeWord = True
'Just stop if not found by end of document
.Wrap = wdFindStop
.Replacement.Text = ""
'Replace All of them
.Execute Replace:=wdReplaceAll
End With 'ActiveDocument.Range.Find
End Sub
Sub ColourSpecificText(subj_text, clr)
With ActiveDocument.Range.Find
.Font.ColorIndex = wdAuto
.Text = subj_text
.MatchCase = True
'Match whole word only if not looking for two words
.MatchWholeWord = InStr(1, subj_text, " ", _
vbBinaryCompare) = 0
'Just stop if not found by end of document
.Wrap = wdFindStop
'replace as bold blue version
.Replacement.Text = subj_text
.Replacement.Font.Bold = True
.Replacement.Font.ColorIndex = clr
'Replace All of them
.Execute Replace:=wdReplaceAll
End With 'ActiveDocument.Range.Find
End Sub

[macropod]

Hi realbear,

OK, I see a document and a bunch of code, but you haven't said exactly what isn't working properly (ie what effect isn't being applied consistently) and which module in your code is the one you're running at the time.

[realbear]

:hi:
Hi
BTW I have just noticed that there are really FIVE column - not three.

The idea is to publish the MS Access report in Word and then, when in Word (with the VBA code, here, in Word's Normal) I would run macro "ColouredKids".

The routine ColouredKids() completes successfully and colours the children (in "column five") according to the found and analysed date of birth, takes out some of the demarkation characters (e.g. `; and ` ) and colour codes the report's grouping footer (there are other pages of other caravan sites) so that the human reader can use it as a colour key to pick out children (in "column five") of particular age groups.

The problem is that the MS Access report has a text box for Partners (in "column four") with the "Can grow" property set to true: if the entry is long enough it will go to the next line and, potentially, become includable with a multiline entry for the children (in "column five"). The VBA code, here, would also, quite likely, get the colour coding wrong as the partner's date of birth will be used to determine the colour. In the sample data, this has happened for the partner on plots 6 and 15.

Attempts to put everything in columns proved highly unsatisfactory. One thing I notice is that, where the partner stays on one line, a Line Feed to the next line of children results in a great long tab of 11cm or so. Should a partner wrap to an addtional line, the resulting Line Feed would be much less (6.5 cm or so).

The routine ColourInKids() needs to do a concurrent analysis of the paragrahs in the global range Kids [ set in the routine EstablishExtentOfKids() ]. Where a tabstop's .Position property equates to less than 11cm, ColourInKids' code needs to split NextKid into two ranges; the first range would end at the Line Feed; the second range would end where NextKid did; the START of at the second range would be determined by looking for a tabstop with a .Position equating to at least 11cm.

I will have play (in a while) with the above concept.

Regards

realbear

[macropod]

Hi realbear,

Here's a workaround that should actually make your document's layout more consistent:
1. Format the paragraphs with a hanging indent at 11.2cm
2. Insert hard spaces (chr 160) between each child's name & DOB
3. Don't insert a new line when there are too many children to fit on one line. The wrapping and space controls will take care of that, keeping all children on one logical line even when they span multiple printed lines.

[realbear]

Macropod
In generating a Rich Text File from an MS Access Report (and then Saving As a Word document) the only feature of your workaround that I could implement was No 2: the hard spacing (chr 160) between each child's name & DOB.
Complex though my code is, it is less involved than trying to colur code the children dynamically, in the MS Access Report.
I looked into all this again and concluded that the child's DOB always appears hard up against the trailing semi colon. Therefore I rewrote Function FindDateof() to read the last five words before the semi colon:
Function FindDateof(Kid As Range)
Dim NextWd As Range, w As Long, wd As String
Dim DateRange As Range, DateStartRg As Range, DateEndRg As Range
If Kid.Words.Count > 1 Then
Set DateRange = ActiveDocument.Range(Kid.End, Kid.End)
Set DateStartRg = DateRange.Previous(wdWord, 5)
Set DateEndRg = DateRange.Previous(wdWord, 1)
Set DateRange = ActiveDocument.Range(DateStartRg.Start, DateEndRg.End)
FindDateof = DateRange.Text
Else
FindDateof = ""
End If
End FunctionFunctions NextFourWdsMakesDate() and FiveWdsStartingAt() are no longer used. Also, routine ColourInKids needs to check whether a date was foundSub ColourInKids()
Dim Kids As Range, NextKid As Range, strKidDOB, KidDOB As Date
Dim AnyMorekids As Boolean
Set NextKid = ActiveDocument.Range(doc.Start, doc.Start)
AnyMorekids = True
While AnyMorekids
Set NextKid = GetNextKid()
If Not NextKid Is Nothing Then
'If InStr(1, NextKid.Text, "NANCY 31/07/1990") Then Stop
NextKid.Select
strKidDOB = FindDateof(NextKid)
If strKidDOB <> "" Then
KidDOB = CDate(strKidDOB)
NextKid.Font.ColorIndex = AgeRangeColour(KidDOB)
PossiblyBlackenPartner NextKid
End If
KidsStart = NextKid.End + 1 'IIf(NextKid.End < doc.End - 1, NextKid.End + 1, doc.End - 2)
Else
If KidsEnd < doc.End Then
Set NextKid = ActiveDocument.Range(KidsEnd, KidsEnd)
AnyMorekids = NextKid.Start < KidsEnd
Else
AnyMorekids = False
End If
End If

Wend
End SubIncluded in Range NextKid is possibly some partner information (though the DOB will no longer be utilised by mistake). Routine PossiblyBlackenPartner checks if Range NextKid spans more than one line and short circuits if that second line has only one TabStop (meaning that the Partner does NOT span more than one line). The routine searches back from the end of Range NextKid until a TabStop is found and then re-colours the text black from the beginning of the second line to this TabStopSub PossiblyBlackenPartner(NextKid As Range)
Dim SecondLine As Paragraph, ParaRange As Range
Dim BlackenRange As Range
If NextKid.Paragraphs.Count > 1 Then
Set SecondLine = NextKid.Paragraphs(2)
If SecondLine.TabStops.Count > 1 Then
Set ParaRange = ActiveDocument.Range(NextKid.End, NextKid.End)
While Not ParaRange.Text = Chr(9)
Set ParaRange = ParaRange.Previous(wdWord, 1)
Wend
Set BlackenRange = ActiveDocument.Range(SecondLine.Range.Start, ParaRange.End)
BlackenRange.Font.ColorIndex = wdBlack
End If
End If

End SubThis new code achieves my objective (of colour coding the kids [only] by age group) without being particularly general purpose: the text is published from MS Access which does not seem very customizable. That new code in fullDim doc As Range, KidsStart As Long, KidsEnd As Long
Sub ColouredKids()
Set doc = ActiveDocument.Range
ScourAllKids
End Sub
Sub ScourAllKids()
Dim KidBlip As Range
Set KidBlip = ActiveDocument.Range
KidBlip.Find.Execute findtext:="`"
While KidBlip.Find.Found
KidsStart = KidBlip.Start + 1
EstablishExtentOfKids
ColourInKids
KidBlip.Find.Execute findtext:="`"
Wend
GetRidOf "`;"
GetRidOf "`"
ColourSpecificText "17+", wdViolet
ColourSpecificText "12-16", wdBlue
ColourSpecificText "5-11", wdGreen
ColourSpecificText "under 5s", wdRed

End Sub
Sub EstablishExtentOfKids() 'look for NEXT Blip
Dim Kids As Range
Set Kids = ActiveDocument.Range(KidsStart, doc.End)
Kids.Find.Execute findtext:="`"
'if THERE say end of Kids is JUST BEFORE it
If Kids.Find.Found Then
KidsEnd = Kids.Start - 1
Else 'if NOT THERE say end of Kids is end of doc
KidsEnd = doc.End
End If
End Sub
Sub ColourInKids()
Dim Kids As Range, NextKid As Range, strKidDOB, KidDOB As Date
Dim AnyMorekids As Boolean
Set NextKid = ActiveDocument.Range(doc.Start, doc.Start)
AnyMorekids = True
While AnyMorekids
Set NextKid = GetNextKid()
If Not NextKid Is Nothing Then
strKidDOB = FindDateof(NextKid)
If strKidDOB <> "" Then
KidDOB = CDate(strKidDOB)
NextKid.Font.ColorIndex = AgeRangeColour(KidDOB)
PossiblyBlackenPartner NextKid
End If
KidsStart = NextKid.End + 1 'IIf(NextKid.End < doc.End - 1, NextKid.End + 1, doc.End - 2)
Else
If KidsEnd < doc.End Then
Set NextKid = ActiveDocument.Range(KidsEnd, KidsEnd)
AnyMorekids = NextKid.Start < KidsEnd
Else
AnyMorekids = False
End If
End If

Wend
End Sub
Sub PossiblyBlackenPartner(NextKid As Range)
Dim SecondLine As Paragraph, ParaRange As Range
Dim BlackenRange As Range
If NextKid.Paragraphs.Count > 1 Then
Set SecondLine = NextKid.Paragraphs(2)
If SecondLine.TabStops.Count > 1 Then
Set ParaRange = ActiveDocument.Range(NextKid.End, NextKid.End)
While Not ParaRange.Text = Chr(9)
Set ParaRange = ParaRange.Previous(wdWord, 1)
Wend
Set BlackenRange = ActiveDocument.Range(SecondLine.Range.Start, ParaRange.End)
BlackenRange.Font.ColorIndex = wdBlack
End If
End If

End Sub
Function GetNextKid()
Dim SemiStart As Long, semicolon As Range
Set semicolon = ActiveDocument.Range(KidsStart, KidsEnd)
semicolon.Find.Execute findtext:=";"
If semicolon.Find.Found Then
Set GetNextKid = ActiveDocument.Range(KidsStart, semicolon.Start)
Else
Set GetNextKid = Nothing
End If

End Function
Function FindDateof(Kid As Range)
Dim NextWd As Range, w As Long, wd As String
Dim DateRange As Range, DateStartRg As Range, DateEndRg As Range
If Kid.Words.Count > 1 Then
Set DateRange = ActiveDocument.Range(Kid.End, Kid.End)
Set DateStartRg = DateRange.Previous(wdWord, 5)
Set DateEndRg = DateRange.Previous(wdWord, 1)
Set DateRange = ActiveDocument.Range(DateStartRg.Start, DateEndRg.End)
FindDateof = DateRange.Text
Else
FindDateof = ""
End If
End Function
Function AgeRangeColour(DOB As Date) As Long
Dim DOBasDaysAgo As Long
DOBasDaysAgo = CLng(Date - DOB)
If DOBasDaysAgo >= 17 * 365 Then
AgeRangeColour = wdViolet
Else
If DOBasDaysAgo < 17 * 365 And DOBasDaysAgo >= 12 * 365 Then
AgeRangeColour = wdBlue
Else
If DOBasDaysAgo < 12 * 365 And DOBasDaysAgo >= 5 * 365 Then
AgeRangeColour = wdGreen
Else
AgeRangeColour = wdRed
End If
End If
End If
End Function
Sub GetRidOf(old_text)
With ActiveDocument.Range.Find
.Font.ColorIndex = wdAuto
.Text = old_text
'Match whole word
.MatchWholeWord = True
'Just stop if not found by end of document
.Wrap = wdFindStop
.Replacement.Text = ""
'Replace All of them
.Execute Replace:=wdReplaceAll
End With 'ActiveDocument.Range.Find
End Sub
Sub ColourSpecificText(subj_text, clr)
With ActiveDocument.Range.Find
.Font.ColorIndex = wdAuto
.Text = subj_text
.MatchCase = True
'Match whole word only if not looking for two words
.MatchWholeWord = InStr(1, subj_text, " ", _
vbBinaryCompare) = 0
'Just stop if not found by end of document
.Wrap = wdFindStop
'replace as bold blue version
.Replacement.Text = subj_text
.Replacement.Font.Bold = True
.Replacement.Font.ColorIndex = clr
'Replace All of them
.Execute Replace:=wdReplaceAll
End With 'ActiveDocument.Range.Find
End Sub
Hope some else might be able to adapt some/all of this

Regards

Realbear

[macropod]

Hi realbear,

Try modifying your macro so that it outputs the data to a document using a custom paper size that's sufficiently wider than your longest data stream to ensure each record is output on one line. Then, when you've finished outputting the records, change the paper size to match what you really want. Provided your paragraphs are formatted with the appropriate hanging indent, the 'overflow' should line up correctly. You should then be able to do your shading etc on the basis of each record constituting a logical line/paragraph.