I'm working on a template doc that I can copy to different folders. When I open the doc I want it to find a excel file with name "Mod127*.xlsx" on the same folder and update the source path of all fields to that Excel file.
I wrote this code for that effect, and it works, with the exception of a field located in the header of the document
Dim fieldCount As Integer, x As Long
With ActiveDocument
ficheiro = Dir(.Path & "\Mod127*")
If ficheiro = "" Then
MsgBox "Model 127 not found in folder"
Else
fieldCount = .Fields.Count
For x = 1 To fieldCount
With .Fields(x)
If .Type = 56 Then ' Type 56 is an excel link
.LinkFormat.SourceFullName = ActiveDocument.Path & "\" & ficheiro
.Update
.LinkFormat.AutoUpdate = False
DoEvents
End If
End With
Next x
End If
End With
Any idea on how to reach that headers field?
I also tried cross referencing one of the fields to the heading, but I get a "reference not found" after the code runs
Headers and footers are child objects of the Section. Dependent on the page layout of the section there may be up to 3 headers and footers, so you will need to know which one(s) to update. The code below should get you started.
With .Sections(1).Headers(wdHeaderFooterPrimary).Range.Fields(1)
.LinkFormat.SourceFullName = ActiveDocument.Path & "\" & ficheiro
.Update
.LinkFormat.AutoUpdate = False
DoEvents
End With
Related
I need to update a massive number of documents with our new company logo. The task its just to replace the existing header image with a new one. I found an ancient code that should work with older versions of MS Word but it breaks on 365, so I need the help of a kind soul to guide me as I'm illiterate in VBA.
I tried the following code:
Sub ReplaceEntireHdr()
Dim wrd As Word.Application
Set wrd = CreateObject("word.application")
wrd.Visible = True
AppActivate wrd.Name
'Change the directory to YOUR folder's path
FName = Dir("C:\Test\*.doc")
Do While (FName <> "")
With wrd
'Change the directory to YOUR folder's path
.Documents.Open ("C:\Test\" & FName)
If .ActiveWindow.View.SplitSpecial = wdPaneNone Then
.ActiveWindow.ActivePane.View.Type = wdPrintView
Else
.ActiveWindow.View.Type = wdPrintView
End If
.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
.Selection.WholeStory
.Selection.Paste
.ActiveDocument.Save
.ActiveDocument.Close
End With
FName = Dir
Loop
Set wrd = Nothing
End Sub
It should open all files on a given directory, delete the header and paste the one held on the clipboard. When I try to run it, I get error '5' on line 5 (AppActivate wrd.Name).
The code you in your question is written to be run from outside Word, probably from Excel.
One thing that you need to figure out is which of the three types of header you are replacing. The code below assumes it is the main header. If you need just the first page header replace wdHeaderFooterPrimary with wdHeaderFooterFirstPage. You can tell which header you need by editing the header in the UI and checking the grey label.
The code you have is not well written and can be simplified as below.
Sub ReplaceEntireHdrXL()
Dim wrd As Word.Application
Set wrd = CreateObject("word.application")
wrd.Visible = True
'Change the directory to YOUR folder's path
Dim FName As String
FName = Dir("C:\Test\*.doc")
Dim doc As Document
Do While (FName <> "")
'Change the directory to YOUR folder's path
Set doc = wrd.Documents.Open("C:\Test\" & FName)
With doc
With .Sections(1).Headers(wdHeaderFooterPrimary).Range
.Paste
'if what you have copied includes a paragpraph mark at the end
'you may need to delete the last para in the header
.Paragraphs.Last.Range.Delete
End With
.Save
.Close
End With
FName = Dir
Loop
Set wrd = Nothing
End Sub
You can simplify things further if you run it from Word instead.
Sub ReplaceEntireHdr()
Dim FName As String
'Change the directory to YOUR folder's path
FName = Dir("C:\Test\*.doc")
Dim doc As Document
Do While (FName <> "")
'Change the directory to YOUR folder's path
Set doc = Documents.Open("C:\Test\" & FName)
With doc
With .Sections(1).Headers(wdHeaderFooterPrimary).Range
.Paste
'if what you have copied includes a paragpraph mark at the end
'you may need to delete the last para in the header
.Paragraphs.Last.Range.Delete
End With
.Save
.Close
End With
FName = Dir
Loop
End Sub
I have around 1000 word documents in one folder which the header and footer needs to be added/changed (header need to added/changed just for the first page).
I found a very helpful VBA script which is work but I tried but can not style and format to my needs, which is shown in the attached pictures
Header Style I need
Footer Style I need
The found working code which i found in stackoverflow:
Sub openAllfilesInALocation()
Dim Doc
Dim i As Integer
Dim docToOpen As FileDialog
Set docToOpen = Application.FileDialog(msoFileDialogFilePicker)
docToOpen.Show
For i = 1 To docToOpen.SelectedItems.Count
'Open each document
Set Doc = Documents.Open(FileName:=docToOpen.SelectedItems(i))
With ActiveDocument.Sections(1)
.Headers(wdHeaderFooterPrimary).Range.Text = "Header goes here"
.Footers(wdHeaderFooterPrimary).Range.Text = "Footer goes here"
End With
Doc.Save
Doc.Close
Next i
End Sub
Thanks in advance for everybody reading and/or helping me with this question, because if I can not work it out, I need to add for around 1000 word docs headers and footers manually...... :( so thanks for helping or just trying!
Before you write code for this you need to break the task down into steps.
Open one of the documents that you need to apply the changes to.
Record a macro whilst you edit the Header style so that it has the correct formatting
Record a macro whilst you edit the Footer style so that it has the correct formatting
Edit the header of the document to include whatever logo and text you require.
Select the content of the header and save as as a Building Block - on the Header & Footer tab click "Header" then "Save Selection to Header Gallery". Ensure that you pay attention to which template you are saving it to as you will need to know this later.
Edit the footer of the document to include whatever text you require.
Select the content of the footer and save as as a Building Block - on the Header & Footer tab click "Footer" then "Save Selection to Footer Gallery". Again ensure that you pay attention to which template you are saving it to.
Now you can write your code. For example:
Sub openAllfilesInALocation()
Dim Doc As Document
Dim i As Integer
Dim BBlockSource As Template
Set BBlockSource = Application.Templates("<Full path to template you stored building blocks in>")
Dim docToOpen As FileDialog
Set docToOpen = Application.FileDialog(msoFileDialogFilePicker)
docToOpen.Show
For i = 1 To docToOpen.SelectedItems.Count
'Open each document
Set Doc = Documents.Open(FileName:=docToOpen.SelectedItems(i))
MacroToModifyHeaderStyle 'name of the macros you recorded in steps 2 & 3
MacroToModifyFooterStyle
With ActiveDocument.Sections(1)
BBlockSource.BuildingBlockEntries("Name of Header Building Block").Insert .Headers(wdHeaderFooterFirstPage).Range
BBlockSource.BuildingBlockEntries("Name of Footer Building Block").Insert .Footers(wdHeaderFooterFirstPage).Range
'you may need the following if an extra paragraph is created when adding the building block
'.Headers(wdHeaderFooterFirstPage).Range.Paragraphs.Last.Range.Delete
'.Footers(wdHeaderFooterFirstPage).Range.Paragraphs.Last.Range.Delete
End With
Doc.Save
Doc.Close
Next i
End Sub
Obviously you test your code on a copy of some of the files before attempting to run it on all of them.
Simply add the following macro to a document containing your new header & footer, then run the macro, which includes a folder browser so you can select the folder to process.
Sub UpdateDocumentHeaders()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String
Dim wdDocTgt As Document, wdDocSrc As Document
Dim Sctn As Section, HdFt As HeaderFooter
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set wdDocSrc = ActiveDocument
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
If strFolder & "\" & strFile <> wdDocSrc.FullName Then
Set wdDocTgt = Documents.Open(FileName:=strFolder & "\" & strFile, _
AddToRecentFiles:=False, Visible:=False)
With wdDocTgt
For Each Sctn In .Sections
'For Headers
For Each HdFt In Sctn.Headers
With HdFt
If .Exists Then
If .LinkToPrevious = False Then
.Range.FormattedText = _
wdDocSrc.Sections.First.Headers(wdHeaderFooterPrimary).Range.FormattedText
End If
End If
End With
Next
'For footers
For Each HdFt In Sctn.Footers
With HdFt
If .Exists Then
If .LinkToPrevious = False Then
.Range.FormattedText = _
wdDocSrc.Sections.First.Footers(wdHeaderFooterPrimary).Range.FormattedText
End If
End If
End With
Next
Next
.Close SaveChanges:=True
End With
End If
strFile = Dir()
Wend
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
As coded, the macro assumes the document you're running the macro from has only one Section, with up to three populated headers (as allowed by Word), and that all headers in the target document are to be updated to match the source document's primary header & footer. If you only want to update headers in the first Section, delete the footer loop and delete 'For Each Sctn In .Sections' and it's 'Next' later in the code and change 'For Each HdFt In Sctn.Headers' to 'For Each HdFt In .Sections(1).Headers'.
Overall objective: create an Excel-based file converter that interops with Word, changing several built-in document properties, header/footer text & pics, watermark, and file name. The new attributes/text/file paths are found in cells. After changing all these attributes, et al, the file is to be copied as a regular .docx to a new Output folder and also exported as a PDF to a separate PDF Output folder. Optionally the files in the input folder will be deleted after the other steps are completed.
Specific problem: After I rename any of the files using the Name function, the File Object (I'm using File Scripting Object) loses its reference to the old file (since it's renamed), but does not pick up on the new, renamed file. After renaming the file, I would like to make a copy of it into the word document output folder; then, with the original, I would export it to the PDF output folder. Finally, I would either delete it or leave it alone, depending on an optional boolean.
I have attempted to re-assign the File Object with the new file, but this doesn't seem to be possible, and nothing else in its properties or methods makes sense to use.
Sub ChangeProperties()
Dim wordApp As Word.Application
Dim wordDoc() As Word.Document
Dim fso As New FileSystemObject
Dim fo(3) As Folder
Dim f As file
Dim cvSht As Worksheet
Dim fileSht As Worksheet
Dim progShp As Shape
Dim fileRng(0 To 13) As Range
Dim optRng As Range
Dim i As Long
Dim n As Long
Dim count As Long
Set wordApp = Word.Application
' Dashboard sheet
Set cvSht = Sheets("Convert")
' Sheet where user types new attributes or views old attributes
Set fileSht = Sheets("FileAttributes")
' Folder objects
Set fo(1) = fso.GetFolder(cvSht.Range("F3").Value)
Set fo(2) = fso.GetFolder(cvSht.Range("F5").Value)
Set fo(3) = fso.GetFolder(cvSht.Range("F7").Value)
ChDir (fo(1) & Application.PathSeparator)
Set optRng = cvSht.Range("H13")
' Just some user-defined true/false input cells
optERR = optRng
optMSG = optRng.Offset(1, 0)
optPDF = optRng.Offset(2, 0)
optDOC = optRng.Offset(3, 0)
optRMV = optRng.Offset(4, 0)
' Run some pre-execution checks to prevent catastrophic failure
If fo(1).Files.count > 20 Then
MsgBox "Too many files in folder. Please only 20 files at a time.", vbOKOnly, "Error!"
Exit Sub
End If
For i = 0 To 13
Set fileRng(i) = fileSht.Range("D27").Offset(0, i)
Next
n = 1
If InStr(1, fileRng(0).Offset(n - 1, 0), "doc") = 0 Then
MsgBox "New file names must end with a proper extension, i.e. - .docx", vbCritical, "Terminating Process!"
Exit Sub
End If
For Each f In fo(1).Files
For i = 0 To fo(1).Files.count
If fileRng(0).Value = f.Name Then
MsgBox "New file names must be different from the existing file names! Aborting...", vbCritical, "Terminating Process!"
Exit Sub
End If
Next
Next
For Each f In fo(1).Files
If optERR = False Then On Error Resume Next
If Left(f.Name, 1) = "~" Then GoTo Nxt
Set wordDoc(n) = wordApp.Documents.Open(f.Path)
' -------- Clipped out middle parts for clarity ---------
If fileRng(0).Offset(n - 1, 0) <> "" Then
End If
On Error GoTo 0
wordDoc(n).Save
Application.Wait Now + 0.00003
Application.StatusBar = "Processing..." & n & "/" & fo(1).Files.count
If optPDF Then
If Right(f, 1) = "x" Then
wordDoc(n).ExportAsFixedFormat fo(2) & Application.PathSeparator & _
VBA.Replace(f.Name, ".docx", ".pdf"), wdExportFormatPDF
ElseIf Right(f, 1) = "c" Then
wordDoc(n).ExportAsFixedFormat fo(2) & Application.PathSeparator & _
VBA.Replace(f.Name, ".doc", ".pdf"), wdExportFormatPDF
ElseIf Right(f, 1) = "m" Then
wordDoc(n).ExportAsFixedFormat fo(2) & Application.PathSeparator & _
VBA.Replace(f.Name, ".docm", ".pdf"), wdExportFormatPDF
End If
End If
wordDoc(n).Close
**Name f.Name As fileRng(0).Offset(n - 1, 0).Value** ' Causes the next lines to fail
**Set f = fileRng(0).Offset(n - 1, 0).Value** ' Attempt to reassign fails
**If optDOC Then f.Copy (fo(3) & "/")** ' This would fail too
If optRMV Then f.Delete
Nxt:
On Error GoTo 0
n = n + 1
Next
End Sub
My problem is the following:
I want to define a range, including cells in my spreadsheet that contain formatted text (bold font), and turn it into any object that I can later use as the body for an outlook e-mail.
One of the ways I have tried so far is via the RangetoHTML function by Ron de Bruin (http://www.rondebruin.nl/win/s1/outlook/bmail2.htm). However, the function brings the text cells into another excel workbook which finally yields a table in the outlook e-mail. I want to keep the very same format that I start with in my excel cells. That is, it must be lines of ordinary text and not a table-like body in the mail.
That's my current code:
Sub Mail_Selection_Range_Outlook_Body()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Sheets("Preparation").Range("A90:A131")
With Selection
.Value = rng.Text
.Font.Bold = rng.Font.Bold
.Font.Color = rng.Font.Color
End With
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.HTMLBody = RangetoHTML(rng)
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Thanks in advance for your help
Ron de Bruin’s RangeToHtml shows how to use Excel’s PublishObjects to convert a worksheet range to Html that can be used as the body of an email. I am sure this has helped thousands of developers.
The difficulty that RdeB overcomes is that PublishObjects is designed to create and maintain webpages. His routine outputs to a file and then reads that file because that is the only way to get the Html string required for the email body.
The difficulty that RdeB cannot overcome is that PublishObjects create poor quality, proprietary CSS. By “poor quality”, I mean that there is a lot of unnecessary CSS and that row heights and column widths are defined in points to give sizes suitable for a PC. By “proprietary”, I mean it uses styles such as mso-ignore:padding and mso-number-format:General that only Microsoft browsers are guaranteed to understand. It appears the major browsers are able to cope but many people have found that some newer browsers cannot cope and display rubbish.
To demonstrate this and to test my code, I created a worksheet based on your image. Rows 16 to 18 are right-aligned because I have specified this. Rows 20 to 22 are right aligned because this is the Excel default for numeric, date and time values. Its appearance is:
You can use your real data.
Copy this code to your workbook:
Option Explicit
Sub Test1()
Dim PathCrnt As String
Dim PathFileCrnt As String
Dim RngStr As String
Dim WshtName As String
PathCrnt = ThisWorkbook.Path & "\" ' ## Output to the same folder as workbook holding the macro
PathFileCrnt = PathCrnt & "Test1.html" ' ## Change if you do not like my filename
WshtName = "Sheet1" ' ## Change to your worksheet
RngStr = "A1:A28" ' ## Change to your range
With ThisWorkbook
With .PublishObjects.Add(SourceType:=xlSourceRange, _
Filename:=PathFileCrnt, _
Sheet:=WshtName, _
Source:=RngStr, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
End With
End Sub
You will need to change some of the statements near the top marked with ##
Run this macro to output your range to the file.
On my laptop, Microsoft Edge, Microsoft Internet Explorer and Google Chrome all display the file and all look the same although IE and Chrome are slow to display. The column is down the centre of the window:
There are none of the background grey cells and wide, white border you showed. However, I have not tried to display it within Outlook.
Now look at the file with your favourite text editor. Notice how much CSS is repeated. Notice how many style start “mso-” indicating they are Microsoft extensions. Notice the heights and widths measured in “pt” (points). Some Html display engines can cope but some cannot.
I suspect that PublishObjects has not been maintained. It was available with Excel 2003 and perhaps earlier. Some of the old Microsoft CSS extensions now have standard CSS equivalents but PublishObjects has not been updated to use them.
I have my own RangeToHtml written entirely in VBA. It will handle all formatting except borders. My code is far too big to post on Stack Overflow so I have extracted the bits you need. You apparently need bold or not bold and left or right alignment. I do not know if you specify right alignment or if you have numeric fields which right align by default so I handle both.
My function ColToHtml(range) returns a complete Html file for the first column of a range. My code does not create a temporary workbook or a temporary file. It produces clean, crisp Html and Css. It produces a table because you cannot have right-alignment outside a table. However, with no borders, it is not obvious the output is a table. The only difference in appearance is that the table is left aligned. If you prefer a centred table, it would be an easy change.
This was my test routine:
Sub Test2()
Dim Rng As Range
With Worksheets("Sheet1")
Set Rng = .Range(.Cells(1, 1), .Cells(28, 1))
End With
Debug.Print ColumnToHtml(Rng)
End Sub
It outputs the Html string to the Immediate Window. I then copied it to a file. I could have used VBA to write to a file but this was easier. When I opened the file with Microsoft Edge, it looked the same. Have a look at this second file with your favourite text editor. Notice how much smaller it is. The PublishObjects version is 6,901 bytes while this second version is 1,681 bytes. Notice how only standard Css is used and that the minimum of Css is used. This allows the display engine to make its own decisions about how to display the file based on the type of output device.
My last test was:
Sub Test3()
' This will need a reference to Microsoft Outlook nn.0 Outlook library
' where nn is the number of the Outlook version you are using.
Dim Rng As Range
Dim OutApp As Outlook.Application
Dim MailItemNew As Outlook.MailItem
With Worksheets("Sheet1")
Set Rng = .Range(.Cells(1, 1), .Cells(28, 1))
End With
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set MailItemNew = OutApp.CreateItem(olMailItem)
With MailItemNew
.BodyFormat = olFormatHTML
.HTMLBody = ColumnToHtml(Rng)
.Display
End With
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set MailItemNew = Nothing
Set OutApp = Nothing
End Sub
This outputs the range to Outlook. I have used your code as a template but have referenced the Outlook library so I can use Outlook objects and constants. I had to reduce the font size to get it all on the screen at one time giving:
Again this has the same appearance except that the first letter of each line has been capitalized. I do not know how to stop the Outlook email editor doing this.
Incidentally, I selected the entire email and got the same appearance as in the image you posted.
The code for ColumnToHtml is below. Note that CellToHtml is the routine that actually creates the Html for a cell. It only handles bold and right alignment but it should be obvious that it would be easy to add other cell-level formats.
Function ColumnToHtml(ByRef RngCol As Range) As String
' Returns the first or only column of rng as a borderless table
' so it appears as a formatted list of rows.
Dim RngCell As Range
Dim RowCrnt As Long
Dim Table As String
' Build an Html table of the cells within the first column of RngCol
' ==================================================================
Table = Space(4) & "<table border=""0"">" & vbLf
For RowCrnt = RngCol.Row To RngCol.Row + RngCol.Rows.Count - 1
Set RngCell = RngCol.Worksheet.Cells(RowCrnt, RngCol.Column)
Table = Table & Space(6) & "<tr>" & CellToHtml(RngCell) & "</tr>" & vbLf
Next
Table = Table & Space(4) & "</table>"
' Build an Html file envelope around the table
' ============================================
ColumnToHtml = "<!DOCTYPE html PUBLIC ""-//W3C//DTD XHTML 1.0 Frameset//EN""" & _
"""http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd"">" & vbLf & _
"<html xmlns=""http://www.w3.org/1999/xhtml"" xml:lang=""en"" lang=""en"">" & vbLf & _
" <head></head>" & vbLf & _
" <meta http-equiv=""Content-Type""content=""text/html; charset=utf-8""/>" & vbLf & _
" <style>" & vbLf & _
" td.bold {font-weight:bold;}" & vbLf & _
" td.hAlign-right {text-align:right;}" & vbLf & _
" </style>" & vbLf & _
" </head>" & vbLf & _
" <body>" & vbLf & Table & vbLf & _
" </body>" & vbLf & _
"</html>"
End Function
Function CellToHtml(ByRef RngCell As Range) As String
' Convert a single cell to Html.
' This code handles: value, bold or not-bold (default) and left )default) or
' right-alignment.
' Note RngCell.Value is the value perhaps "1234" or "42999".
' and RngCell.Text is the display text perhaps "1,234" or "21-Sep-17".
' This is particularly important with dates and time where the
' value is unlikely to be what is displayed.
' Dates are held as days since 1-Jan-1900 and times are held as
' seconds-since-midnight / seconds-in-a-day. It is the NumberFormat that
' determine what you see.
Dim BoldCell As Boolean
Dim RAlignedCell As Boolean
Dim Style As String
Dim StyleNeeded As Boolean
CellToHtml = "<td"
' Add interior formatting here if required
If RngCell.Value = "" Then
' Ignore font and alignment formatting of empty cell.
Else
' Test for formats
BoldCell = False
RAlignedCell = False
Style = ""
StyleNeeded = False
If RngCell.Font.Bold Then
BoldCell = True
StyleNeeded = True
End If
If RngCell.HorizontalAlignment = xlRight Or _
(RngCell.HorizontalAlignment = xlGeneral And _
(IsNumeric(RngCell.Value) Or IsDate(RngCell.Value))) Then
RAlignedCell = True
StyleNeeded = True
End If
If StyleNeeded Then
CellToHtml = CellToHtml & " class="""
If BoldCell Then
If Style <> "" Then
Style = Style & " "
End If
Style = Style & "bold"
End If
If RAlignedCell Then
If Style <> "" Then
Style = Style & " "
End If
Style = Style & "hAlign-right"
End If
CellToHtml = CellToHtml & Style & """"
End If
End If
CellToHtml = CellToHtml & ">" ' Terminate "<td"
If RngCell.Value = "" Then
' Blank rows are displayed narrow. Use Non-blank space so display at homral width
CellToHtml = CellToHtml & " "
Else
CellToHtml = CellToHtml & RngCell.Text
End If
CellToHtml = CellToHtml & "</td>"
End Function
One last comment. You have not selected anything so I do not see the purpose of this code:
With Selection
.Value = rng.Text
.Font.Bold = rng.Font.Bold
.Font.Color = rng.Font.Color
End With
I have a Word document that contains a table with 3 columns. I'm trying to create a macro that will open a pdf file (name stored in columns 2) at the page number in column 3.
I found a macro in Excel that will open it automatically when I select the page number cell, but nothing in Word. Lots of users are using the Word document and don't want to switch to Excel.
Best will be to activate the macro with a keybord shortcut and if in the table, it will open the file at the page specified in the row where the cursor is. If cursor is not in the table, an error could show.
Thanks.
[EDIT]
Here is the code for the Excel macro. Note that the Adobe Reader path and program is store in cell B1 and the file is in cell B2 in this example.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Row > 4 And Target.Column = 1 And Target.Value > 0 Then
vAdobe = ActiveSheet.Cells(1, 2)
vDocument = ActiveSheet.Cells(2, 2)
vPage = Target.Value
result = Shell(vAdobe & " /A ""page=" & vPage & """ " & vDocument, vbNormalFocus)
End If
End Sub
Here's one way:
Sub OpenPDF()
Dim aRow As Row
Dim vDocument As String
Dim vPage As String
Dim vAdobe As String
Dim result As Long
vAdobe = <File path to Acrobat.exe here.>
If Selection.Information(wdWithInTable) = True Then
Set aRow = Selection.Range.Rows(1)
vDocument = Trim(Replace(Replace(aRow.Cells(2).Range.Text, "", ""), vbCr, ""))
vPage = Trim(Replace(Replace(aRow.Cells(3).Range.Text, "", ""), vbCr, ""))
result = Shell(vAdobe & " /A ""page=" & vPage & """ " & vDocument, vbNormalFocus)
Else: 'Some error message here.
End If
End Sub
You may need to play with those Replace methods; I found it necessary to remove some table characters that were appearing at the end of any text pulled from the table cell.
Another option that requires setting a reference can be found here: http://www.myengineeringworld.net/2012/07/vba-macro-to-open-pdf-file.html