I have a VBA program that automates assembly of Word documents from other docs using mostly copy/pasting and bookmark insertions. One template won't save after copying from another document. Here is the code that errors:
'get starting doc w macro (styletemplate)
Set mydoc = wrd.Documents.Open(strformattemplate, False, False)
'this is the base doc with styles - this save works fine
mydoc.SaveAs2 filename:=strNewName,FileFormat:=wdFormatXMLDocumentMacroEnabled
'here's our skeleton this is what we want to copy in
Set skel = wrd.Documents.Open(skelpath)
Set rangetocopy = skel.Range(0, skel.Bookmarks("\endofdoc").End)
rangetocopy.copy ' copy to clipboard
'copy in the skeleton and close it
Set workingrange = mydoc.Range(0, mydoc.Bookmarks("\endofdoc").End)
workingrange.Paste
mydoc.Save 'here's where it's failing
skel.Close False
The second save fails. There is an endless pop-up. The user must abort. I want to emphasize that this code works on all other templates. It appears to fail if one shape (a box that is an underline for a header) is included. Boxes like this appear in the first page of each chapter.
Related
In the active word document I have a macro which extracts a text string and all images from the document.
I want to copy this text and the picture in a new blank word document.
I tried the following
Dim docNew As Document
Set docNew = Documents.Add
With ThisDocument
...
docNew.Content.Text = docNew.Content.Text & vbCrLf & sSentence
For Each iShape In .InlineShapes
iShape.Select
Selection.CopyAsPicture
docNew.Content.Paste
Next iShape
End With
When I execute this code, first the text is copied correctly to the new blank document. But when the picture is pasted, it overwrites the text and only the picture remains in the document.
How do I have to modify the code so that the text as well as all pictures are included?
As you would have discovered from looking at the help text .Content represents the whole of the main body of the document.
Assuming you want to add the pictures at the end of the document, replace
docNew.Content.Paste
with
With docNew.Content
.InsertParagraphAfter
.Paragraphs.Last.Range.Paste
End With
To summarize what I'm attempting to do, I work for a non-profit organization that sends out acknowledgement letters when someone donates money to us (a thank you, basically). We have multiple different letters that are written every month and sent to IS to "process". I would like to make this as efficient and use as little time as possible for IS, so I've created a program in VB.NET that takes content and pastes it into a template using Word bookmarks, updates a table in SQL so that the letter can be tested with live data, and sends an e-mail to the Production department letting them know to test the letter. It works fully, except...
I cannot for the life of me figure out how to retain RTF (RichText) when I insert the content into the letter template.
I've tried saving the content of the RichTextBox as an RTF file, but I can't figure out how to insert the RTF file contents into my document template and replace the bookmark.
I've tried using the Clipboard.SetText, odoc......Paste method, but it's unreliable as I can't accurately state where I'd like the text to paste. The find/replace function isn't very helpful because all of the bookmarks I'm trying to replace are within text boxes.
I'd show some code, but most of it has been deleted out of frustration for not working. Either way, here's some code I've been working with:
Private Sub testing()
strTemplateLocation = "\\SERVER\AcknowledgementLetters\TEST\TEMPLATE.dot"
Dim Selection As Word.Selection
Dim goWord As Word.Application
Dim odoc As Word.Document
goWord = CreateObject("Word.Application")
goWord.Visible = True
odoc = goWord.Documents.Add(strTemplateLocation)
Clipboard.Clear()
Clipboard.SetText(txtPreD.Rtf, TextDataFormat.Rtf)
odoc.Content.Find.Execute(FindText:="<fp>", ReplaceWith:=My.Computer.Clipboard.GetText)
'Code for looping through all MS Word Textboxes, but didn't produce desired results
For Each oCtl As Shape In odoc.Shapes
If oCtl.Type = Microsoft.Office.Core.MsoShapeType.msoTextBox Then
oCtl.TextFrame.TextRange.Text.Replace("<fp>", "Test")
goWord.Selection.Paste()
End If
Next
'Clipboard.Clear()
'Clipboard.SetText(txtPostD.Rtf, TextDataFormat.Rtf)
'odoc.Content.Find.Execute(FindText:="<bp>", ReplaceWith:="")
'goWord.Selection.Paste()
MsgBox("Click Ok when finished checking.")
odoc.SaveAs2("\\SERVER\AcknowledgementLetters\TEST\TEST.docx")
odoc = Nothing
goWord.Quit(False)
odoc = Nothing
goWord = Nothing
End Sub
...and here is the default code for setting bookmarks. This works perfectly as long as formatting is not required:
Private Sub SetBookmark(odoc As Object, strBookmark As String, strValue As String)
Dim bookMarkRange As Object
If odoc.Bookmarks.Exists(strBookmark) = False Then
Exit Sub
End If
bookMarkRange = odoc.Bookmarks(strBookmark).Range
If ((Err.Number = 0) And (Not (bookMarkRange Is Nothing))) Then
bookMarkRange.text = strValue
odoc.Bookmarks.Add(strBookmark, bookMarkRange)
bookMarkRange = Nothing
End If
End Sub
TL;DR - Need formatted text (Example: "TEST") to be inserted into a Word document either as a bookmark or as a replacement text.
Expected results: Replace "fp" (front page) bookmark with "TEST" including bold formatting.
Actual results: "fp" is not replaced (when using clipboard and find/replace method), or is replaced as "TEST" with no formatting.
I figured it out! I had to do it a weird way, but it works.
The following code saves the RichTextBox as an .rtf file:
RichTextBoxName.SaveFile("temp .rtf file location")
I then used the following code to insert the .rtf file into the bookmark:
goWord.ActiveDocument.Bookmarks("BookmarkName").Select()
goWord.Selection.InsertFile(FileName:="temp .rtf file location")
I then deleted the temp files:
If My.Computer.FileSystem.FileExists("temp .rtf file location") Then
My.Computer.FileSystem.DeleteFile("\temp .rtf file location")
End If
Current Code:
Const cName = "ChartDummy"
Const rName = "Availability"
Const iconSource = "C:\user.name\defaulfolder\"
'/* Availability is a named Range for this example but can be any valid range */
'/* UF_EmoTrans is a Userform with and Image Control named I_Console */
Dim oCh As ChartObject, chImg As String
Dim Ch As Object
Application.DisplayAlerts = False
With Sheet2
'.Activate
chImg = iconSource & "availIcon.jpg"
Set oCh = .ChartObjects.Add(370, 14, 180, 277.2): oCh.Name = cName
.Range(rName).CopyPicture xlScreen, xlBitmap
'oCh.Activate
oCh.Chart.Paste
oCh.Chart.Export chImg, "JPG"
'/* I call this procedure at UserForm_Initialize */
UF_EMOTrans.I_Console.Picture = LoadPicture(chImg)
oCh.Delete
End With
My current code works when I run it in break mode (using F8 and stepping through each line).
It exports the Range as image(through chartobject) and loads it to the userform just fine.
Now, when I run this in execution mode (loading the form), it doesn't create the same result.
It seems the oCh.Chart.Paste method didn't fire and so no image was paste within the chart.
Once exported, it produces a picture with plain white background.
So my question is, why is that? Why does it behave differently?
P.S.:
It will work if the chart is activated (but you will need to activate the sheet first) prior pasting (commented lines).
But I just want to know if this is one of those oddities that Excel have that we just have to live with.
When you show Userform, show userform modeless.
or When your proceure include userform.show , the image worked well.
UF_EMOTrans.Show (vbModeless)
or
UF_EMOTrans.Show (0)
I have a table in a Word file A which contains a bunch of different Contents. Which I just copy using VBA into another Word or PowerPoint file B. So far that is not a problem.
However, since file A is a working sheet, people sometimes cross stuff out, which means: it should be removed, but for the record it stays in there first. In the final version it shouldnt be displayed, so in the process of copying everything in a different file, the crossed out text should be removed.
To break it down to the technical stuff:
I want to select text in a Word document, and then remove all text that has a certain formatting.
Maybe there is a special selection possibility or a way to iterate through all characters and test for formatting.
The best way to do this without suffering severe performance iterating characters or paragraphs in vba is to use find and replace.
You can do this in vba as follows, note I have wrapped all the actions in a custom undo record, then you can call your current vba routine with CopyDocumentToPowerPoint and the word document will be restored to the state it was before the macro ran (crossed out text remains in word, but is not pasted to powerpoint).
'wrap everything you do in an undo record
Application.UndoRecord.StartCustomRecord "Move to powerpoint"
With ActiveDocument.Range.Find
.ClearFormatting
.Font.StrikeThrough = True
.Text = ""
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With
'copy to powerpoint and whatever else you want
CopyDocumentToPowerPoint
Application.UndoRecord.EndCustomRecord
'and put the document back to where you started
ActiveDocument.Undo
It is possible to go character-by-character and remove those which have the strikethrough font enabled on them (the ones which are crossed out) in MS Word. However, as far as I know, there is no such possibility to detect a strike-through font in MS PowerPoint.
If you just need to delete the text which has the strikethrough font on it in the selected text only, you can use this Word macro:
Sub RemoveStrikethroughFromSelection()
Dim char As Range
For Each char In Selection.Characters
If char.Font.StrikeThrough = -1 Then
char.Delete
End If
Next
End Sub
If more integrated to copying a Word table to another Word document and PowerPoint presentation, the following code might be useful. It first pastes the table to a new Word file, then removes unnecessary characters, and after that pastes this new table to PowerPoint.
Sub CopyWithoutCrossedOutText()
Dim DocApp As Object: Set DocApp = CreateObject("Word.Application")
Dim PptApp As Object: Set PptApp = CreateObject("PowerPoint.Application")
Dim Doc As Object: Set Doc = DocApp.Documents.Add
Dim Ppt As Object: Set Ppt = PptApp.Presentations.Add
Dim c As Cell
Dim char As Range
DocApp.Visible = True
PptApp.Visible = True
'Copying Word table to the 2nd Word document
ThisDocument.Tables(1).Range.Copy
Doc.ActiveWindow.Selection.Paste
'In the 2nd Word document - removing characters having strikethrough font enabled on them
For Each c In Doc.Tables(Doc.Tables.Count).Range.Cells
For Each char In c.Range.Characters
If char.Font.StrikeThrough = -1 Then
char.Delete
End If
Next
Next
'Copying the table from the 2nd Word document to the PowerPoint presentation
Doc.Tables(1).Range.Copy
Ppt.Slides.Add(1, 32).Shapes.Paste
End Sub
I am particularly new to coding, not to mention VBA. After a week of really cracking down on learning VBA, I've started to get the hang of it. At the moment, I'm trying to put together a code that will pull the hyperlinks (both addresses and names) out of a word document (eventually word, excel, and power point files), and dump them into the excel file I run the code from. It also dumps the file path and name at the top of the list. I can run the code and pull links from 1 file at a time, and the code pops it out after the end of the last filled line. It will save me endless amounts of time when I have to update links.
Sub ExtractWordLinks()
'the following code gets and sets an open file command bar for word documents
Dim Filter, Caption, SelectedFile As String
Dim Finalrow As String
Filter = "docx Files (*.docx),*.docx, doc Files (*.doc),*.doc, xlsm Files (*.xlsx),*.xlsx"
Caption = "Please Select .doc, .docx, .xlsx files only, " & TheUser
SelectedFile = Application.GetOpenFilename(Filter, , Caption)
'check if value is blank if it is exit
Finalrow = Cells(Rows.Count, 1).End(xlUp).Row
If (Trim(SelectedFile) = "") Then
Exit Sub
Else
'setting up the inital word application object
Set wordapp = CreateObject("word.Application")
'opening the document that is defined in the open file dialog
wordapp.documents.Open (SelectedFile)
'ability to change wether it needs to burn cycles updating the UI
wordapp.Visible = False
'declare excel sheet
Dim xlsSheet As Excel.Worksheet
'set active sheet
Set xlsSheet = Application.ActiveSheet
Dim i As Integer
i = 1
'MsgBox (wordapp.ActiveDocument.Hyperlinks.Count)
For i = 1 To wordapp.ActiveDocument.Hyperlinks.Count
'puts the title of the document in the formatted cells
'xlsSheet.Cells(Finalrow + 1, 1).Value = wordapp.ActiveDocument.Path & "\" & wordapp.ActiveDocument.Name
'formats the file name cell to be a bit easier to discern from the listing.
Range(Cells(Finalrow + 1, 1), Cells(Finalrow + 1, 2)).Font.Bold = True
Range(Cells(Finalrow + 1, 1), Cells(Finalrow + 1, 2)).Merge
'save the links address.
xlsSheet.Cells(Finalrow + i, 1).Value = wordapp.ActiveDocument.Hyperlinks(i).Address
'save the links display text
xlsSheet.Cells(Finalrow + i, 2).Value = wordapp.ActiveDocument.Hyperlinks(i).TextToDisplay
Next
wordapp.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
wordapp.Quit SaveChanges:=wdDoNotSaveChanges
End If
End Sub
My problem, is that when I run this code on a simple sample file with 3 or so hyperlinks in it across a single page, it returns everything exactly how I want, with the file path/name at the top and all the links in the page directly below it (address in one column, displayed text in the other). However, when I run it on one of the files I am writing this code for (a 95+ page .docx file with ~30 links), it prints out the path/file in the formatted section, and then drops 90 (90 every time) blank lines before printing out the path/file a second time, and then all the links in the document. It does it perfectly, except for the inexplicable second path/file (even there if I comment out the bit I put in) and the 90 blank entries.
Can anyone explain what's going on, or should I try to figure out a way to just bypass the issue by removing my own link code, and including a bit that removes all blank lines?