I am trying to replace all carriage returns with the ¶ symbol to make the carriage returns visible in PPT (only word has a button for this, PPT does not). Since the "replace" function only finds the first occurrence, I need to loop through each string to find the next occurrences.
I am using the sample code from the MS "replace" function, but the code only finds SOME of the carriage returns but not ALL of them. What am I missing?
Thanks!
VBA code:
If .HasTextFrame Then
If .TextFrame.HasText Then
'MsgBox (.TextFrame.TextRange.Text)
Set oTxtRng = oSh.TextFrame.TextRange
'Set oTmpRng = oTxtRng
Set oTmpRng = oTxtRng.Replace(FindWhat:=Chr$(13), _
Replacewhat:=("¶"))
Do While Not oTmpRng Is Nothing
Set oTxtRng = oTxtRng.Characters(oTmpRng.Start + oTmpRng.Length + 1, _
oTxtRng.Length)
charCount = charCount + 1
'MsgBox (oTxtRng.Text)
Set oTmpRng = oTxtRng.Replace(FindWhat:=Chr$(13), Replacewhat:=("¶"))
Loop
End If
End If
PPT uses different line ending characters, depending on version and what type of text box it is even within one version; paragraph endings are different from linebreaks also. This page on my PPTFAQ site should help:
Paragraph endings and line breaks
http://www.pptfaq.com/FAQ00992_Paragraph_endings_and_line_breaks.htm
I experienced the same issue with the Microsoft Sample code. It seems to miss certain occurrences (although consistently). Anyway, to fix it, instead of redefining oTxtRng, I instead changed it to use the After:= parameter. That seems to work reliably:
If .HasTextFrame Then
If .TextFrame.HasText Then
'MsgBox (.TextFrame.TextRange.Text)
Set oTxtRng = oSh.TextFrame.TextRange
'Set oTmpRng = oTxtRng
Set oTmpRng = oTxtRng.Replace(FindWhat:=Chr$(13), _
Replacewhat:=("¶"))
Do While Not oTmpRng Is Nothing
charCount = charCount + 1
'MsgBox (oTxtRng.Text)
Set oTmpRng = oTxtRng.Replace(FindWhat:=Chr$(13), Replacewhat:=("¶"), After:=oTmpRng.Start + oTmpRng.Length)
Loop
End If
End If
Use the Replace function, not the text range Replace method, eg
dim sText = Replace(oTxtRng.Text, Chr$(13), "¶")
oTxtRng.Text = sText
Replace function replaces all occurrences in one go.
Related
I am trying to delete ALL empty paragraphs at the start of a Word file. I am using the following to delete just the FIRST paragraph but I need to delete all empty paragraphs in a row, so that if you have 5 empty lines, they will all be deleted.
here is the code:
Dim MyRange As Range
Set MyRange = ActiveDocument.Paragraphs(1).Range
If MyRange.Text = vbCr Then MyRange.Delete
I've tried adding a loop and for statement, but to no avail.
thanks in advance.
Collapse to the start of the document, then extend the range whilst 'empty characters' are found.
Here is your starter for 10
Dim MyRange As Range
Set MyRange = ActiveDocument.Paragraphs(1).Range
MyRange.Collapse direction:=wdCollapseStart
MyRange.MoveEndWhile cset:=" " & vbCrLf ' & any other invisible characters that may be present
MyRange.Delete
Each paragraph must have at least one character - the paragraph mark itself. So all we need to do is to check if the paragraph contains only 1 character.
Simple like this:
Sub ClearEmptyPargraphAtStartOfDocument()
While (ActiveDocument.Paragraphs(1).Range.Characters.Count = 1)
ActiveDocument.Paragraphs(1).Range.Delete
Wend
End Sub
This seems to work for me
Public Sub SOCheck()
Dim MyRange As Range, CarryOn As Boolean
CarryOn = True
While CarryOn
Set MyRange = ActiveDocument.Paragraphs(1).Range
If MyRange.Text = vbCr Then
MyRange.Delete
Else
CarryOn = False
End If
Wend
'MsgBox "Done"
End Sub
It's just a loop around your own code
I need to color text in a word document (code snippets) red up until the colon, then after the colon it needs to be blue until a comma or ending paren in each line (or selection).
I've been using "selection" and trying to use the move function to start up with the blue. But I'm new to VBA and all the tutorials are confusing to me as to how to tell it when to start and stop with specific formatting.
I found this that I thought might be a helpful bit, but when I put a comma in instead of a _ VB was unhappy with me.
Selection.MoveRight Unit:=wdCharacter, Count:=1, _
Extend:=wdExtend
If by each line you refer to paragraphs in word then the simple code may serve your purpose
Sub TestColorPara()
Dim Para As Paragraph, Rng As Range, ColonAt As Long, CommaAt As Long
For Each Para In Selection.Paragraphs
Ln = Para.Range.Characters.Count
If Ln > 1 Then
ColonAt = InStr(1, Para.Range.Text, ":")
If ColonAt > 0 Then
Set Rng = ActiveDocument.Range(Start:=Para.Range.Start, End:=Para.Range.Start + ColonAt)
Rng.Font.Color = wdColorRed
CommaAt = InStr(ColonAt, Para.Range.Text, ",")
CommaAt = IIf(CommaAt > 0, CommaAt, Ln - 1)
Set Rng = ActiveDocument.Range(Start:=Para.Range.Start + ColonAt, End:=Para.Range.Start + CommaAt)
Rng.Font.Color = wdColorBlue
End If
End If
Next
End Sub
Tested to achieve what I understand as your requirement.
I have a code like so:
Sub MoveToBeginningSentence()
Application.ScreenUpdating = False
Dim selectedWords As Range
Dim selectedText As String
Const punctuation As String = " & Chr(145) & "
On Error GoTo ErrorReport
' Cancel macro when there's no text selected
Selection.Cut
Selection.MoveLeft Unit:=wdSentence, Count:=1, Extend:=wdMove
Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend
Set selectedWords = Selection.Range
selectedText = selectedWords
If InStr(selectedText, punctuation) = 0 Then
Selection.MoveLeft Unit:=wdSentence, Count:=1, Extend:=wdMove
Selection.Paste
Else
Selection.MoveLeft Unit:=wdSentence, Count:=1, Extend:=wdMove
Selection.Paste
Selection.Paste
Selection.Paste
Selection.Paste
End If
ErrorReport:
End Sub
Basically, it help me move whatever text I have selected to the beginning of the sentence in Word. If there's no quotation mark, then paste once. If there is a quote mark, paste 4 times.
The problem is regardless of whether there's any quotation there or not, it will only paste once. If I set the macro to detect any other character, it will work fine. But every single time I try to force it to detect smart quotations, it will fail.
Is there any way to fix it?
Working with the Selection object is always a bit chancy; on the whole, it's better to work with a Range object. You can have only one Selection; you can have as many Ranges as you need.
Because your code uses the Selection object it's not 100% clear what the code does. Based on my best guess, I put together the following example which you can tweak if it's not exactly right.
At the beginning, I check whether there's something in the selection, or it's a blinking insertion point. If no text is selected, the macro ends. This is better than invoking Error handling, then not handling anything: If other problems crop up in your code, you wouldn't know about them.
A Range object is instantiated for the selection - there's no need to "cut" it, as you'll see further along. Based on this, the entire sentence is also assigned to a Range object. The text of the sentence is picked up, then the sentence's Range is "collapsed" to its starting point. (Think of this like pressing the left arrow on the keyboard.)
Now the sentence's text is checked for the character Chr(145). If it's not there, the original selection's text (including formatting) is added at the beginning of the sentence. If it's there, then it's added four times.
Finally, the original selection is deleted.
Sub MoveToBeginningSentence()
Application.ScreenUpdating = False
Dim selectedText As String
Dim punctuation As String
punctuation = Chr(145) ' ‘ "smart" apostrophe
Dim selRange As word.Range
Dim curSentence As word.Range
Dim i As Long
' Cancel macro when there's no text selected
If Selection.Type = wdSelectionIP Then Exit Sub
Set selRange = Selection.Range
Set curSentence = selRange.Sentences(1)
selectedText = curSentence.Text
curSentence.Collapse wdCollapseStart
If InStr(selectedText, punctuation) = 0 Then
curSentence.FormattedText = selRange.FormattedText
Else
For i = 1 To 4
curSentence.FormattedText = selRange.FormattedText
curSentence.Collapse wdCollapseEnd
Next
End If
selRange.Delete
End Sub
Please check out this code.
Sub MoveToBeginningSentence()
' 19 Jan 2018
Dim Rng As Range
Dim SelText As String
Dim Repeats As Integer
Dim i As Integer
With Selection.Range
SelText = .Text ' copy the selected text
Set Rng = .Sentences(1) ' identify the current sentence
End With
If Len(SelText) Then ' Skip when no text is selected
With Rng
Application.ScreenUpdating = False
Selection.Range.Text = "" ' delete the selected text
Repeats = IIf(IsQuote(.Text), 4, 1)
If Repeats = 4 Then .MoveStart wdCharacter, 1
For i = 1 To Repeats
.Text = SelText & .Text
Next i
Application.ScreenUpdating = True
End With
Else
MsgBox "Please select some text.", _
vbExclamation, "Selection is empty"
End If
End Sub
Private Function IsQuote(Txt As String) As Boolean
' 19 Jan 2018
Dim Quotes
Dim Ch As Long
Dim i As Long
Quotes = Array(34, 147, 148, -24143, -24144)
Ch = Asc(Txt)
' Debug.Print Ch ' read ASCII code of first character
For i = 0 To UBound(Quotes)
If Ch = Quotes(i) Then Exit For
Next i
IsQuote = (i <= UBound(Quotes))
End Function
The approach taken is to identify the first character of the selected sentence using the ASC() function. For a normal quotation mark that would be 34. In my test I came up with -24143 and -24144 (opening and closing). I couldn't identify Chr(145) but found MS stating that curly quotation marks are Chr(147) and Chr(148) respectively. Therefore I added a function that checks all of them. If you enable the line Debug.Print Ch in the function the character code actually found will be printed to the immediate window. You might add more character codes to the array Quotes.
The code itself doesn't consider spaces between words. Perhaps Word will take care of that, and perhaps you don't need it.
You need to supply InStr with the starting position as a first parameter:
If InStr(1, selectedText, punctuation) = 0 Then
Also
Const punctuation As String = " & Chr(145) & "
is going to search for space-ampersand-space-Chr(145)-space-ampersand-space. If you want to search for the smart quote character then use
Const punctuation As String = Chr(145)
Hope that helps.
I have several PowerPoints with a great deal of text in the notes. I need to search the note text and delete any paragraphs that start with "A."
Here is what I tried - but am getting type mismatch error
Dim curSlide As Slide
Dim curNotes As Shape
Dim x As Long
For Each curSlide In ActivePresentation.Slides
Set curNotes = curSlide.NotesPage.Shapes(2).TextFrame.TextRange
With curNotes.TextFrame.TextRange
For x = 1 To Len(curNotes.TextFrame.TextRange)
If Mid(curNotes.TextFrame.TextRange, x, 2) = "A." Then
curNotes.TextFrame.TextRange.Paragraphs = ""
End If
Next x
End With
Next curSlide
End Sub
Thanks for your help!!
You get a mismatch error whenever you try to assign data of a different type specified by your variable. This is happening in your code because you defined curNotes as type Shape and then tried to set that object variable to a different data type, TextRange. You are then trying to process the object TextRange as a string. You need to work on the .Text child of .TextRange The use of Mid is not checking the start of the string and finally, when you set the text to "", you are deleting all the text in the Note but that's not what you said you're trying to do.
This is the corrected code to delete only paragraphs starting with "A."
' PowerPoint VBA macro to delete all slide note paragraphs starting with the string "A."
' Rewritten by Jamie Garroch of youpresent.co.uk
Option Explicit
Sub DeleteNoteParagraphsStartingA()
Dim curSlide As Slide
Dim curNotes As TextRange
Dim iPara As Long
For Each curSlide In ActivePresentation.Slides
Set curNotes = curSlide.NotesPage.Shapes(2).TextFrame.TextRange
With curNotes
' Count backwards in any collection when deleting items from it
For iPara = .Paragraphs.Count To 1 Step -1
If Left(.Paragraphs(iPara), 2) = "A." Then
.Paragraphs(iPara).Delete
Debug.Print "Paragraph " & iPara & " deleted from notes pane on slide " & curSlide.SlideIndex
End If
Next
End With
Next curSlide
End Sub
I have a long list of Accounts labels which I need to format out the contact information to leave only the name (first word in every paragraph). I have some experience with VBA excel, but this is my first foray into word.
So what I want to do is delete everything after the first word, but leave all paragraph breaks intact, if possible (whoever made the list formatted it with lots of breaks, rather than spacing).
Thanks a ton in advance!
Try something like this, modify as needed. Not 100% sure it will preserve your paragraph breaks but this should at least get you to a list of "first word" in each of the paragraphs.
Sub FirstWord()
Dim myString$
Dim MyDoc As Document
Dim DocPara As Paragraph
Dim i%
Dim p%
Set MyDoc = ActiveDocument
For p = MyDoc.Paragraphs.Count To 1 Step -1
Set DocPara = MyDoc.Paragraphs(p)
i = InStr(1, DocPara.Range.Text, " ")
DocPara.Range.Text = _
Left(DocPara.Range.Text, i) & Right(DocPara.Range.Text, 1)
Next
End Sub
UPDATED
To address leading spaces indenting each paragraph, try this instead. I'm going to modify the above routine so you can see a few changes to this code and how I just adapt it. I haven't tested this version yet, letme know if any problems.
Sub FirstWordIndented()
Dim myString$
Dim x% '<-- this is new
Dim MyDoc As Document
Dim DocPara As Paragraph
Dim i%
Dim p%
Set MyDoc = ActiveDocument
For p = MyDoc.Paragraphs.Count To 1 Step -1
Set DocPara = MyDoc.Paragraphs(p)
'// Make sure to ignore leading spaces
'// This block should remove leading spaces
myString = DocPara.Range.Text
Do
If Not Left(myString,1) = " " Then Exit Do
'// Removes the first character if it's a space
myString = Right(myString, Len(myString) - 1)
'// Loop until the first character isn't a space
Loop
'// Some small modifications to use the myString variable in this block:
i = InStr(1, myString, " ")
DocPara.Range.Text = _
Left(myString, i) & Right(myString, 1)
Next
End Sub
BEFORE
AFTER