Closed. This question needs to be more focused. It is not currently accepting answers.
Want to improve this question? Update the question so it focuses on one problem only by editing this post.
Closed 4 years ago.
Improve this question
For some automated tests I need to create a Word Doc that contains all the glyphs of a font (for several different fonts). Is there an easy way to create a macro that loops through all the available glyphs in a font (and inserts them into a doc)?
Is there a particular reason why it needs to be in Word? Is this simply to visualize all the characters of a font? If so, you can use Font Book in OS X and go to Print, select Report Type: Repetoire, and save out to PDF.
Edit: Seems I missed "automated tests". Disregard.
Geez... I've made something like that a long time ago... Yes, it's possible to do it.
A good start is the MSDN
Edited to add:
I knew I had done something like this before. Going through some of my old emails I found a macro I've sent to a friend of mine containing exactly this. Here it is:
Sub GenerateFontCatalog()
'
' Macro created in 05/14/2008 by Paulo Santos
'
Dim i As Long
Dim j As Long
Dim fnt As String
Dim doc As Document
Dim fnts() As String
'*
'* Get all font names
'*
Word.StatusBar = "Reading Font Names..."
ReDim fnts(Word.FontNames.Count)
For i = 1 To Word.FontNames.Count
fnts(i) = Word.FontNames.Item(i)
DoEvents
Next
'*
'* Sort alphabetically
'*
Word.StatusBar = "Sorting Font Names..."
For i = 1 To UBound(fnts)
For j = i + 1 To UBound(fnts)
If (fnts(i) > fnts(j)) Then
fnt = fnts(i)
fnts(i) = fnts(j)
fnts(j) = fnt
End If
Next
DoEvents
Next
Word.StatusBar = "Generating Font Catalog..."
Set doc = Application.Documents.Add()
doc.Activate
'*
'* Page configuration
'*
With ActiveDocument.PageSetup
.Orientation = wdOrientPortrait
.TopMargin = CentimetersToPoints(2)
.BottomMargin = CentimetersToPoints(2)
.LeftMargin = CentimetersToPoints(2)
.RightMargin = CentimetersToPoints(2)
End With
For i = 1 To UBound(fnts)
'*
'* Write font name
'*
Selection.Font.Name = "Arial"
Selection.Font.Size = 10
If (i > 1) Then
Selection.TypeParagraph
Selection.ParagraphFormat.KeepTogether = False
Selection.ParagraphFormat.KeepWithNext = False
Selection.TypeParagraph
End If
Selection.TypeText fnts(i)
Selection.ParagraphFormat.KeepWithNext = True
Selection.TypeParagraph
'*
'* Write font sample
'*
Selection.Font.Name = fnts(i)
Selection.Font.Size = 16
Selection.TypeText "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & Chr(11)
Selection.TypeText "abcdefghijklmnopqrstuvwxyz" & Chr(11)
Selection.TypeText "0123456789"
Selection.ParagraphFormat.KeepTogether = True
DoEvents
Next
'*
'* Adjust cursor position
'*
Selection.HomeKey Unit:=wdStory
Selection.InsertBreak Type:=wdSectionBreakNextPage
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveUp Unit:=wdLine, Count:=1
Word.StatusBar = "Generating Font Index..."
For i = 1 To UBound(fnts)
Selection.Font.Name = "Arial"
Selection.Font.Size = 10
Selection.TypeText fnts(i) & vbTab
Selection.Font.Name = fnts(i)
Selection.TypeText "ABC abc 123"
Selection.TypeParagraph
Next
'*
'* Split the document in two columns
'*
With Selection.Sections(1).PageSetup.TextColumns
.SetCount NumColumns:=2
.EvenlySpaced = True
.LineBetween = False
End With
Selection.HomeKey Unit:=wdStory, Extend:=True
Selection.ParagraphFormat.TabStops.Add Position:=Selection.Sections(1).PageSetup.TextColumns(1).Width, Alignment:=wdAlignTabRight, Leader:=wdTabLeaderSpaces
Selection.HomeKey Unit:=wdStory
Word.StatusBar = ""
End Sub
Programs like MS Word won't be able to tell you what characters are available in a font. As far as I can tell you from experience, only the Window's "Character Map" application can show you. Character Map can be found in your Start menu via Accessories, or alternatively by Start, Run..., and typing "charmap" but there's no convenient method to collect these characters from Character Map or MS Word.
Strictly in Word, I have no idea if it's possible, but since you can execute scripts in Word, I'm sure it's possible to read the font files and read their binary data to collect the available characters inside it.. that's the long-winded way, and possibly the only way to get what you desire.
I've not been able to find a suitable program online to do this for me either, sorry.
It will be nice idea to insert
The quick brown fox jumps over the
lazy dog
and loop through the fonts that need to be tested using a macro.
Seems like a pretty good compromise is to create an html file with &#XXX; entries for each character and then open that with MS Word.
Related
I want to make a macro that will do the following:
Highlight every nth selection.
Check that selection to ensure it is a word (and not numerical or punctuation).
Cut the word and paste it into another document.
Replace the word with a blank space.
Repeat until the end of the document.
The hard part is checking a selection to validate that it is indeed a word and not something else.
I found some code written by someone else that might work, but I don't understand how to implement it in my macro with the rest of the commands:
Function IsLetter(strValue As String) As Boolean
Dim intPos As Integer
For intPos = 1 To Len(strValue)
Select Case Asc(Mid(strValue, intPos, 1))
Case 65 To 90, 97 To 122
IsLetter = True
Case Else
IsLetter = False
Exit For
End Select
Next
End Function
Sub Blank()
Dim OriginalStory As Document
Set OriginalStory = ActiveDocument
Dim WordListDoc As Document
Set WordListDoc = Application.Documents.Add
Windows(OriginalStory).Activate
sPrompt = "How many spaces would you like between each removed word?"
sTitle = "Choose Blank Interval"
sDefault = "8"
sInterval = InputBox(sPrompt, sTitle, sDefault)
Selection.HomeKey Unit:=wdStory
Do Until Selection.Bookmarks.Exists("\EndOfDoc") = True
Selection.MoveRight Unit:=wdWord, Count:=sInterval, Extend:=wdMove
Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
If IsLetter = True Then
Selection.Cut
Selection.TypeText Text:="__________ "
Windows(WordListDoc).Activate
Selection.PasteAndFormat (wdFormatOriginalFormatting)
Selection.TypeParagraph
Windows(OriginalStory).Activate
Else
Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdMove
Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend
Loop
Loop
End Sub
The function should sit 'above' the rest of the code right? But I get an error 'argument not optional' when I run it.
Any ideas or tips much appreciated.
I think the code below will do most of what you want. Note that some of the comments relate to the reasons for which I discarded some of your code while others may prove helpful in understanding the present version.
Sub InsertBlanks()
' 02 May 2017
Dim Doc As Document
Dim WordList As Document
Dim Rng As Range
Dim Interval As String, Inter As Integer
Dim Wd As String
' you shouldn't care which Window is active,
' though it probably is the one you want, anyway.
' The important thing is which document you work on.
' Windows(OriginalStory).Activate
Set Doc = ActiveDocument
Application.ScreenUpdating = False
Set WordList = Application.Documents.Add
' If you want to use all these variables you should also declare them.
' However, except for the input itself, they are hardly necessary.
' sPrompt = "How many spaces would you like between each removed word?"
' sTitle = "Choose Blank Interval"
' sDefault = "8"
Do
Interval = InputBox("How many retained words would you like between removed words?", _
"Choose Blank Interval", CStr(8))
If Interval = "" Then Exit Sub
Loop While Val(Interval) < 4 Or Val(Interval) > 25
Inter = CInt(Interval)
' you can modify min and max. Exit by entering a blank or 'Cancel'.
' You don't need to select anything.
' Selection.HomeKey Unit:=wdStory
Set Rng = Doc.Range(1, 1) ' that's the start of the document
' Set Rng = Doc.Bookmarks("James").Range ' I used another start for my testing
Do Until Rng.Bookmarks.Exists("\EndOfDoc") = True
Rng.Move wdWord, Inter
Wd = Rng.Words(1)
If Asc(Wd) < 65 Then
Inter = 1
Else
Set Rng = Rng.Words(1)
With Rng
' replace Len(Wd) with a fixed number of repeats,
' if you don't want to give a hint about the removed word.
.Text = String(Len(Wd) - 1, "_") & " "
.Collapse wdCollapseEnd
End With
With WordList.Range
If .Words.Count > 1 Then .InsertAfter Chr(11)
.InsertAfter Wd
End With
Inter = CInt(Interval)
End If
Loop
Application.ScreenUpdating = True
End Sub
In order to avoid processing non-words my above code tests, roughly, if the first character is a letter (ASCII > 64). This will preclude numbers and it will allow a lot of symbols. For example "€100" would be accepted for replacement but not "100". You may wish to refine this test, perhaps creating a function like you originally did. Another way I thought of would be to exclude "words" of less than 3 characters length. That would eliminate CrLf (if Word considers that one word) but it would also eliminate a lot of prepositions which you perhaps like while doing nothing about "€100". It's either very simple, the way I did it, or it can be quite complicated.
Variatus - thank you so much for this. It works absolutely perfectly and will be really useful for me.
And your comments are helpful for me to understand some of the commands you use that I am not familiar with.
I'm very grateful for your patience and help.
I am currently setting up some MS Word templates in Word 2010 and have encountered a problem, where text suddenly disappears at the end of a paragraph.
The problem only occurs in some specific scenarios, but I have experienced that it can be recreated in a lot of different ways. I have not, however, been able to pinpoint the exact reason why this happens. Therefore, I would like to find the specific reason, that makes the issue occur, in order to avoid it.
It seems that a combination of the existence of wrapped tables, content in the page header and a certain length of a line can invoke the issue.
To recreate a document where this issue occurs, please follow this procedure:
Open a new document in Word 2010.
Copy the code below into a new module in the VBA editor.
Run the A_ReplicateScenario macro to insert example content in the document.
Place the cursor at the end of line 3 (the line that ends close to the margin).
Type a new sentence after the dot, beginning with a space.
The text that you have typed, will disappear when the margin is reached.
The text will then be shown if for instance a character is deleted from the original text (i.e. from the beginning of the line) or if a formatting change is made (e.g. clear formatting). The 'Show all' setting in Word can also sometimes display the text, but will only display it while 'Show all' is activated. Other times Word will display 'ghosted' double lines which can not be selected.
A short video of the replicated issue can be viewed here: https://youtu.be/Bqp9STDRkXc
Sub A_ReplicateScenario()
Call SetUpNormalStyle
Call InsertBodyTextLines
Call InsertHeaderTextLines
Call InsertWrappedTables
Call SetUpMargins
Call InsertExampleBodyText
End Sub
Sub SetUpNormalStyle()
With ActiveDocument.Styles("Normal").Font
.Name = "Arial"
.Size = 10
End With
With ActiveDocument.Styles("Normal").ParagraphFormat
.SpaceAfter = 0
.LineSpacingRule = wdLineSpaceAtLeast
.LineSpacing = 12
End With
End Sub
Sub InsertBodyTextLines()
For i = 1 To 4
Selection.TypeParagraph
Next
End Sub
Sub InsertHeaderTextLines()
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
For i = 1 To 26
Selection.TypeParagraph
Next
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
Sub InsertWrappedTables()
Selection.HomeKey Unit:=wdStory
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=1, NumColumns:=1, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
With Selection.Tables(1).Rows
.WrapAroundText = True
.HorizontalPosition = CentimetersToPoints(2)
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.VerticalPosition = CentimetersToPoints(4.5)
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
End With
Selection.Tables(1).Columns(1).PreferredWidthType = wdPreferredWidthPoints
Selection.Tables(1).Columns(1).PreferredWidth = CentimetersToPoints(11)
Selection.MoveDown Unit:=wdLine, Count:=1
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=1, NumColumns:=1, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
With Selection.Tables(1).Rows
.WrapAroundText = True
.HorizontalPosition = CentimetersToPoints(10)
.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
.VerticalPosition = CentimetersToPoints(8)
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
End With
Selection.Tables(1).Columns(1).PreferredWidthType = wdPreferredWidthPoints
Selection.Tables(1).Columns(1).PreferredWidth = CentimetersToPoints(9)
End Sub
Sub SetUpMargins()
With ActiveDocument.PageSetup
.TopMargin = CentimetersToPoints(3.8)
.BottomMargin = CentimetersToPoints(2.8)
.LeftMargin = CentimetersToPoints(2.3)
.RightMargin = CentimetersToPoints(1.5)
End With
End Sub
Sub InsertExampleBodyText()
With Selection
.HomeKey Unit:=wdStory
.MoveDown Unit:=wdLine, Count:=3
.TypeText Text:="Ouwouwouwoiwoiuwoiuwoiuwoiuwoiuwoiuwoiw oiwu oiwu owiu woiu woiuw oiwu owiu owiu ww."
.TypeParagraph
.TypeText Text:="Woiuwoiuwoiuw."
End With
End Sub
The problem is related to the tables being formatted to float around the text. Word has a long history of issues with floating objects. And although Word has improved a lot over the years you might still experience problems, in particular with floating tables.
If you change the formatting of the second table (via Table Properties) and set the text wrapping to None, the bug goes away (YMMV).
My recommendation would be to avoid the floating tables if possible.
I'm working on a Powerpoint slide, where I few texts are listed. I have to search for these texts in a Word Document which has a lot of Headings and Texts. After I find the title text, I need to copy the text under the Heading and paste in a new document.
Basically, the VBA coding has to be done in the Powerpoint VBA, with two documents in the background for searching text and pasting it in another.
I've opened the word doc. But searching the text in it and selecting it for copying to another document is what I've not been able to do. Kindly help me.
I see. The following is not exactly elegant since it uses Selection which I always try to avoid but it is the only way I know to achieve such a thing.
Disclaimer 1: this is made in Word VBA, so you will need a slight adaption, like set a reference to Word, use a wrdApp = New Word.Application object and declare doc and newdoc explicitely as Word.Document.
Disclaimer 2: Since you search for text instead of the respective heading, beware that this will find the first occurence of that text so you better not have the same text in several chapters. ;-)
Disclaimer 3: I cannot paste anymore! :-( My clipboard is set, it pastes elsewhere but I just cannot paste in here.
Code follows with first edit, hopefully in a minute...
Edit: yepp, pasting works again. :-)
Sub FindChapter()
Dim doc As Document, newdoc As Document
Dim startrange As Long, endrange As Long
Dim HeadingToFind As String, ChapterToFind As String
ChapterToFind = "zgasfdiukzfdggsdaf" 'just for testing
Set doc = ActiveDocument
Set newdoc = Documents.Add
doc.Activate
Selection.HomeKey unit:=wdStory
With Selection
With .Find
.ClearFormatting
.Text = ChapterToFind
.MatchWildcards = False
.MatchCase = True
.Execute
End With
If .Find.Found Then
'**********
'Find preceding heading to know where chapter starts
'**********
.Collapse wdCollapseStart
With .Find
.Text = ""
.Style = "Heading 1"
.Forward = False
.Execute
If Not .Found Then
MsgBox "Could not find chapter heading"
Exit Sub
End If
End With
.MoveDown Count:=1
.HomeKey unit:=wdLine
startrange = .Start
'*********
'Find next heading to know where chapter ends
'*********
.Find.Forward = True
.Find.Execute
.Collapse wdCollapseStart
.MoveUp Count:=1
.EndKey unit:=wdLine
endrange = .End
doc.Range(startrange, endrange).Copy
newdoc.Content.Paste
newdoc.SaveAs2 doc.Path & "\" & HeadingToFind & ".docx", wdFormatFlatXML
Else
MsgBox "Chapter not found"
End If
End With
End Sub
Edit: If you need to search for a "feature" that will be in some table in column 1 with the description in column 2 and you need that description in a new doc, try this:
Sub FindFeature()
Dim doc As Document, newdoc As Document
Dim FeatureToFind As String
Dim ro As Long, tbl As Table
FeatureToFind = "zgasfdiukzfdggsdaf" 'just for testing
Set doc = ActiveDocument
Set newdoc = Documents.Add
doc.Activate
Selection.HomeKey unit:=wdStory
With Selection
With .Find
.ClearFormatting
.Text = FeatureToFind
.MatchWildcards = False
.MatchCase = True
.Execute
End With
If .Find.Found Then
Set tbl = Selection.Tables(1)
ro = Selection.Cells(1).RowIndex
tbl.Cell(ro, 2).Range.Copy
newdoc.Range.Paste
End If
End With
End Sub
Edit: Slight adaptation so you can paste without overwriting existing content in newdoc:
Instead of newdoc.Range.Paste just use something along the line of this:
Dim ran As Range
Set ran = newdoc.Range
ran.Start = ran.End
ran.Paste
I am pulling text from another application and creating a MS-Word document on the fly.
Occasionally there may be some highlighting of words needed which I perform as I find these. What I cannot understand is how to cease displaying the HighlightColorIndex.
I've tried Selection.Collapse, Selection.Range.Collapse and Selection.Range.HighlightColorIndex = wdNoHighlight all to limited success. Can you assist please?
Dim lngRangeStart As Long
Dim lngRangeEnd As Long
Selection.TypeText Text:="Test of colour" ' No highlighting at present
Selection.TypeParagraph '
Selection.TypeText Text:="Starting colour after colon: " ' No highlighting at present
lngRangeStart = Selection.Start ' set to the start of the Range
Selection.Range.StartOf
Selection.TypeText Text:="This text is highlighted"
lngRangeEnd = Selection.Start ' set to the end of the Range and sel.start appears correct
Selection.SetRange Start:=lngRangeStart, End:=lngRangeEnd ' sets range correctly
Selection.Range.HighlightColorIndex = wdYellow
' >>> This is where I need to cease highlighting but what to do?
{funky code to stop highlighting here}
Selection.TypeText Text:="Now back to clear text"
You need to select text as you did before and reset its highlight to none wdNoHighlight
Use below code
' >>> This is where I need to cease highlighting but what to do?
'{funky code to stop highlighting here}
Selection.Move WdUnits.wdCharacter, 1
''Clear for text
lngRangeStart = Selection.Start
Selection.TypeText text:="Now back to clear text"
lngRangeEnd = Selection.Start
Selection.SetRange Start:=lngRangeStart, End:=lngRangeEnd ' sets range correctly
Selection.Range.HighlightColorIndex = wdNoHighlight
Selection.Move WdUnits.wdCharacter, 1
Selection.TypeText text:="Now back to the future text"
If I understand your question correctly, then you just set the highlight color to wdColorAutomatic, which is a constant specifying the automatic (default) color.
So putting it all together, to highlight text, you'd set its background to wdColorYellow. To remove the highlighting, you'd set its background to wdColorAutomatic.
I want to insert text with custom formatting, then change the font style back to what it was before the code was run.
Dim myText As String
Dim oldFont As Object
'Save old font
Set oldFont = Selection.Font
'Insert text with custom font
myText = "CUSTOM STRING"
Selection.Font.Name = "Comic Sans MS"
Selection.Font.Size = 26
Selection.Font.Bold = True
Selection.TypeText (myText)
'Revert font back to original
Set Selection.Font = oldFont
Can anyone explain a way to do what I'm looking for?
Edit: I should have been more specific. If I am typing text, I have a certain formatting that I am typing in that is shown on the Home Tab (eg. Comic Sans Ms, Size 22, Bold). When I insert text with the code, this changes the formatting that I am typing with, so if I continue typing it will be in the NEW font type, not the Comic Sans MS. I am trying to make it so if I continue typing after I have inserted the text via VBA code, it will retain my old formatting.
One simple solution is to store all properties that you are going to change, and to reset them at the end:
Dim myText As String
Dim oldFont As String
Dim oldSize As Integer
Dim oldBold As Boolean
'Save old font
oldFont = Selection.Font.Name
oldSize = Selection.Font.Size
oldBold = Selection.Font.Bold
'Insert text with custom font
myText = "CUSTOM STRING"
Selection.Font.Name = "Comic Sans MS"
Selection.Font.Size = 26
Selection.Font.Bold = True
Selection.TypeText (myText)
'Revert font back to original
Selection.Font.Name = oldFont
Selection.Font.Bold = oldBold
Selection.Font.Size = oldSize
The trick I find helpful when writing Word macros is simply to replicate what I'd be doing if I was using the Word GUI. When I want to paste formatted text but keep my current format, I type a space, paste in the text before the space then delete the space. As the space has my original format that's how I get it back.
So, doing this as a macro:
'Type a space
Selection.TypeText Text:=" "
'Move Cursor back one character
Selection.MoveLeft Unit:=wdCharacter, Count:=1
'Insert text with custom font
myText = "CUSTOM STRING"
Selection.Font.Name = "Comic Sans MS"
Selection.Font.Size = 26
Selection.Font.Bold = True
Selection.TypeText (myText)
'Move Cursor forward one character
Selection.MoveRight Unit:=wdCharacter, Count:=1
'Delete the space
Selection.TypeBackspace
This will preserve any properties of the text you originally had.
I can't quite figure out exactly what you're trying to do there, but Selection.TypeText will collapse the selection down to the insertion point, so you effectively have no characters selected by the time you try to "revert the font". You either need to re-select the text, or use a Range object instead of the Selection to identify the text to be affected.
The reason that you get an error at the line:
Set Selection.Font = oldFont
...is because - unusually, and perversely - you should not use the Set keyword when assigning to the Font property. Rather than storing a reference to a Font object, the assignment simply applies the properties of the assigned font.
This is very confusing API design, made all the more confusing because you do need to use the Set keyword when reading the Font property, and because that does assign a reference to a Font object!
And that's the other reason why your code won't work - you're taking a reference to a Font object which you then modify, and your reference points to the same Font object that has now changed.
What you actually need to do is create a new Font object to store the original font details, as follows:
Set oldFont = Selection.Font.Duplicate
The Selection.Font object is read only.
This means that there is no way to restore all the settings in one assignment. Since you are only changing a few properties the easiest solution is to save each individual value and restore them afterwards as stephan suggests.
I.e. Save properties:
oldFontName = Selection.Font.Name
oldFontSize = Selection.Font.Size
oldFontBold = Selection.Font.Bold
Do you stuff and then restore properties:
Selection.Font.Name = oldFontName
Selection.Font.Size = oldFontSize
Selection.Font.Bold = oldFontBold
See, if this piece of code gives you enough hint.
CopyFormat picks up the existing formatting by moving left from current cursor.
PasteFormat applies it to a character & from there on, the original formatting (which was copied) comes into effect.
Selection.MoveLeft unit:=wdWord, Count:=1
Selection.EndKey Extend:=wdExtend
Selection.CopyFormat
Selection.MoveRight unit:=wdWord
'* New text and new formatting
Selection.Font.Bold = True
Selection.Font.Italic = True
Selection.Font.Size = 28
Selection.TypeText "hello world"
Selection.TypeText " "
Selection.MoveLeft unit:=wdCharacter, Count:=1
Selection.EndKey Extend:=wdExtend
Selection.PasteFormat
Selection.TypeText "original formatting here"
Sub No_Format()
'
' No_Format Macro
'
'
Selection.PasteSpecial Link:=False, DataType:=wdPasteText
End Sub
this will allow you to paste the text and adopting the new formatting.