i want to check a word file using vb.net and check that the styles in the document are proper or not.
I have to check for these expressions in word document
a.Verdana + 16 pt + Bold + Red
b.Verdana + 12 pt + Bold + Italic + Blue
c.Verdana + 11 pt + Bold + Italic + Brown
d.Arial + 10 pt + Black
I have tried this,
If objDoc.Range.Font.Name = "Arial" And objDoc.Range.Font.Size = 10 Then
If objDoc.Range.Font.Color = WdColor.wdColorBlack Then
End If
MsgBox("ok")
Else
MsgBox("not ok")
End If
But with this code it shows msgbox "OK" only when the whole word document consist of Arial,10,Black and shows msgbox "Not Ok" when it consist the above expressions except for the Arial,10,Black
So basically i need help to find out all the expressions in the same word document which consist of all the above expressions/Styles.
Any Help will be really really appreciable..
Plz help me with this still not able to find a solution..
With the foolowing code you can find sentences where font style is different.
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
Dim oDoc As New Word.Document()
Dim wapp As New Word.Application()
Try
oDoc = wapp.Documents.Open(TextBox1.Text & "\" & "TEST.doc")
For Each Senetence As Word.Range In oDoc.Sentences
For Each Character As Word.Range In Senetence.Characters
If Character.Font.Name <> "Verdana" AndAlso Character.Font.Name <> "Arial" Then
MsgBox(" Font Name not matching Error Line number " & Senetence.Text)
Exit For
End If
Next
Next
oDoc.Close()
Catch ex As Exception
oDoc.Close()
End Try
End Sub
Related
In 2019 comments in Word were redesigned. Therefore there was no autocorrection available in comments anymore.
I used the autocorrection function for substituting my own abbreviations in the comments.
I now wrote a VBA SUB making use of the Comments/Comment object and the AutoCorrect object.
It works fine to substitute my abbreviations in all comments after I wrote them. But to get a more immediate experience, I would like to link the SUB to a "Comment was added"- or "Comment has changed"-Event but I can't find one.
The closest I can get is via a call of my SUB in App_WindowSelectionChange() but the selection of a comment balloon or adding a new comment is not firing that event.
It should work like this:
editing autocorrection fu1 = fuggel1
Select: Word->Developement tools->macros-> Register_Event_Handler()
write comment including "fu1 is the best"
on event changing to "fuggel1 is the best"
Any ideas how to make the call of my SUB related to adding a new comment or changing a comment ?
Rem Class EventACC
Public WithEvents App As Word.Application
Private Sub App_WindowSelectionChange(ByVal Sel As Selection)
Rem Debug.Print ("change")
Call Auto_Correct_Comment
End Sub
Rem Module AutoCorrectComment
Dim ACC As New EventACC
Sub Register_Event_Handler()
Set ACC.App = Word.Application
End Sub
Sub Auto_Correct_Comment()
If ActiveDocument.Comments.Count >= 1 Then
For X = 1 To ActiveDocument.Comments.Count
Dim m_s_comment As String
Dim m_s_arr_comment_p() As String
m_s_comment = Trim(ActiveDocument.Comments(X).Range.Text)
m_s_arr_comment_p = Split(m_s_comment, " ")
For C = 0 To UBound(m_s_arr_comment_p)
Rem Debug.Print (m_s_arr_comment_p(C))
On Error Resume Next
Dim m_s_test As String
m_s_test = AutoCorrect.Entries(m_s_arr_comment_p(C)).Value
If Err.Number = 0 Then
Rem Debug.Print (AutoCorrect.Entries(m_s_arr_comment_p(C)).Value)
m_s_comment = Replace(m_s_comment, m_s_arr_comment_p(C), AutoCorrect.Entries(m_s_arr_comment_p(C)).Value)
Rem Debug.Print (m_s_comment)
End If
Next C
ActiveDocument.Comments(X).Range.Text = m_s_comment
Next X
End If
End Sub
I made some progess, now being able to change abbreviations in the selected comment via a key-shortcut (ALT + 0) after writing and confirming it or choosing the comment balloon later on. See code below. Still wanting an event related change.
Usage->Select: Word->Developement tools->macros->AddKeyBinding().
Then use the Key-Shortcut (Alt+0) on comments after writing and confirming them.
Rem Module AutoCorrectComment
Sub Auto_Correct_Comment_2()
If ActiveDocument.ActiveWindow.ActivePane.Selection.Comments.Count >= 1 Then
m_s_comment = Trim(ActiveDocument.ActiveWindow.ActivePane.Selection.Comments.Item(1).Range.Text)
m_s_comment_copy = m_s_comment
Replacement = Array(".", ",", "?", "!", ":") ' add more
For Each A In Replacement
m_s_comment_copy = Replace(m_s_comment_copy, A, " " & A & " ") ' necessary to "free" Autocorrect Element
Next A
m_s_arr_comment_p = Split(m_s_comment_copy, " ")
For C = 0 To UBound(m_s_arr_comment_p)
Rem Debug.Print (m_s_arr_comment_p(C))
On Error Resume Next
Dim m_s_test As String
m_s_test = AutoCorrect.Entries(m_s_arr_comment_p(C)).Value
If Err.Number = 0 Then
Debug.Print (m_s_arr_comment_p(C))
Rem Debug.Print (AutoCorrect.Entries(m_s_arr_comment_p(C)).Value)
m_s_comment = Replace(m_s_comment, m_s_arr_comment_p(C), AutoCorrect.Entries(m_s_arr_comment_p(C)).Value)
Rem Debug.Print (m_s_comment)
End If
Next C
ActiveDocument.ActiveWindow.ActivePane.Selection.Comments.Item(1).Range.Text = m_s_comment
End If
End Sub
Sub AddKeyBinding()
With Application
.CustomizationContext = ActiveDocument.AttachedTemplate
' \\ Add keybinding to Active.Document Shorcut: Alt+0
.KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKey0), _
KeyCategory:=wdKeyCategoryCommand, _
Command:="Auto_Correct_Comment_2"
End With
End Sub
this is going to be easy for any VBA expert out there so, apologies for the novice question! I have a code to condense text into a text box. At the moment the code condensed all the text inside the text box but I want the code to work for selected text only. How can I modify this code to make it work?
Many thanks on advance!
PJ
Sub CondenseText()
On Error GoTo Catch
Dim o As Shape, b As Boolean
Set o = ActiveWindow.Selection.ShapeRange(1)
If Not o Is Nothing Then
With o
.TextFrame2.TextRange.Font.Spacing = .TextFrame2.TextRange.Font.Spacing - 0.1
End With
End If
Exit Sub
Catch:
If Err.Number = -2147188160 Then MsgBox CG_NOTHING_SELECTED
End Sub
Sub CondenseText()
Dim oTextRange2 As TextRange2
' You can check Selection.Type rather than relying
' on an errorhandler if you like
If ActiveWindow.Selection.Type = ppSelectionText Then
Set oTextRange2 = ActiveWindow.Selection.TextRange2
If Not oTextRange2 Is Nothing Then
oTextRange2.Font.Spacing = oTextRange2.Font.Spacing - 0.1
End If
' and you could add an Else clause with msg for the
' user here if you like:
Else
MsgBox "Yo! Select some text first, OK?"
End If
End Sub
I have some word documents with unaccepted, tracked changes. I want to accept them but still have them shown in red in my documents. I think a good way to do this would be doing a wildcard search for unaccepted changes and replacing them with the same text in red, however I dont know if this is possible.
I am also happy with other ways of achieving my goal, without wildcards.
Applying formatting to revisions cannot be done using Word's standard find & replace operation. However, you can write a macro that enumerates all revisions and then applies formatting to each of them.
There is a bloc post by Chris Rae who provides a macro that converts revisions to standard formatting:
Enumerating edits on large documents (AKA converting tracked changes to conventional formatting)
The macro may not yet do exactly what you need, but it should get you started.
For reference, here is a copy of the macro:
Sub EnumerateChanges()
Dim rAll As Revision
Dim dReport As Document
Dim dBigDoc As Document
Set dBigDoc = ActiveDocument
If dBigDoc.Revisions.Count = 0 Then
MsgBox "There are no revisions in the active document.", vbCritical
ElseIf MsgBox(“This will enumerate the changes in '" + dBigDoc.Name + "' in a new document and close the original WITHOUT saving changes. Continue?", vbYesNo) <> vbNo Then
Set dReport = Documents.Add
dBigDoc.Activate ' really just so we can show progress by selecting the revisions
dBigDoc.TrackRevisions = False ' Leaving this on results in a disaster
For Each rAll In dBigDoc.Revisions
' Now find the nearest section heading downwards
Dim rFindFirst As Range, rFindLast As Range
Set rFindLast = rAll.Range.Paragraphs(1).Range
While Not IsNumberedPara(rFindLast.Next(wdParagraph))
Set rFindLast = rFindLast.Next(wdParagraph)
Wend
' Now head back up to the next numbered section header
Set rFindFirst = rFindLast
Do
Set rFindFirst = rFindFirst.Previous(wdParagraph)
Loop Until IsNumberedPara(rFindFirst) Or (rFindFirst.Previous(wdParagraph) Is Nothing)
ConvertNumberedToText rFindFirst
Dim rChangedSection As Range
Set rChangedSection = dBigDoc.Range(rFindFirst.Start, rFindLast.End)
' Properly tag all the revisions in this whole section
Dim rOnesInThisSection As Revision
For Each rOnesInThisSection In rChangedSection.Revisions
rOnesInThisSection.Range.Select ' just for visual update
DoEvents ' update the screen so we can see how far we are through
If rOnesInThisSection.Type = wdRevisionDelete Then
rOnesInThisSection.Reject
With Selection.Range
.Font.ColorIndex = wdRed
.Font.StrikeThrough = True
End With
dBigDoc.Comments.Add Selection.Range, “deleted”
Else
If rOnesInThisSection.Type = wdRevisionInsert Then
rOnesInThisSection.Accept
With Selection.Range
.Font.ColorIndex = wdBlue
End With
dBigDoc.Comments.Add Selection.Range, “inserted”
End If
End If
Next
' Now copy the whole thing into our new document
rChangedSection.Copy
Dim rOut As Range
Set rOut = dReport.Range
rOut.EndOf wdStory, False
rOut.Paste
Next rAll
' There should end up being no numbered paragraphs at all in the
' new doc (they were converted to text), so delete them
Dim pFinal As Paragraph
For Each pFinal In dReport.Paragraphs
If IsNumberedPara(pFinal.Range) Then
pFinal.Range.ListFormat.RemoveNumbers
End If
Next
dBigDoc.Close False
End If
End Sub
Sub ConvertNumberedToText(rOf As Range)
If InStr(rOf.ListFormat.ListString, “.”) > 0 Then
rOf.InsertBefore "Changes to section " + rOf.ListFormat.ListString + " "
End If
End Sub
Function IsNumberedPara(rOf As Range) As Boolean
If rOf Is Nothing Then ‘ if the document doesn’t have numbered sections, this will cause changes to be enumerated in the whole thing
IsNumberedPara = True
ElseIf rOf.ListFormat.ListString <> "" Then
If Asc(rOf.ListFormat.ListString) <> 63 Then
IsNumberedPara = True
End If
End If
End Function
I'd want to indent RTF text in a RichTextBox without losing the RTF style.
Dim Alinea As String = " "
Private Sub Indent_Click(sender As Object, e As EventArgs) Handles Indent.Click
Try
Dim Output As String = Nothing
Dim Split() As String = RichTextBox1.Lines
For i = 0 To Split.Length - 1
Output = String.Concat(Output, Split(i).Insert(0, Alinea), If(Not i = Split.Length - 1, vbNewLine, Nothing))
Next
RichTextBox1.Text = Output
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
The previous code works, but it returns the text without any style.
I'd just like to add Alinea on all beginnings of line of the RichTextBox text.
I've tried to use the RichTextBox1.Rtf property, but it shows a MsgBox saying "File format not valid".
Instead of using RichTextBox1.Lines, use RichTextBox1.Rtf.
RichTextBox1.Rtf = RichTextBox1.Rtf.Replace(vbCrLf, vbCrLf & vbTab)
This works, but you may want to key on something like \par or \par & vbcrlf to adhere more to the rtf standard.
RichTextBox1.Rtf = RichTextBox1.Rtf.Replace("\par" & vbCrLf, "\par" & vbCrLf & vbTab)
"It is left as an exercise to the reader" to make it work on the first line and for any whitespace character following "\par". (I always hated that phrase.)
Does anyone know how to detect the use of Theme fonts in Powerpoint 2007 slide objects using VBA? If one looks at Shape.TextFrame.TextRange.Font.Name the font name appears as simple name (ex: "Arial") whether or not the font was assigned as a fixed name or a Theme name (subject to change with the document theme). I don't see any other property in the Object Model that would flag the name as tied to a theme (such as ObjectThemeColor for colors).
Thanks!
There is no direct method (that I know of), however you can check with an If/Then:
Sub checkthemeFont()
Dim s As Shape
Set s = ActivePresentation.Slides(1).Shapes(1)
Dim f As Font
Set f = s.TextFrame.TextRange.Font
Dim themeFonts As themeFonts
Dim majorFont As ThemeFont
Set themeFonts = ActivePresentation.SlideMaster.Theme.ThemeFontScheme.MajorFont
Set majorFont = themeFonts(msoThemeLatin)
If f.Name = majorFont Then
Debug.Print f.Name
End If
End Sub
Thanks to the idea from #tobriand here is an implementation that reports if any placeholders are set to hard coded fonts rather than those from the theme:
Option Explicit
' =================================================================================
' PowerPoint VBA macro to check if all text-supporting placeholders are set
' to use one of the two theme fonts or are "hard coded".
' Checks all slide masters in the active presentation.
' Author : Jamie Garroch
' Company : BrightCarbon Ltd. (https://brightcarbon.com/)
' Date : 05MAR2020
' =================================================================================
Public Sub CheckMastersUseThemeFonts()
Dim oDes As Design
Dim oCL As CustomLayout
Dim oShp As Shape
Dim tMinor As String, tMajor As String
Dim bFound As Boolean
Dim lMasters, lLayouts, lPlaceholders
' If you use Arial, change this to any font not used in your template
Const TEMP_FONT = "Arial"
For Each oDes In ActivePresentation.Designs
lMasters = lMasters + 1
' Save the current theme fonts before changing them
With oDes.SlideMaster.Theme.ThemeFontScheme
tMajor = .MajorFont(msoThemeLatin).Name
tMinor = .MinorFont(msoThemeLatin).Name
.MajorFont(msoThemeLatin).Name = TEMP_FONT
.MinorFont(msoThemeLatin).Name = TEMP_FONT
End With
' Check if any are not set to the temporary font, indicating hard coding
For Each oCL In oDes.SlideMaster.CustomLayouts
lLayouts = lLayouts + 1
For Each oShp In oCL.Shapes
If oShp.Type = msoPlaceholder Then lPlaceholders = lPlaceholders + 1
If oShp.HasTextFrame Then
Select Case oShp.TextFrame.TextRange.Font.Name
Case "Arial"
Case Else
bFound = True
Debug.Print oShp.TextFrame.TextRange.Font.Name, oDes.Name, oCL.Name, oShp.Name
End Select
End If
Next
Next
' Restore the original fonts
With oDes.SlideMaster.Theme.ThemeFontScheme
.MajorFont(msoThemeLatin).Name = tMajor
.MinorFont(msoThemeLatin).Name = tMinor
End With
Next
If bFound Then
MsgBox "Some placeholders are not set to use the theme fonts. Press Alt+F11 to see them in the Immediate pane.", vbCritical + vbOKOnly, "BrightSlide - Master Theme Fonts"
Else
MsgBox "All placeholders are set to use the theme fonts.", vbInformation + vbOKOnly, "BrightSlide - Master Theme Fonts"
End If
' Provide some stats on what was checked
Debug.Print "Masters: " & lMasters
Debug.Print "Layouts: " & lLayouts
Debug.Print "Placeholders: " & lPlaceholders
End Sub