I would like to have the #Name from textbox to header and footer, any solution?
See the attached file. It attempts to replace each keyword in the:
a. Main Body
b. Header
c. Footer
I figured the general 'replace all' was better than replace some keywords in the 'Main Body', and/or some in the 'Header', and/or some in the 'Footer'. The code can be modified to do each section separately if that is what you want.
I want to thank MacroPod in post #5 of the following link, for header/footer replacement code: http://www.msofficeforums.com/word-v...er-footer.html
In an ordinary code module:
Sub ExportUserFormDataToWord()
'This Replaces Text in a Word Document with text from a UserForm
'
'Text in the Word Document is in the form of KEYWORDS preceeded by the '#' sign
'e.g. The KEYWORD '#Name' (no apostrophes) is a KEYWORD
'This is the name of the WORD file that will be accessed
'The file MUST BE in the same folder as this file
Const sWordFileNAME = "ExistingTemplate.doc"
'Reference Post #5: http://www.msofficeforums.com/word-vba/22669-created-vba-find-replace-body-header-footer.html
'Thank you MacroPod
'
'
'Enumerated constants reference:
'http://include.wutils.com/com-dll/constants/constants-Word.htm
'
'Word methods reference:
'https://msdn.microsoft.com/en-us/library/office/ff822886.aspx
'
'The following CONSTANTS that start with 'wd' allow the use of 'Late Binding'
'which does NOT require the inclusion of 'Microsoft Word xx.x Object Library' as a VBA REFERENCE
Const wdCatalog = 3
Const wdDefaultFirstRecord = 1
Const wdDefaultLastRecord = -16
Const wdDirectory = 3
Const wdDoNotSaveChanges = 0
Const wdSaveChanges As Long = -1
Const wdPromptToSaveChanges As Long = -2
Const wdEMail = 4
Const wdEnvelopes = 2
Const wdFax = 5
Const wdFormLetters = 0
Const wdMailingLabels = 1
Const wdNotAMergeDocument = -1
Const wdOpenFormatAuto = 0
Const wdSendToNewDocument = 0
Const wdMove = 0
Const wdExtend = 1
Const wdWord = 2
Const wdSentence = 3
Const wdStory = 6
Const wdFindContinue = 1
Const wdReplaceNone = 0
Const wdReplaceOne = 1
Const wdReplaceAll = 2
Dim WordApp As Object
Dim WordDoc As Object
Dim sNewName As String
Dim sNewGender As String
Dim sPath As String
Dim sPathAndWordFileName As String
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Initial Processing
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Get the Current Path of the file running the code
sPath = ThisWorkbook.Path & "\"
'Create the Path and Word File Combination
sPathAndWordFileName = sPath & sWordFileNAME
'Make sure the Word file exists
If LJMFileExists(sPathAndWordFileName) = False Then
MsgBox "Microsoft Word file DOES NOT EXIST." & vbCrLf & _
"Folder: " & sPath & vbCrLf & _
"File: " & sWordFileNAME
Exit Sub
End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Get Replacement Values from the UserForm (remove leading/trailing spaces)
''''''''''''''''''''''''''''''''''''''''''''''''''''''
sNewGender = Trim(UserForm1.ComboBoxGender.Value)
sNewName = Trim(UserForm1.TextBoxName.Value)
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Open the Word File Document
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Create Word application object
Set WordApp = CreateObject("Word.Application")
'Create Word Document Object and Open Word file
'Make the word application visible
'Set the focus on the Word document
Set WordDoc = WordApp.documents.Open(sPathAndWordFileName)
WordApp.Visible = True
WordApp.Application.Activate
'Open the Word File
WordApp.documents.Open sPathAndWordFileName
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Replace Text in the Word Document:
'a. Main Body
'b. Header
'c. Footer
''''''''''''''''''''''''''''''''''''''''''''''''''''''
Call ReplaceWordDocumentTextInMainBodyHeaderAndFooter(WordDoc, "#Name", sNewName)
Call ReplaceWordDocumentTextInMainBodyHeaderAndFooter(WordDoc, "#Gender", sNewGender)
''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Termination
''''''''''''''''''''''''''''''''''''''''''''''''''''''
ERROR_EXIT:
'NOTE: The following code will not prompt the user to save changes in Excel 2003
' WordApp.Quit WILL prompt the user to save changes (if any)
'
'Save and Close the Word document
'WordDoc.Saved = False
'WordDoc.Save
'WordDoc.Close SaveChanges:=wdDoNotSaveChanges
'WordDoc.Close SaveChanges:=wdPromptToSaveChanges 'Close options: wdSaveChanges or wdPromptToSaveChanges
'Close Microsoft Word
'Word asks about what to do with the OUTPUT FILE
WordApp.Quit
'Clear object pointers
Set WordApp = Nothing
Set WordDoc = Nothing
End Sub
Sub ReplaceWordDocumentTextInMainBodyHeaderAndFooter(WordDoc As Object, sOriginalText As String, sReplacementText As String)
'This replaces Text in a Word Document:
'a. Main Body
'b. Header
'c. Footer
Dim myWordSection As Object
Dim myWordHeaderFooter As Object
'Replace 'Main Body' Text
Call ReplaceWordDocumentText(WordDoc.Range, sOriginalText, sReplacementText)
'Replace 'Header' and 'Footer' Text
For Each myWordSection In WordDoc.Sections
'Replace 'Header' Text
For Each myWordHeaderFooter In myWordSection.Headers
Call ReplaceWordDocumentText(myWordHeaderFooter.Range, sOriginalText, sReplacementText)
Next myWordHeaderFooter
'Replace 'Footer' Text
For Each myWordHeaderFooter In myWordSection.footers
Call ReplaceWordDocumentText(myWordHeaderFooter.Range, sOriginalText, sReplacementText)
Next myWordHeaderFooter
Next myWordSection
End Sub
Sub ReplaceWordDocumentText(myWordRange As Object, sOriginalText As String, sReplacementText As String)
'This replaces Word Document Text in a Given Range (usually a section) in a Word Document
'
'Reference Post #5: http://www.msofficeforums.com/word-vba/22669-created-vba-find-replace-body-header-footer.html
'Thank you MacroPod
'The following CONSTANTS that start with 'wd' allow the use of 'Late Binding'
'which does NOT require the inclusion of 'Microsoft Word xx.x Object Library' as a VBA REFERENCE
Const wdFindContinue = 1
Const wdReplaceNone = 0
Const wdReplaceOne = 1
Const wdReplaceAll = 2
'First search the main document using the Selection
With myWordRange.Find
.Text = sOriginalText
.Replacement.Text = sReplacementText
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
End Sub
Private Function LJMFileExists(sPathAndFullFileName As String) As Boolean
'This returns TRUE if a file exists and FALSE if a file does NOT exist
Dim iError As Integer
Dim iFileAttributes As Integer
On Error Resume Next
iFileAttributes = GetAttr(sPathAndFullFileName)
'Check the internal error return
iError = Err.Number
Select Case iError
Case Is = 0
iFileAttributes = iFileAttributes And vbDirectory
If iFileAttributes = 0 Then
LJMFileExists = True
Else
LJMFileExists = False
End If
Case Else
LJMFileExists = False
End Select
On Error GoTo 0
End Function
Lewis
LinkBack URL
About LinkBacks
Exporting UserForm data to Word
)
Register To Reply
Bookmarks