#1
|
|||
|
|||
Move Selection to the next Column on a Page (Not a table)
Hi, Ive written some code which changes the colour of certain selected text.
The page of each document has either one or two columns. The documents are only one page long. The code works beautifully as it moves down the first column of text, but wont move up to the top of the second column to start editing that piece of text. I cant find any code that identifies the number of columns, and then moves the selection from the bottom of the first column (when it gets there), to the top of the second column so it can start the process again. Appreciate your help! Here is my code: Sub ColourText() Dim numOfLines As Integer Dim numOfColumns As Integer Dim numOfSpaces As Integer Dim numOfChar As Integer Dim ArraySpaces() As String Dim x1 As Integer 'Count the number of non blank lines in current document numOfLines = ActiveDocument.BuiltInDocumentProperties("NUMBER OF LINES") 'Move to start of document Selection.HomeKey Unit:=wdStory 'Start the loop - looping once for each line For x1 = 1 To numOfLines 'Move to start of line Selection.HomeKey Unit:=wdLine 'Select entire line Selection.EndKey Unit:=wdLine, Extend:=wdExtend If Len(Selection.Range.Text) > 1 Then 'if 1 ignore as paragraph return only 'check to see if current line is likely to be Chords - ie if it contains lots of spaces ArraySpaces = Split(Selection.Range.Text, " ") numOfSpaces = UBound(ArraySpaces) 'count characters in selection numOfChar = Len(Selection.Range.Text) - numOfSpaces If (numOfSpaces > numOfChar) Or numOfChar < 4 Then ' likely not to be text so should be chords 'colour this line blue Selection.Font.TextColor.RGB = RGB(0, 0, 255) Else 'colour this line black Selection.Font.TextColor.RGB = RGB(0, 0, 0) End If End If If InStr(1, Selection.Range.Text, "Chorus") Then Selection.Range.HighlightColorIndex = wdYellow Selection.Font.Bold = True End If 'Move to the next part of the loop ##but wont do this when more than 1 column of text Selection.MoveDown Unit:=wdLine, count:=1 Next x1 MsgBox ("Setup completed") End Sub |
#2
|
||||
|
||||
'Lines' are a vague concept in Word, especially in a document that is dynamically formatted and doubly so when there are columns.
I won't pretend to know what your document looks like and so I can't test your macro to see what it does in practice, but as you have discovered, moving down by lines ignores the presence of a second column of text and continues to the next page. You need to move right to move the next column. I suppose you could test whether the page has changed each time you move down and then move back and move right to the start of the next column (that will also take you to the start of the next page) e.g. as follows but whether it will work in the context of your macro is hard to ascertain Code:
'Move to the next part of the loop ##but wont do this when more than 1 column of text iPage = Selection.Information(wdActiveEndPageNumber) Selection.MoveDown Unit:=wdLine, Count:=1 If Selection.Information(wdActiveEndPageNumber) > iPage Then Selection.MoveUp Unit:=wdLine, Count:=1 Selection.EndKey Unit:=wdLine, Extend:=wdExtend Selection.MoveRight Unit:=wdCharacter End If
__________________
Graham Mayor - MS MVP (Word) (2002-2019) Visit my web site for more programming tips and ready made processes www.gmayor.com |
#3
|
|||
|
|||
Move Selection to the next Column on a Page (Not a table)
Thanks Graham. From your response I gather there is no way to tell what the bottom line of the first column is? I have included an example of a document if that helps further.
My numOfLines variable tells me the aggregate number of lines in both columns accurately, but I would prefer to use a loop that redirected to Selection.MoveRight Unit:=wdCharacter, once I hit the bottom of the first column. Thanks |
#4
|
|||
|
|||
Guitar, this is what I use for my sheet music. Not perfect but does a lot of the work. You can add more chords. I'm sure one of the guys could simplify it.
Code:
Sub ChangeColorTargets() Dim range As range Dim i As Long Dim TargetList TargetList = Array("A ", "Am", "E7", "A#", "A7", "Ab", "B ", "Bm ", "B7", _ "C ", "Cm ", "D ", "Dm ", "E ", "Em ", " C", "C#", "Db", "D#", "E#", "Eb", "Fb", " F", "F#", "Gb", " G ", "G#", "Ab", "B#", "Bb") '... Add additional words to this line at the end, each word to be separated with , "[WORD]" ' if you run out on the second line, end it with , "[WORD]" _ and continue on next line For i = 0 To UBound(TargetList) Set range = ActiveDocument.range With range.Find .Text = TargetList(i) .Format = True .MatchCase = True .MatchWholeWord = True .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False Do While .Execute(Forward:=True) = True range.Font.TextColor.RGB = RGB(0, 0, 255) Loop End With Next Call HighlightTargets End Sub Sub HighlightTargets() Dim range As range Dim i As Long Dim TargetList TargetList = Array("[Chorus]", "[Verse]", "[Bridge]", "[Solo]") '... Add additional words to this line at the end, each word to be separated with , "[WORD]" ' if you run out on the second line, end it with , "[WORD]" _ and continue on next line For i = 0 To UBound(TargetList) Set range = ActiveDocument.range With range.Find .Text = TargetList(i) .Format = True .MatchCase = True .MatchWholeWord = True .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False Do While .Execute(Forward:=True) = True range.HighlightColorIndex = wdYellow Loop End With Next End Sub |
#5
|
|||
|
|||
Hi Kilroy thanks for your thoughts- seems we have similar tastes! The problem for me is that I use every conceivable chord variation incl diminished, sus, half diminished, 6ths etc etc and therefore would be having potentially 100+ chord variations in the targetlist array. Instead of using that technique I've found that I can identify which line has chords, and which has lyrics through a ratio of spaces to total characters in the line. Works like a treat as I separate my chords with spaces. I'll try using your approach re setting range as this is where my code is going wrong as it won't find the second column.
Have you written any code for transposing? Love to see it if you have thanks? Recently my computer crashed and I lost my 'tricky' code for transposing, and formatting, as the location for saving macros was not being backed up - very frustrating as all my docs etc are religiously backed up. Didn't realise they were kept in some obscure folder separate to the actual document. |
#6
|
|||
|
|||
I thought about using spaces and the following code works for that but there are instances where even the lyric lines have many spaces at the start of the line like in the chorus the line "Yeah I love....". If you were to use tab and no more than 3 spaces to align lyrics with chords and use tabs for spacing the Title then the following works. Also keep in mind that the code looks for 4 spaces so when you have sections like "Solo" or "Bridge" where you only list the chords and don't need to align with lyrics those types of progressions need to have at least one place where you use 4 spaces in a row.
This is a temporary fix until you figure out the ratio thing, which is way above me. Looking forward to seeing the solution. Also I'm very interested in the transposing code you spoke of. Code:
Sub ChordFont() Dim oRng As range Set oRng = ActiveDocument.range With oRng.Find Do While .Execute(FindText:=" ") oRng.Start = oRng.Sentences(1).Start oRng.End = oRng.Paragraphs(1).range.End oRng.Font.TextColor.RGB = RGB(0, 0, 255) oRng.Collapse 0 Loop End With lbl_Exit: Set oRng = Nothing Call HighlightChorus Exit Sub End Sub Sub HighlightChorus() Dim oRng As range Set oRng = ActiveDocument.range With oRng.Find Do While .Execute(FindText:="[Chorus]") oRng.Start = oRng.Sentences(1).Start oRng.End = oRng.Paragraphs(1).range.End oRng.HighlightColorIndex = wdYellow oRng.Collapse 0 Loop End With lbl_Exit: Set oRng = Nothing Exit Sub End Sub |
#7
|
|||
|
|||
Check this version out.
Code:
Sub ColourText2() Dim numOfLines As Integer Dim numOfColumns As Integer Dim numOfSpaces As Integer Dim numOfChar As Integer Dim ArraySpaces() As String Dim x1 As Integer With Selection.PageSetup.TextColumns .SetCount NumColumns:=1 .EvenlySpaced = True .LineBetween = False End With 'Count the number of non blank lines in current document numOfLines = ActiveDocument.BuiltInDocumentProperties("NUMBER OF LINES") 'Move to start of document Selection.HomeKey Unit:=wdStory Selection.WholeStory 'Start the loop - looping once for each line For x1 = 1 To numOfLines 'Move to start of line Selection.HomeKey Unit:=wdLine 'Select entire line Selection.EndKey Unit:=wdLine, Extend:=wdExtend If Len(Selection.Range.Text) > 1 Then 'if 1 ignore as paragraph return only 'check to see if current line is likely to be Chords - ie if it contains lots of spaces ArraySpaces = Split(Selection.Range.Text, " ") numOfSpaces = UBound(ArraySpaces) 'count characters in selection numOfChar = Len(Selection.Range.Text) - numOfSpaces If (numOfSpaces > numOfChar) Or numOfChar < 4 Then ' likely not to be text so should be chords 'colour this line blue Selection.Font.TextColor.RGB = RGB(0, 0, 255) Else 'colour this line black Selection.Font.TextColor.RGB = RGB(0, 0, 0) End If End If If InStr(1, Selection.Range.Text, "Chorus") Then Selection.Range.HighlightColorIndex = wdYellow Selection.Font.Bold = True End If 'Move to the next part of the loop ##but wont do this when more than 1 column of text Selection.MoveDown Unit:=wdLine, Count:=1 'Selection.Columns.Select Next x1 With Selection.PageSetup.TextColumns .SetCount NumColumns:=2 .EvenlySpaced = True .LineBetween = False .Width = InchesToPoints(3.49) End With MsgBox ("Setup completed. Rock on Bud!") End Sub |
#8
|
||||
|
||||
IMHO, this would be a lot simpler if you used Styles for the formatting. As far as I can tell, too, you don't need any complicated arrays. Try:
Code:
Sub Demo() Application.ScreenUpdating = False Dim i As Long, StrTmp As String: Const StrAcc As String = "m7#b" On Error Resume Next With ActiveDocument .Styles.Add "Chord", wdStyleTypeParagraph 'wdStyleTypeCharacter .Styles("Chord").Font.ColorIndex = wdBlue End With On Error GoTo 0 With ActiveDocument.Range With .Find .ClearFormatting .Replacement.ClearFormatting .Text = "<[A-F][m7#b ^13]" .Replacement.Text = "" .Wrap = wdFindStop .Format = False .MatchWildcards = True .Execute End With Do While .Find.Found If .Paragraphs(1).Style = "Chord" Then .End = .Paragraphs(1).Range.End Else StrTmp = Split(.Paragraphs(1).Range.Text, vbCr)(0) For i = 1 To Len(StrAcc) StrTmp = Replace(StrTmp, Mid(StrAcc, i, 1), "") Next For i = 1 To 7 StrTmp = Replace(StrTmp, Chr(64 + i), "") Next StrTmp = Trim(StrTmp) If StrTmp = "" Then .Paragraphs(1).Style = "Chord" End If .Collapse wdCollapseEnd .Find.Execute Loop End With With ActiveDocument.Range With .Find .ClearFormatting .Replacement.ClearFormatting .Text = "\[[!\[]@\]" .Replacement.Text = "" .Wrap = wdFindStop .Format = False .MatchWildcards = True .Execute End With Do While .Find.Found Select Case .Text Case "[Chorus]": .HighlightColorIndex = wdYellow: .Style = wdStyleStrong Case "[Verse]": .HighlightColorIndex = wdNoHighlight: .Font.Reset Case "[Bridge]": .HighlightColorIndex = wdBrightGreen: .Style = wdStyleStrong End Select .Collapse wdCollapseEnd .Find.Execute Loop End With Application.ScreenUpdating = True End Sub
__________________
Cheers, Paul Edstein [Fmr MS MVP - Word] |
Thread Tools | |
Display Modes | |
|
Similar Threads | ||||
Thread | Thread Starter | Forum | Replies | Last Post |
Insert Table To Multi Column Page | mertdogan | Word Tables | 2 | 08-03-2017 03:46 PM |
Center a table column on page | Mutak94 | Word Tables | 1 | 09-12-2014 02:52 PM |
Selection of all Text for a specific page in word is spanning selection across pages | ramsgarla | Word VBA | 9 | 12-05-2012 03:23 AM |
Columns. How to move the left column so it's to the right of the 'right' column ? | Vit | Word | 9 | 11-21-2012 12:57 PM |
Long, 3 Column Table - Can I make Fit Into Page Columns? | Rigwald | Word Tables | 9 | 08-07-2012 08:14 PM |