i am trying to write some code to clear a template. I have run into a problem when i try to clear a date picker. The code i have now does clear the datepicker, but it also removes the date picker function. Code is included below, thanks in advance!
Dim StopDate As ContentControl
Dim StartDate As ContentControl
With ActiveDocument.ContentControls(1)
.Type = wdContentControlText
.Range.Text = ""
.Type = wdContentControlDropdownList
End With
With ActiveDocument.ContentControls(2)
.Type = wdContentControlText
.Range.Text = ""
.Type = wdContentControlDropdownList
End With
Since you're working with Date content controls, you should use wdContentControlDate. For example:
With ActiveDocument
With .ContentControls(1)
.Type = wdContentControlText
.Range.Text = ""
.Type = wdContentControlDate
End With
With .ContentControls(2)
.Type = wdContentControlText
.Range.Text = ""
.Type = wdContentControlDate
End With
End With
Related
I have been using a macro by Rodney Atkins called "ReinsertComments" that was posted by someone in the comments section over at CyberText (see macro below): https://cybertext.wordpress.com/2013/04/10/word-removing-reviewer-names/. It reinserts all the comments in a Word document. I would like to find a way, if at all possible, to reinsert only one user's comments, but not all other users' comments.
Is it possible to specify per author which comments will be
reinserted?
Could you run an If/Then statement to specify a user name for the comments to be reinserted? Perhaps something along the lines of
If myComment.Author = "Jane" Then
If a version of that is possible, where should I insert the If/Then
and End If portion in the macro below?
Thanks to all! :)
Sub CommentsReinsert()
Dim myComment As Comment
Dim myComText As String
Dim comStart
Dim comEnd
Dim i
On Error GoTo Done
Application.ScreenUpdating = False
If ActiveDocument.TrackRevisions = True Then
With ActiveDocument
.TrackRevisions = False
End With
End If
For i = ActiveDocument.Comments.Count To 1 Step -1
Set myComment = ActiveDocument.Comments(i)
myComText = myComment.Range.Text
comStart = myComment.Scope.Start
comEnd = myComment.Scope.End
myComment.Reference.Select
myComment.Delete
ActiveDocument.Range(comStart, comEnd).Select
ActiveDocument.Comments.Add _
Range:=Selection.Range, Text:=myComText
Next i
ActiveWindow.ActivePane.Close
Application.ScreenUpdating = True
Done:
End Sub
You could use code like:
Sub ReinsertComments()
Application.ScreenUpdating = False
Dim bRev As Boolean, i As Long, Rng As Range, Cmt As Comment
With ActiveDocument
bRev = .TrackRevisions
.TrackRevisions = False
For i = .Comments.Count To 1 Step -1
With .Comments(i)
Select Case .Author
Case "Jane"
Set Rng = .Range
Set Cmt = ActiveDocument.Comments.Add(Range:=.Scope, Text:="")
Cmt.Range.FormattedText = Rng.FormattedText ': Cmt.Author = "Anon."
Rng.Comments(1).Delete
End Select
End With
Next
.TrackRevisions = bRev
End With
Set Cmt = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
End Sub
Unlike the code you posted, the above preserves the original comment's formatting. Note the commented-out code for changing the inserted comment's author name.
An alternative approach would be to temporarily change the UserName & Initials in the Word Options, to that of the commentator, then simply change the Comment.Author property to whatever other name you want - without all the deletion/reinsertion circumlocution.
I imagine people would be concerned about the dates if there are replies to comments and the above macro was deleting then reinserting them with a different date...
As I said in my previous reply, you could use the alternative approach of:
Sub ChangeCommentAuthor()
Application.ScreenUpdating = False
Dim bRev As Boolean, i As Long, UsrNm As String, UsrIn As String, bUsr As Boolean
UsrNm = Application.UserName: UsrIn = Application.UserInitials: bUsr = Options.UseLocalUserInfo
'Nominate the UserName & Initials to change from
Application.UserName = "Figgie 10": Application.UserInitials = "F": Options.UseLocalUserInfo = True
With ActiveDocument
bRev = .TrackRevisions
.TrackRevisions = False
For i = .Comments.Count To 1 Step -1
With .Comments(i)
'Nominate the UserName & Initials to change to
If .Author = Application.UserName Then .Author = "John Doe": .Initial = "JD"
End With
Next
.TrackRevisions = bRev
End With
Application.UserName = UsrNm: Application.UserInitials = UsrIn: Options.UseLocalUserInfo = bUsr
Application.ScreenUpdating = True
End Sub
The contentcontrol "contents cannot be edited" checkbox is unchecked, and I use code to set
LockContets = False
, but even so, there is still error "You are not allowed to edit this selection because it is protected"
the code is as follow:
Sub Test()
Dim CC As ContentControl
For Each CC In ActiveDocument.ContentControls
Debug.Print CC.Type
Debug.Print CC.Range.Text
CC.LockContentControl = True
CC.LockContents = False
CC.Range.Text = "" <--error here
Next CC
End Sub
why will this happen? how to solve it?
You cannot clear the text from Dropdown List, CheckBox, or Picture Content Controls, since they don't have an editable text property.
Try something along the lines of:
Sub Test()
Dim CC As ContentControl
For Each CC In ActiveDocument.ContentControls
With CC
.LockContentControl = True
.LockContents = False
Select Case .Type
Case wdContentControlRichText, wdContentControlText, wdContentControlComboBox, wdContentControlDate
.Range.Text = ""
Case wdContentControlDropdownList
.Type = wdContentControlText
.Range.Text = ""
.Type = wdContentControlDropdownList
Case wdContentControlCheckBox: .Checked = False
Case wdContentControlPicture: .Range.InlineShapes(1).Delete
End Select
End With
Next CC
End Sub
There are many type of conent controls all you need is add an if condition to check if content coontrol type is of text
Sub Test()
Dim CC As ContentControl
For Each CC In ActiveDocument.ContentControls
CC.LockContents = False
If CC.Type = wdContentControlRichText Or CC.Type = wdContentControlText Then
CC.Range.Text = ""
End If
Next CC
End Sub
I have a document with a large number of checkboxes spread around the text and I would like to replace all checkboxes with characters.
Example:
If checkbox is checked then replace it with "A"
If checkbox is not Checked then replace it with "O"
For the time being I can only replace all checkboxes with a letter regardless of their state (checked or unchecked). I need to improve my macro so it recognizes the state of the checkbox and replacing it with the right litteral.
Thanks in advance
Sub Checkbox_Replacement()
Dim i As Long, Rng As Range
With ActiveDocument
For i = .FormFields.Count To 1 Step -1
With .FormFields(i)
If .Type = wdFieldFormCheckBox Then
Set Rng = .Range
.Delete
Rng.Text = "A"
End If
End With
Next
Set Rng = Nothing
End With
End Sub
Expected Result
If checkbox is checked then replace it with "A"
If checkbox is not Checked then replace it with "O"
Actual Result
All checkboxes are replaced with "A"
You need a second If..Else block to check the condition of the checkbox:
If .Type = wdFieldFormCheckBox Then
Set Rng = .Range
If .CheckBox.Value = True Then
Rng.Text = "A"
Else
Rng.Text = "O"
End If
.Delete
End If
The answer to the problem was to remove the .Delete
Sub Checkbox_Replacement()
Dim i As Long, Rng As Range
With ActiveDocument
For i = .FormFields.Count To 1 Step -1
With .FormFields(i)
If .Type = wdFieldFormCheckBox Then
Set Rng = .Range
If .CheckBox.Value = True Then
Rng.Text = "A"
Else
Rng.Text = "O"
End If
End If
End With
Next
Set Rng = Nothing
End With
End Sub
I have the following code to customize the right click menu:
Sub CreateMenuItem()
Dim MenuButton As CommandBarButton
With CommandBars("Text") 'Text, Lists and Tables
Set MenuButton = .Controls.Add(msoControlButton)
With MenuButton
.Caption = "Correct"
.Style = msoButtonCaption
.OnAction = "InsertCorrect"
End With
End With
End Sub
It works fine with text and lists, but only partially with tables:
With CommandBars("Tables")
I must select the whole table or a column then it works but not inside a cell. What is the name for the context menu inside a cell or for text inside a table cell?
I made this routine to see al the names of the CommandBars in Word:
Sub ListYourCommandBars()
For Each c In CommandBars
Debug.Print c.Name
Next
End Sub
Good news they are already sorted alphabetically. I found one called Table Cells. I tried it:
With CommandBars("Table Cells")
and it worked. Only thing, a cell or a number of cells must be "wholly selected". That is, the menu-item doesnt show up if you just enter inside the cell, you must select the cell "as a whole" (dunno how to say it better). Hope this helps.
I got it to work inside a table cell by adding the MenuButton to the following Built-In CommandBars: "Text", "Linked Text", "Table Text", "Font Paragraph", "Linked Headings", "Linked Table", "Linked Text", "Lists", "Table Cells", "Table Lists", "Tables", "Tables and Borders", and "Text Box".
I’m not sure which one actually did the trick. Here’s my code:
Private DisableEvents As Boolean
Private Sub UpdateRightClickMenus()
Dim MenuButton As CommandBarButton
Dim CommandBarTypes(100) As String
Dim i As Long
Dim PRChecklistIsSelected As Boolean
Dim CheckListTypeFound As Boolean
PRChecklist = True
ResetRightClickMenus
CommandBarTypes(0) = "Text"
CommandBarTypes(1) = "Linked Text"
CommandBarTypes(2) = "Table Text"
CommandBarTypes(3) = "Font Paragraph"
CommandBarTypes(4) = "Linked Headings"
CommandBarTypes(5) = "Linked Table"
CommandBarTypes(6) = "Linked Text"
CommandBarTypes(7) = "Lists"
CommandBarTypes(8) = "Table Cells"
CommandBarTypes(9) = "Table Lists"
CommandBarTypes(10) = "Tables"
CommandBarTypes(11) = "Tables and Borders"
CommandBarTypes(12) = "Text Box"
Dim cc As ContentControl
Set cc = FindContentControlByTag("ListBox_PR_TR")
If IsNull(cc) Then
DisableEvents = False
Exit Sub
End If
'Find Selected
For i = 1 To cc.DropdownListEntries.Count
If cc.Range.Text = "Product Review" Then
PRChecklistIsSelected = True
CheckListTypeFound = True
Exit For
End If
If cc.Range.Text = "Technical Review" Then
PRChecklistIsSelected = False
CheckListTypeFound = True
Exit For
End If
Next i
If CheckListTypeFound = False Then Exit Sub
For i = 0 To 12
With Application
If PRChecklistIsSelected Then
'Add right-click menu option to set as a Product Review comment
With .CommandBars(CommandBarTypes(i))
Set MenuButton = .Controls.Add(msoControlButton)
With MenuButton
.Caption = "Set as Product Review Comment"
.Style = msoButtonCaption
.OnAction = "Set_as_Product_Review_Comment"
End With
End With
Else
'Add right-click menu option to set as a Tech Review comment
With .CommandBars(CommandBarTypes(i))
Set MenuButton = .Controls.Add(msoControlButton)
With MenuButton
.Caption = "Set as Tech Review Comment"
.Style = msoButtonCaption
.OnAction = "Set_as_Tech_Review_Comment"
End With
End With
End If
End With
Next i
RightClickMenuItemsAdded = True
End Sub
Private Sub Document_ContentControlOnExit(ByVal ContentControl As ContentControl, Cancel As Boolean)
If DisableEvents = True Then Exit Sub
Set cc = FindContentControlByTag("ListBox_PR_TR")
If IsNull(cc) Then
ResetRightClickMenus
DisableEvents = False
Exit Sub
End If
If cc.Range.Text = "Technical Review" Then
Find_PR_Style_ReplaceWith_TR_Style
End If
UpdateRightClickMenus
DisableEvents = False
End Sub
Private Sub Find_PR_Style_ReplaceWith_TR_Style()
Set StylePR = ThisDocument.Styles("Product Review Style")
Set StyleTR = ThisDocument.Styles("Technical Review Style")
With ThisDocument.Content.Find
.ClearFormatting
.Style = StylePR
With .Replacement
.ClearFormatting
.Style = StyleTR
End With
.Execute Forward:=True, Replace:=wdReplaceAll, FindText:="", ReplaceWith:=""
End With
End Sub
Private Sub Set_as_Tech_Review_Comment()
Set StyleTR = ThisDocument.Styles("Technical Review Style")
With ThisDocument
Selection.Style = StyleTR
SetCanContinuePreviousList
End With
End Sub
Private Sub Set_as_Product_Review_Comment()
Set StylePR = ThisDocument.Styles("Product Review Style")
With ThisDocument
Selection.Style = StylePR
SetCanContinuePreviousList
End With
End Sub
Private Sub SetCanContinuePreviousList()
Dim lfTemp As ListFormat
Dim intContinue As Integer
Dim oldListNumber As Single
Set lfTemp = Selection.Range.ListFormat
oldListNumber = lfTemp.ListValue
If Not (lfTemp.ListTemplate Is Nothing) Then
intContinue = lfTemp.CanContinuePreviousList( _
ListTemplate:=lfTemp.ListTemplate)
lfTemp.ApplyListTemplate _
ListTemplate:=lfTemp.ListTemplate, _
ContinuePreviousList:=False, _
ApplyTo:=wdListApplyToWholeList
If lfTemp.ListValue = oldListNumber Then
lfTemp.ApplyListTemplate _
ListTemplate:=lfTemp.ListTemplate, _
ContinuePreviousList:=True, _
ApplyTo:=wdListApplyToWholeList
End If
End If
Set lfTemp = Nothing
End Sub
Private Function FindContentControlByTag(Tag As String) As ContentControl
For Each cc In ThisDocument.ContentControls
If cc.Tag = Tag Then
Set FindContentControlByTag = cc
Exit Function
End If
Next
End Function
Private Sub ResetRightClickMenus()
Dim CommandBarTypes(100) As String
Dim i As Long
CommandBarTypes(0) = "Text"
CommandBarTypes(1) = "Linked Text"
CommandBarTypes(2) = "Table Text"
CommandBarTypes(3) = "Font Paragraph"
CommandBarTypes(4) = "Linked Headings"
CommandBarTypes(5) = "Linked Table"
CommandBarTypes(6) = "Linked Text"
CommandBarTypes(7) = "Lists"
CommandBarTypes(8) = "Table Cells"
CommandBarTypes(9) = "Table Lists"
CommandBarTypes(10) = "Tables"
CommandBarTypes(11) = "Tables and Borders"
CommandBarTypes(12) = "Text Box"
For i = 0 To 12
Application.CommandBars(CommandBarTypes(i)).Reset
Next i
RightClickMenuItemsAdded = False
End Sub
Private Sub Document_Open()
UpdateRightClickMenus
End Sub
Private Sub Document_Close()
ResetRightClickMenus
End Sub
I am exporting an excel table into word using VBA. The word document has one bookmark. The code is such that first it writes the TYPE as the heading and then write all the description under that TYPE. I want the headings to be bold and formatted. I have the following code but it does not work. If anyone could suggest something.
If Dir(strPath & "\" & strFileName) <> "" Then
'Word Document open
On Error Resume Next
Set objWDApp = GetObject(, "Word.Application")
If objWDApp Is Nothing Then Set objWDApp = CreateObject("Word.Application")
With objWDApp
.Visible = True 'Or True, if Word is to be indicated
.Documents.Open (strPath & "\" & strFileName)
Set objRng = objWDApp.ActiveDocument.Bookmarks("Bookmark").Range
.Styles.Add ("Heading")
.Styles.Add ("Text")
With .Styles("Heading").Font
.Name = "Arial"
.Size = 12
.Bold = True
.Underline = True
End With
With .Styles("Text").Font
.Name = "Arial"
.Size = 10
.Bold = False
.Underline = False
End With
End With
On Error GoTo 0
i = Start_Cell
idx(1) = i
n = 2
Do ' Search for first empty cell in the table
i = i + 1
If i > Start_Cell + 1 And Cells(i, QB_Type).Value = Cells(i - 1, QB_Type) Then GoTo Loop1
idx(n) = i
n = n + 1
Loop1:
Loop Until IsEmpty(Cells(i + 1, QB_Type).Value)
idxEnd = i
idx(n) = 9999
i = Start_Cell
n = 1
Do
If i = idx(n) Then
strTMP = vbNewLine & vbNewLine & Cells(idx(n), QB_Type).Value & vbNewLine
With objWDApp
'.Selection.Font.Bold = True 'Type Bold (Doesnt Functions!?)
.Selection.Styles ("Heading") 'I tried this as well but not functioning...gives an error here that object does not support this property
WriteToWord objRng, strTMP 'Text written
End With
n = n + 1
End If
strTMP = vbNewLine & Cells(i, QB_Description).Value & vbNewLine
With objWDApp
' .Selection.Font.Bold = False 'Description Not bold (Not functioning!?)
.Selection.Styles("Text") 'This is also not functioning
WriteToWord objRng, strTMP 'Text written
End With
i = i + 1 'Arbeitspunktzähler erhöhen
Loop Until i > idxEnd
Public Sub WriteToWord(objRng, text)
With objRng
.InsertAfter text
End With
End Sub
Try .Selection.Style.Name = "Heading" from here
Edit 2
The following code works as expected. You will need to modify it to fit your needs. I successfully added and then bolded text to an existing word document.
Option Explicit
Public Sub Test()
' Add a reference to Microsoft Word x.0 Object Library for early binding and syntax support
Dim w As Word.Application
If (w Is Nothing) Then Set w = New Word.Application
Dim item As Word.Document, doc As Word.Document
' If the document is already open, just get a reference to it
For Each item In w.Documents
If (item.FullName = "C:\Path\To\Test.docx") Then
Set doc = item
Exit For
End If
Next
' Else, open the document
If (doc Is Nothing) Then Set doc = w.Documents.Open("C:\Path\To\Test.docx")
' Force change Word's default read-only/protected view
doc.ActiveWindow.View = wdNormalView
' Delete the preexisting style to avoid an error of duplicate entry next time this is run
' Could also check if the style exists by iterating through all styles. Whichever method works for you
doc.Styles.item("MyStyle").Delete
doc.Styles.Add "MyStyle"
With doc.Styles("MyStyle").Font
.Name = "Arial"
.Size = 12
.Bold = True
.Underline = wdUnderlineSingle
End With
' Do your logic to put text where you need it
doc.Range.InsertAfter "This is another Heading"
' Now find that same text you just added to the document, and bold it.
With doc.Content.Find
.Text = "This is another Heading"
.Execute
If (.Found) Then .Parent.Bold = True
End With
' Make sure to dispose of the objects. This can cause issues when the macro gets out mid way, causing a file lock on the document
doc.Close
Set doc = Nothing
w.Quit
Set w = Nothing
End Sub
By adding a reference to the object library, you can get intellisense support and compilation errors. It would help you determine earlier in development that Styles is not a valid property off the Word.Application object.