VBA WORD looping trought sentences and lines of senteces - vba

Is that even possible?
EDIT: explain my self, and thinking in another aproach
I can loop trough letters, words and paragraphs, but not thought what I suppose should be sentences, and neither I can find any reference for lines.
As an image worth like a thousand words, I attach a picture to explain myself:
squared on black an example of text
squared on green what I success with the code bellow
squared in red, what I can figure out how to do
example of sentences coloured as mention, image as link as it is my first post
My purpose, is to highlight/mark/colour out those lines that do not fit in a single page width, as example squared in yellow. But not sure how should do event I can not achieve the easy ones.
Any help?
(been searching here and other places for like couple of hours without success)
If False Then ' Cool, letter by letter
With ActiveDocument
For i = 1 To .Characters.Count
.Characters(i).Font.Color = Int(Rnd * 1048576)
Next
End With
End If
If False Then ' Cool, word by word
With ActiveDocument
For i = 1 To .Words.Count
.Words(i).Font.Color = Int(Rnd * 1048576)
Next
End With
End If
If False Then ' :-( same as paragraph
With ActiveDocument
For i = 1 To .Sentences.Count
.Sentences(i).Font.Color = Int(Rnd * 1048576)
Next
End With
End If
If True Then ' Cool, paragraph by paragraph
With ActiveDocument
For i = 1 To .Paragraphs.Count
.Paragraphs(i).Range.Sentences(1).Font.Color = Int(Rnd * 1048576)
Next
End With
End If
NOTE + ADDs : explain my self, and thinking in another aproach
As some staid bellow, I explain myself, the overall purpose ids to identify “text lines that do not fit in one printing line”. It has something to do with writing poetry, if interested.
I guess I could also try to “locate each character” on the printing line, identify the “line-brake” character (that Word do not take into account to brake sentences), and color manually word by word / letter by letter.
But I neither have found on the character object, a property referring to the position in the printing view.

May be possible to optimize, but this works !!,, (thanks John Korchok)
For Each p In ActiveDocument.Paragraphs
first_word_of_paragraph = True
For Each w In p.Range.Words
If first_word_of_paragraph = True Then
first_word_of_paragraph = False
actual_line_vertical_start = w.Information(wdVerticalPositionRelativeToPage)
End If
If first_word_of_sentence = True Then
first_word_of_sentence = False
actual_line_vertical_start = w.Information(wdVerticalPositionRelativeToPage)
End If
If w.Text = "" Then
first_word_of_sentence = True
End If
If actual_line_vertical_start <> w.Information(wdVerticalPositionRelativeToPage) Then
w.HighlightColorIndex = wdRed
End If

Related

Set specific font size for Hebrew characters in Word in VBA

I am in need to modify this code which is made for Word 2007 to Word XP. I need to set size for hebrew text in document. It is mix of Central Europe words combined with hebrew. What I need is hebrew text in bigger size. This contains only basic hebrew characters, no vowels. The non hebrews characters can be English or Czech (http://www.biega.com/special-char.html), the hebrew Chars are from 1488 to 1514.
But I could not run the code send here Flag special characters in document using VBA in Word in the answer as I got error (Range?) object not selected.
Sub test()
'Options.DefaultHighlightColorIndex = wdNoHighlight
'Range.HighlightColorIndex = wdNoHighlight ' used for testing to clear Highlight
Dim r As Range, t As Double: t = Timer
Application.ScreenUpdating = False
For Each r In Range.Characters ' For Each r In Range.Words is somehow about 2 times slower than .Characters
checkRange r
Next
Application.ScreenUpdating = True
Debug.Print Timer - t; Range.Words.Count; Range.Characters.Count; Range.End ' " 3.15625 8801 20601 20601 "
End Sub
Sub checkRange(r As Range)
Dim b() As Byte, i As Long, a As Long
b = r.Text ' converts the string to byte array (2 or 4 bytes per character)
'Debug.Print "'" & r & "'"; r.LanguageID; r.LanguageIDFarEast; r.LanguageIDOther
For i = 1 To UBound(b) Step 2 ' 2 bytes per Unicode codepoint
If b(i) > 0 Then ' if AscW > 255
a = b(i): a = a * 256 + b(i - 1) ' AscW
Select Case a
Case &H1F00 To &H1FFF: r.HighlightColorIndex = wdBlue: Exit Sub ' Greek Extended
Case &H3040 To &H30FF: r.HighlightColorIndex = wdPink: Exit Sub ' Hiragana and Katakana
Case &H4E00 To 40959: r.HighlightColorIndex = wdGreen: Exit Sub ' CJK Unified Ideographs
Case 55296 To 56319: ' ignore leading High Surrogates ?
Case 56320 To 57343: ' ignore trailing Low Surrogates ?
Case Else: r.HighlightColorIndex = wdRed: Debug.Print Hex(a), r.End - r.Start ' other
End Select
End If
Next
End Sub
So I only need to select the size and make this working for Word XP. Any help?
Notice:
Whole document and the hebrew chars are written from left to right (when I typed hebrew in online keyboard, they were RTL, but after coping to Word they were LTR. But this was not problem, because I have copied/pasted them to display the hebrew word correctly. So they are in LTR in fact.
The error is because you haven't specified which object's range you want to process.
For Each r In Range.Characters
Needs to be qualified either as
For Each r In Selection.Range.Characters
or as
For Each r In ActiveDocument.Range.Characters
You could have answered this for yourself simply by looking up the online help for Range
NOTE:
Processing a document character by character is going to be a very long process. If the characters you want to process can be identified by language id you can speed up the process considerably.

Shapes.AddPicture in Word Table

I am using a Word table as a placeholder for images, where table cells contain only pictures and no text.
When inserting a picture into a Word table, I have no problems when inserting an Inline Shape. The picture appears into the expected cell. However, with the "equivalent" code which inserts the picture as a Shape, the shape does not always appear in the expected cell. So far, I have seen this problem in Word 2013, 32 bit version.
Sub test()
Dim s As Shape
Dim x As String
Dim f As String
Dim r As Long
Dim c As Long
Dim h As Single
Dim w As Single
Dim rng As Word.Range
Dim ins As Word.InlineShape
f = "file name of a picture, .bmp .jpg etc."
Word.Application.ScreenUpdating = False
If Selection.Information(wdWithInTable) Then
' insert a picture in a table cell
r = Selection.Information(wdStartOfRangeRowNumber)
c = Selection.Information(wdStartOfRangeColumnNumber)
With Selection.Tables(1).Cell(r, c)
Set rng = .Range
rng.collapse wdCollapseStart
.Range.Text = ""
h = .height
w = .width
End With
' Works reliably
Set s = Word.Selection.InlineShapes.AddPicture(f, False, True, rng).ConvertToShape
s.height = h
s.width = w
' Not at all reliable
' Set s = Word.ActiveDocument.Shapes.AddPicture(f, False, True, 0, 0, w, h, rng)
Else
' insert a picture at the cursor
h = 100
w = 100
Set s = Word.ActiveDocument.Shapes.AddPicture(f, False, True, 0, 0, w, h)
End If
Word.Application.ScreenUpdating = True
s.WrapFormat.Type = wdWrapInline
s.Title = "Title"
s.AlternativeText = "Some metadata"
End Sub
The idea is to select either a cell in a table in a document or somewhere on the page outside of the table. The outside of the table case works as expected where the picture appears at the cursor location.
To see the problem, start with a fresh document, single page, add a 3 x 3 table and deepen the rows a bit. Be sure to supply a file to insert, variable f. Select one of the cells, then run the code. This works correctly when the picture is inserted as an inline shape then immediately converted to a shape. That happens with this line:
Set s = Word.Selection.InlineShapes.AddPicture(f, False, True, rng).ConvertToShape
However, the preferred solution would be to insert a Shape from the beginning with code something like this:
Set s = Word.ActiveDocument.Shapes.AddPicture(f, False, True, 0, 0, w, h, rng)
The picture appears, but usually not in the expected location. It could be placed into a different cell or somewhere outside the table.
Is the rng argument to Shapes.AddPicture being ignored or mangled somehow?
Experimenting some more with the 3 x 3 table - adding pictures then setting every possible WrapFormat.Type (there are 8 possible values), I see that:
for every WrapFormat.Type except wdWrapInLine, picture insertion works correctly as long as they are done from left to right on a table row, and;
for every WrapFormat.Type without exception, when the row is initially empty, pictures inserted in columns 2 or 3 appear one column to the left.
Making the picture smaller, such as setting h = .height * 0.5 and w = .width * 0.5, has no effect on placement.
Thanks very much for any insight or elucidation.
The main problem appears to be about the pictures inserting in the wrong column. This would be because the "focus point" (location of the Range) of an empty table cell has its starting point in the previous cell. Doesn't really make a lot of sense, but that's how Word works...
Try collapsing the Range to the End, rather than the Start (wdCollapseEnd) in this extract from your code:
With Selection.Tables(1).Cell(r, c)
Set rng = .Range
rng.collapse wdCollapseEnd 'instead of wdCollapseStart
.Range.Text = ""
h = .height
w = .width
End With
In the end, selective usage of rng.collapse did the trick. I have yet to check whether this behaviour is the same in Word 2010 or 2016.
For the first shape anywhere in a table row, rng.collapse wdCollapseEnd.
For all subsequent shapes on that table row, rng.collapse wdCollapseBegin.
I used the following code to count up the shapes in table rows:
Dim numShapes() As Integer
Dim cel As Word.cell
ReDim numShapes(1 To Selection.Tables(1).Rows.Count)
For Each cel In Selection.Tables(1).Range.Cells
If cel.Range.ShapeRange.Count <> 0 Then
numShapes(cel.RowIndex) = numShapes(cel.RowIndex) + 1
End If
Next cel
and the check is simply
If numShapes(r) <> 0 Then
rng.collapse wdCollapseStart
Else
rng.collapse wdCollapseEnd
End If
where r is the row number from the first code example.
Initial experiments with merged cells suggest other problems...

Use Word Macro to Determine last character of Paragraph

I have been using this code to Bold-Underline all the headers in my word doc:
Sub Underline_Headers()
Dim p As Paragraph
For Each p In ActiveDocument.Paragraphs
If Len(p.Range.Text) < 70 Then
p.Range.Font.Underline = True
p.Range.Font.Bold = True
End If
Next p
End Sub
This works great - as long as every header is less than 70 characters long, and the paragraph underneath it is 70 or more characters.
But many times the header can be longer than 70 characters, and the paragraph under the header can be less than 70 characters.
However, the headers always never end with any punctuation, like a "." but the paragraphs underneath them always do.
I am trying to fix the code above to look for all paragraphs not ending in a "." and then Bold-Underline them. In other words, I want to change the rule.
I tried the only thing that made sense to me. The code did not break, but it ended up bold-underline the entire document:
Sub Underline_Headers()
Dim p As Paragraph
For Each p In ActiveDocument.Paragraphs
If Right(p.Range.Text,1) <> "." Then
p.Range.Font.Underline = True
p.Range.Font.Bold = True
End If
Next p
End Sub
This supposedly looks for all paragraphs where the last character is not ".", which if that worked, would isolate all the headers and only bold-underline them, but obviously that doesn't work.
The last character in every paragraph is a carriage return, Chr(13). The text ends one character before that. The code below also considers the possibility that someone ended a paragraph's text with one or more blank spaces. It takes the "cleaned" string and looks for the last character in a string of possible exceptions, like .?!. You can reduce this string to a single full stop or extend it to include more cnadidates for exception.
Private Sub UnderlineTitles()
Dim Para As Paragraph
Dim Txt As String
Application.ScreenUpdating = False
For Each Para In ActiveDocument.Paragraphs
Txt = Para.Range.Text
Txt = RTrim(Left(Txt, Len(Txt) - 1))
' you can extend the list to include characters like ")]}"
If InStr(".?!", Right(Txt, 1)) = 0 Then
' to choose a different style of underline, remove
' "= wdUnderlineSingle", type "=" and select from the dropdown
Para.Range.Font.Underline = wdUnderlineSingle
End If
Next Para
Application.ScreenUpdating = True
End Sub

VBA code in excel to made text between tags bold

I have a csv file which includes the html tags < b > and <\ b > to signify bold text. (I.e several words between these tags, in a longer block of text within the cell, should be bold). Is there a way using vba code in excel to strip the tags, and make the text between the tags bold?
Note - There are sometime multiple sets of tags within a given cell.
This should do what you want:
Sub BoldTags()
Dim X As Long, BoldOn As Boolean
BoldOn = False 'Default from start of cell is not to bold
For X = 1 To Len(ActiveCell.Text)
If UCase(Mid(ActiveCell.Text, X, 3)) = "<B>" Then
BoldOn = True
ActiveCell.Characters(X, 3).Delete
End If
If UCase(Mid(ActiveCell.Text, X, 4)) = "</B>" Then
BoldOn = False
ActiveCell.Characters(X, 4).Delete
End If
ActiveCell.Characters(X, 1).Font.Bold = BoldOn
Next
End Sub
Currently set to run on the activecell, you can just plop it in a loop to do a whole column. You can easily adapt this code for other HTML tags for Cell formatting (ie italic etc)
This was in the cell I tested on (minus the space after <): Sample < b>Te< /b>st of < B>bolding< /B> end
The result was: Sample Test of bolding end
Hope that helps

How to extract specific text from a cell?

In this case, I want to extract the beginning text in a cell and leave the remainder intact.
e.g. a series of cells contain:
2nd Unit. Miami
3rd Production Staff. Toronto
1st Ad. San Francisco
I want to break this up without using Text to columns as previous rows are formatted differently and these last few rows are outliers that I want to handle.
I thought Regular Expressions might do it, but that seems a bit complex.
My algorithm idea is:
1. grab the wanted text (what function or custom sub would do that?)
2. Past the text to it's new location
3. Cut the text from the cell, leaving the remaining text.
Seems simple but I'm still wending my way through VBA forest, and at the rate I'm going it's going to end up faster doing it by hand. But this seems like a good opportunity to learn some VBA tricks.
TIA
Update:
I want to take the text up to the ".\ " and move it to a different column, keeping the remainder where it is.
VBA is unnecessary. To get the text after .\ in cell A1: =MID(A1,FIND(".\",A1,1)+2,LEN(A1)) to get the text before .\ in A1: =LEFT(A1,FIND(".\",A1,1)-1).
As additional information, Find returns the placement in the string where .\ appears. It is the equivalent of InStr in VBA. If .\ is not in the cell, it will display #VALUE, because I didn't bother to add error checking.
Since you seem to want to modify the cell text in place, VBA will be required.
Inside a loop that sets cl to the cell to be processed:
str = cl.value
i = Instr(str, ".\")
cl = Trim(Mid$(str, i + 2)) ' assuming you want to exclude the ".\"
cl.Offset(0, 1) Trim(Left$(str, i - 1)) ' Places the original first part one cell to the right
For the sake of anyone who had this same question, here is the fully tested, working code.
Function RE6(strData As String) As String
Dim RE As Object, REMatches As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.MultiLine = False
.Global = False
.IgnoreCase = True
.Pattern = "[0-9][0-9][0-9][0-9]B"
RE6 = .test(strData)
End With
Set REMatches = RE.Execute(strData)
If REMatches.Count > 0 Then
RE6 = True
Else
RE6 = False
End If
End Function
Sub territory()
Dim strTest As String, str As String, cl As Range
strTest = ActiveCell.Value
Set cl = ActiveCell
If RE6(strTest) = True Then
str = cl.Value
i = InStr(str, ". ")
cl = Trim(Mid$(str, i + 2))
cl.Offset(0, 1) = Trim(Left(str, i - 1))
cl.Offset(0, 2) = "Instance"
MsgBox RE6(strTest)
End If
End Sub