Hi I need to program to add comments in certain situation, in my static test it completes the code but also gives a Type Mismatch error at the end. How should I amend this please?
Sub EquTest()
Dim objRange As range
Dim objEq As OMath
Set objRange = Selection.range
objRange.Text = "Celsius = (5/9)(Fahrenheit - 32)"
Set objRange = Selection.OMaths.Add(objRange)
Set objEq = objRange.OMaths(1)
objEq.BuildUp
Set objEq = objEq.range.Comments.Add(Selection.range, "Blah Blah")
'Comment added but then Type mismatch displayed
End Sub
.Comments.Add returns a comment, not the OMath object that objEq is expecting. Also you don't need to use the Selection more than once
Sub EquTest()
Dim objRange As Range
Dim objEq As OMath
Set objRange = Selection.Range
objRange.Text = "Celsius = (5/9)(Fahrenheit - 32)"
Set objRange = objRange.OMaths.Add(objRange)
Set objEq = objRange.OMaths(1)
objEq.BuildUp
'method 1 - if all you need to do is add the comment
objEq.Range.Comments.Add objRange, "Blah Blah"
'method 2 - if you need to do more with the comment once it has been added
With objEq.Range.Comments.Add(objRange, "Blah Blah")
End With
'method 3 - alternative to method 2
Dim cmt As Comment
Set cmt = objEq.Range.Comments.Add(objRange, "Blah Blah")
End Sub
Related
I am creating a word report through excel VBA. I need math equation to be written but unfortunately, the word document do not autocorrect \pi and \times. Otherwise the equation is printed. Can someone suggest me what is the way forward. Below is the code
Sub AreaSolidBolt(wrdApp As Object, wrdDoc As Object, d As Variant)
Dim objRange As Object
Dim objEq As OMath
Dim aCorrect As OMathAutoCorrectEntry
wrdApp.OMathAutoCorrect.UseOutsideOMath = True
Set objRange = wrdDoc.Range
objRange.Text = "A = \pi/4 \times d^2"
Set objRange = wrdApp.Selection.OMaths.Add(objRange)
For Each aCorrect In wrdApp.OMathAutoCorrect.Entries
With objRange
If InStr(.Text, aCorrect.Name) > 0 Then
.Text = Replace(.Text, aCorrect.Name, aCorrect.Value)
End If
End With
Next aCorrect
Set objEq = objRange.OMaths(1)
objEq.BuildUp
Set objRange = Nothing
End Sub
I have defined the objects as below in the calling function. Can you please suggest me the way forward.
Set fso = CreateObject("Scripting.FileSystemObject")
Set wrdApp = CreateObject("Word.Application")
If Not fso.FileExists(wrdFileName) Then
Set wrdDoc = wrdApp.Documents.Add
wrdApp.Visible = False
With wrdDoc
.SaveAs FileName:=wrdFileName
End With
Else
Set wrdDoc = wrdApp.Documents.Open(wrdFileName)
wrdApp.Visible = False
wrdDoc.Content.InsertAfter vbLf
End If
If the AutoCorrect isn't recognizing something you need to use, then you can write in the corresponding (unicode) character code as part of the equation, using ChrW(). PI is 960, for example.
It's not clear what you consider a "times" character, whether an "x" an "*" or something else. I note that most Math equations don't actually use a character for multiplication, which may be why AutoCorrect isn't picking that up. But you can certainly just type those in?
For example:
objRange.Text = "A = " & ChrW(960) & "/4 * d^2"
I have found the answer myself. The was slightly modified. The error was with the placement of the code line
Set objRange = wrdApp.Selection.OMaths.Add(objRange)
Below is the modified code.
Sub AreaSolidBolt(wrdApp As Object, wrdDoc As Object, d As Variant)
Dim objRange As Object
Dim objEq As OMath
Dim aCorrect As OMathAutoCorrectEntry
wrdApp.OMathAutoCorrect.UseOutsideOMath = True
Set objRange = wrdDoc.Range
objRange.Text = "A = \pi/4 \times d^2"
For Each aCorrect In wrdApp.OMathAutoCorrect.Entries
With objRange
If InStr(.Text, aCorrect.Name) > 0 Then
.Text = Replace(.Text, aCorrect.Name, aCorrect.Value)
End If
End With
Next aCorrect
Set objRange = wrdApp.Selection.OMaths.Add(objRange)
Set objEq = objRange.OMaths(1)
objEq.BuildUp
Set objRange = Nothing
End Sub
I have a function to create a table in my Word document.
Running first Main in WordManager assigns objWord and objDoc. Running FnAddTableToWordDocument in WordFormating works on the first run but fails every time on the second run.
The error I get is the following:
Run-time error 6028
The range cannot be deleted
On line:
objDoc.Tables.Add objRange, intNoOfRows, intNoOfColumns
Two Modules:
Module #1 - WordManager:
Module WordManager
Public objWord As Word.Application
Public objDoc As Word.Document
Sub Main() ' This is to be replaced by a call from the actual CA tool.
Call initWordManager("[string path]", "test2.doc")
End Sub
Sub initWordManager(Path, Name)
sFilePath = Path
sFileName = Name
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Add
End Sub
Module #2 - WordFormating:
Function FnAddTableToWordDocument()
Dim intNoOfRows
Dim intNoOfColumns
Dim objRange
Dim objTable
intNoOfRows = 5
intNoOfColumns = 3
objWord.Visible = True
Set objRange = objDoc.Range
objDoc.Tables.Add objRange, intNoOfRows, intNoOfColumns
Set objTable = objDoc.Tables(1)
objTable.Borders.Enable = True
For i = 1 To intNoOfRows
For j = 1 To intNoOfColumns
objTable.Cell(i, j).Range.Text = "Sumit_" & i & j
Next
Next
End Function
Setting a more specific range solved the issue.
Set objRange = objDoc.Range(Start:=0, End:=0)
Does not give multiple tables but at least it does not cause an error.
I'm trying to create word document from content in Excel.
When I tryto add header/footer in the word, I'm getting an error "Run Time Error 5941 : The requested member of the collection does not exist" on line .Headers(wdHeaderFooterPrimary).Range.Text = "Header text". Please suggest how I can work with this?
Sub CreateFAQWord()
Dim myRow As Long
Dim objWord As Object
Dim objDoc As Object
Dim question As String
Dim answer As String
Dim rng As Range
Dim i As Long
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Add()
objWord.Selection.Style = objDoc.Styles("Title")
objWord.Selection.Paragraphs.Alignment = 1
objWord.Selection.TypeText Text:="Title"
objWord.Selection.TypeParagraph
objWord.Selection.TypeParagraph
With objDoc
.Styles.Add ("BoldNormal")
With .Styles("BoldNormal").Font
.Name = "Calibri"
.Size = 11
.Bold = True
.Italic = True
.Underline = False
End With
End With
myRow = 2
' Value 2 here is the column in which questions are present. Change accordingly
While Cells(myRow, 2).Value <> ""
' Value 9 here is the column in which Yes/No is present. Change accordingly
If Cells(myRow, 9) = "Yes" Then
objDoc.Activate
question = Cells(myRow, 2)
answer = Cells(myRow, 3)
objWord.Selection.Style = objDoc.Styles("BoldNormal")
objWord.Selection.TypeText Text:=question
objWord.Selection.TypeParagraph
objWord.Selection.Style = objDoc.Styles("Normal")
objWord.Selection.TypeText Text:=answer
objWord.Selection.TypeParagraph
objWord.Selection.TypeParagraph
End If
myRow = myRow + 1
Wend
For i = 1 To objDoc.Sections.Count
With objDoc.Sections(i)
.Headers(wdHeaderFooterIndex.wdHeaderFooterPrimary).Range.Text = "Header text"
.Footers(wdHeaderFooterIndex.wdHeaderFooterPrimary).Range.Text = "Footer text"
End With
Next
' Change the location path of where you want the document to be saved as needed
objDoc.SaveAs "C:\Users\2021282\Desktop\FAQ"
End Sub
I do not think you can use .Range.Text
Instead try to assign a reference to a range object. To make this work you need to add the "Microsoft Word XX.X Object Library" under references.
Dim objRange as Word.Range
For i = 1 To objDoc.Sections.Count
With objDoc.Sections(i)
Set objRange = .Headers(wdHeaderFooterIndex.wdHeaderFooterPrimary).Range
objRange = "Header Text"
Set objRange = Nothing
Set objRange = .Footers(wdHeaderFooterIndex.wdHeaderFooterPrimary).Range
objRange = "Footer text"
Set objRange = Nothing
End With
Next
I was looking to see if it was possible to create a macro that locates underlined words in a word document and converts them to the html tags. i tried to record a macro to do that but it just adds tags to all words. I also provide some of the code i tried to use:
Dim myWords() As String
Dim i As Long
Dim myDoc As Document: Set myDoc = ActiveDocument ' Change as needed
Dim aRange As Range: Set aRange = myDoc.Content
Dim sRanges As StoryRanges: Set sRanges = myDoc.StoryRanges
Dim ArrayCounter As Long: ArrayCounter = 0 ' counter for items added to the array
Dim Sentence As Range
Dim w As Variant
Application.ScreenUpdating = False
ReDim myWords(aRange.Words.Count) ' set a array as large as the
' number of words in the doc
For Each Sentence In myDoc.StoryRanges
For Each w In Sentence.Words
If w.Font.Underline <> wdUnderlineNone Then
myDoc.Sentence.Range.InsertBefore "<u>"
myDoc.Sentence.Range.InsertAfter "</u>"
End If
Well this code looks familiar!
Here's a tweak on what you've done that should add the tag around each underlined word. It's important to note, you must remove the underline property, and then add the tag. Otherwise word will treat the newly introduced tag as a new word, and repeat the process.
Sub ChangeUnderLineToHTML()
Dim myDoc As Document: Set myDoc = ActiveDocument ' Change as needed
Dim aRange As Range: Set aRange = myDoc.Content ' Change as needed
Dim sRanges As Variant: Set sRanges = myDoc.StoryRanges
Dim sentence As Object
Dim w As Object
For Each sentence In sRanges
For Each w In sentence.Words
If w.Font.Underline <> wdUnderlineNone Then
w.Font.Underline = wdUnderlineNone
w.Text = "<u>" & w.Text & "</u>"
End If
Next w
Next sentence
'Clean Up
Set myDoc = Nothing
Set aRange = Nothing
Set sRanges = Nothing
Set w = Nothing
Set sentence = Nothing
End Sub
My project is to change words/phrases in the whole Bible, and I have the Word doc with the Bible in it, and separately, I have an Excel file with Column A oldwords that need to be found by the macro, Column B newwords that will replace the old ones.
I was gracefully provided with this macro, which works well in MS Word 2010, but as you can see, it is setup to use Data arrays. It even says, "'Note: Data arrays are used in this example. In practice the data could come from a Word table, Excel worksheet or other data source.". So, I need to adapt it so that it gets the data from my Excel file where I have all the words/phrases that need to be changed.
There are 2 class modules and 1 standard module. But at the end of this post, I'm also including yet more code that should do what I want (get data from an Excel file) but it needs to be adapted to work in my macro. The problem is, I don't know how to adapt it. In other words: I don't know what needs to be replaced in the module/s in order to make it work.
Also, I believe my Excel file needs to be simple. Column A Old wordorphrase // Column B New wordorphrase. Would that work fine just like that?
Here is everything I have (separately):
First class module I was told to name it "clsTerm" and paste this code:
Option Explicit
Private English As String
Private Hebrew As String
Private FNT As String
Property Let EnglishTerm(strVal As String)
English = strVal
End Property
Property Get EnglishTerm() As String
EnglishTerm = English
End Property
Property Let HebrewTerm(strVal As String)
Hebrew = strVal
End Property
Property Get HebrewTerm() As String
HebrewTerm = Hebrew
End Property
Property Let FootnoteText(strVal As String)
FNT = strVal
End Property
Property Get FootnoteText() As String
FootnoteText = FNT
End Property
Second class module I was told to name it "clsTerms" and paste this code:
Option Explicit
Private colTerms As Collection
Private lngCount As Long
Property Get Items() As Collection
Set Items = colTerms
End Property
Property Set Items(oCol As Collection)
Set colTerms = oCol
End Property
Property Get Count() As Long
If Not colTerms Is Nothing Then
Count = colTerms.Count
Else
Count = 0
End If
End Property
Then I was told to create a standard module and name it "Anything I like" and paste this code:
Option Explicit
Dim m_oCol1 As Collection
Dim m_oCol2 As Collection
Sub ReplaceWordsAndDefineFootnotes()
Dim clsTL As clsTerms
Dim lngIndex As Long
Set clsTL = New clsTerms
Set clsTL.Items = DefinedTerms
Set m_oCol1 = New Collection
For lngIndex = 1 To clsTL.Count
'Replace each defined English word with it Hebrew equivelent.
ReplaceWords clsTL.Items(lngIndex).EnglishTerm, clsTL.Items(lngIndex).HebrewTerm
Next lngIndex
Underline_And_DefineFootnote
For lngIndex = 1 To clsTL.Count
'Replace temporary footnote text with with class defined footnote text.
FixFootnotes clsTL.Items(lngIndex).HebrewTerm, clsTL.Items(lngIndex).FootnoteText
Next lngIndex
lbl_Exit:
Exit Sub
End Sub
Function DefinedTerms() As Collection
Dim arrEng() As String
Dim arrHeb() As String
Dim lngIndex As Long
Dim oCol As Collection
Dim Term As clsTerm
'Note: Data arrays are used in this example. In practice the data could come from a Word table, Excel worksheet or other data source.
arrEng = Split("God,heaven,earth,waters,good", ",")
arrHeb = Split("Elohim,shamayim,aretz,mayim,tov", ",")
Set oCol = New Collection
'Put data in the collection.
For lngIndex = 0 To UBound(arrEng)
Set Term = New clsTerm
Term.EnglishTerm = arrEng(lngIndex)
Term.HebrewTerm = arrHeb(lngIndex)
Term.FootnoteText = arrEng(lngIndex) & ":" & arrHeb(lngIndex)
oCol.Add Term, Term.EnglishTerm
Next lngIndex
Set DefinedTerms = oCol
lbl_Exit:
Exit Function
End Function
Sub ReplaceWords(ByVal strFind As String, ByVal strReplaceWith As String)
Dim oRng As Word.Range
'Add each term processed to a collection.
m_oCol1.Add UCase(strReplaceWith), UCase(strReplaceWith)
Set oRng = ActiveDocument.Range
'Replace each instance of the English word with its Hebrew equivalent.
With oRng.Find
.Text = strFind
.Replacement.Text = strReplaceWith
.MatchWholeWord = True
.MatchCase = False
.Execute Replace:=wdReplaceAll
End With
lbl_Exit:
Exit Sub
End Sub
Sub Underline_And_DefineFootnote()
Dim oRng As Word.Range
Dim lngIndex As Long
Dim oWord As Word.Range
Dim strWord As String
Dim lngCounter As Long
Dim lngPages As Long
With ActiveDocument
Set oRng = .Range
lngPages = .ComputeStatistics(wdStatisticPages)
For lngIndex = 1 To lngPages
Reprocess:
Set m_oCol2 = New Collection
Set oRng = oRng.GoTo(What:=wdGoToPage, Name:=lngIndex)
Set oRng = oRng.GoTo(What:=wdGoToBookmark, Name:="\page")
lngCounter = 1
With oRng
For Each oWord In oRng.Words
'Modify the word range to strip off white space. We want only the text portion of the word range.
strWord = UCase(Trim(oWord.Text))
oWord.Collapse wdCollapseStart
oWord.MoveEnd wdCharacter, Len(strWord)
If oWord.Characters.Last = Chr(160) Then oWord.MoveEnd wdCharacter, -1
'We need to know if the text defined by the word range is a word we want to process.
'We added all of those words to a collection during the find and replace process.
'If we try to add one of those words to the collection again then it will error and we will know _
we are dealing with a word we want to process.
On Error Resume Next
m_oCol1.Add strWord, strWord
If Err.Number <> 0 Then
On Error GoTo 0
On Error Resume Next
'We only want to underline and footnote the first instance of the term on each page.
'So add the term and key to a collection.
m_oCol2.Add strWord, strWord
If Err.Number = 0 Then
'There was no error so underline the term and footnote it.
oWord.Font.Underline = 1
On Error GoTo 0
ActiveDocument.Footnotes.Add oWord, CStr(lngCounter), LCase(strWord)
lngCounter = lngCounter + 1
End If
Else
'The word wasn't a word we want to process so remove it from the collection.
m_oCol1.Remove m_oCol1.Count
End If
Next oWord
End With
'Since processing words will add footnotes, the length of the document will increase.
'I'm using this method to reenter the processing loop.
lngPages = .ComputeStatistics(wdStatisticPages)
If lngIndex < lngPages Then
lngIndex = lngIndex + 1
GoTo Reprocess
End If
Next lngIndex
End With
Set oRng = Nothing
End Sub
Sub FixFootnotes(ByVal strFind As String, ByVal strReplaceWith As String)
Dim oRng As Word.Range
m_oCol1.Add UCase(strReplaceWith), UCase(strReplaceWith)
Set oRng = ActiveDocument.StoryRanges(wdFootnotesStory)
With oRng.Find
.Text = strFind
.Replacement.Text = strReplaceWith
.MatchWholeWord = True
.MatchCase = False 'True
.Execute Replace:=wdReplaceAll
End With
lbl_Exit:
Exit Sub
End Sub
And finally, this is the code that I need to adapt into my macro, in order to make it get the data from the Excel file:
Sub ListFromExcel()
Dim lngIndex As Long
Dim arrWords As Variant
'Find words in column 1, Replace words in column 2
arrWords = GetListArray(You file path and name)
For lngIndex = 2 To UBound(arrWords, 1)
Debug.Print arrWords(lngIndex, 1)
Debug.Print arrWords(lngIndex, 2)
Next
End Sub
Function GetListArray(ByRef strFileName As String) As Variant
Dim xlapp As Object
Dim xlbook As Object
Dim xlsheet As Object
Dim bAppStart As Boolean
On Error Resume Next
Set xlapp = GetObject(, "Excel.Application")
If Err Then
bAppStart = True
Set xlapp = CreateObject("Excel.Application")
End If
On Error GoTo 0
Set xlbook = xlapp.Workbooks.Open(FileName:=strFileName)
Set xlsheet = xlbook.Worksheets(1)
GetListArray = xlsheet.Range("A1").CurrentRegion.Value
xlbook.Close
If bAppStart = True Then xlapp.Quit
Set xlapp = Nothing
Set xlbook = Nothing
Set xlsheet = Nothing
lbl_Exit:
Exit Function
End Function
Change the first sub to this
Sub ReplaceWordsAndDefineFootnotes()
Dim clsTL As clsTerms
Dim lngIndex As Long
Set clsTL = New clsTerms
clsTL.FillFromExcel
Set m_oCol1 = New Collection
For lngIndex = 1 To clsTL.Count
'Replace each defined English word with it Hebrew equivelent.
ReplaceWords clsTL.Items(lngIndex).EnglishTerm, clsTL.Items(lngIndex).HebrewTerm
Next lngIndex
Underline_And_DefineFootnote
For lngIndex = 1 To clsTL.Count
'Replace temporary footnote text with with class defined footnote text.
FixFootnotes clsTL.Items(lngIndex).HebrewTerm, clsTL.Items(lngIndex).FootnoteText
Next lngIndex
lbl_Exit:
Exit Sub
End Sub
Add this to the clsTerms class
Public Sub FillFromExcel()
Dim xlApp As Object
Dim xlWb As Object
Dim vaWords As Variant
Dim cTerm As clsTerm
Dim i As Long
Const sFILE As String = "C:\Users\Dick\Documents\My Dropbox\Excel\wordlist.xlsx"
Const xlUP As Long = -4162
Set colTerms = New Collection
Set xlApp = CreateObject("Excel.Application")
Set xlWb = xlApp.Workbooks.Open(sFILE, , True)
With xlWb.Worksheets(1)
vaWords = .Range("A1", .Cells(.Rows.Count, 2).End(xlUP)).Value
End With
For i = LBound(vaWords, 1) To UBound(vaWords, 1)
Set cTerm = New clsTerm
cTerm.EnglishTerm = vaWords(i, 1)
cTerm.HebrewTerm = vaWords(i, 2)
cTerm.FootnoteText = vaWords(i, 1) & ":" & vaWords(i, 2)
colTerms.Add cTerm
Next i
xlWb.Close False
xlApp.Quit
End Sub