Below is a Word VBA macro that does what you need. I've tested it on
Word 2000, Word 97 and Word 2002. The code is commented, but please
let me know if you need any clarification on the code.
Notes:
1. No line of code should wrap. You may need to unwrap lines after
pasting into Word.
2. To access the Word VBA code editor, press Alt-F11 from your main
document. Paste this routine into the General code area.
Good luck with your Word project!
- Hammer
---------------------------------
Sub LinkNewDoc()
Dim strDirectory As String
Dim strFilename As String
Dim strThisFilename As String
Dim strName As String
Dim intMax As Integer
Dim intCompare As Integer
Dim intPos As Integer
Dim hypLink As Hyperlink
Dim docNew As Document
Dim pp As Word.Paragraph
' Get the current document path
strThisFilename = ActiveDocument.FullName
' Make sure there is some text selected
If ActiveDocument.ActiveWindow.Selection.Start <>
ActiveDocument.ActiveWindow.Selection.End Then
strDirectory = ActiveDocument.Path
' Make sure this file is not unnamed
If Len(strDirectory) > 0 Then
intMax = 0
' Get the list of files matching pattern
strFilename = Dir(strDirectory & Application.PathSeparator
& "~????.doc")
Do While strFilename <> ""
intPos = InStr(1, strFilename, ".")
' Confirm pattern match
If (intPos = 6) And (Left(strFilename, 1) = "~") Then
' Parse out the number
strName = Mid(strFilename, 2, 4)
intCompare = CInt(strName)
' Get the highest number
If intCompare > intMax Then
intMax = intCompare
End If
End If
strFilename = Dir
Loop
intMax = intMax + 1
' Build the new filename
strFilename = strDirectory & Application.PathSeparator &
"~" & Format(intMax, "0000") & ".doc"
' Make sure the template file exists
If Dir(strDirectory & Application.PathSeparator &
"~0001.doc") <> "" Then
' Copy the template file to the new name
FileCopy strDirectory & Application.PathSeparator &
"~0001.doc", strFilename
' Create the hyperlink in the current document
Set hypLink =
ActiveDocument.Hyperlinks.Add(ActiveDocument.ActiveWindow.Selection.Range,
strFilename)
If Not hypLink Is Nothing Then
' Open the new document
Set docNew = Documents.Open(strFilename)
If Not docNew Is Nothing Then
' Write the link text into the new document
' and link it to the current document
Set pp = docNew.Paragraphs.Add
pp.Range.Text = "Up"
Set hypLink = docNew.Hyperlinks.Add(pp.Range,
strThisFilename)
If Not hypLink Is Nothing Then
' Save all open documents
Documents.Save True, wdWordDocument
' Close the new document
docNew.Close
Else
MsgBox "Failed to create hyperlink in new document."
End If
Else
MsgBox "Could not open new documnt."
End If
Else
MsgBox "Failed to create hyperlink in main document."
End If
Else
MsgBox "Template file does not exist."
End If
Else
MsgBox ("Invalid document path.")
End If
Else
MsgBox "No text selected!"
End If
' Clean up
strDirectory = ""
strFilename = ""
strThisFilename = ""
strName = ""
Set hypLink = Nothing
Set docNew = Nothing
Set pp = Nothing
End Sub |
Clarification of Answer by
hammer-ga
on
17 Jan 2004 05:38 PST
Here you go! This version will force the link to the top of the document.
- Hammer
--------------------------------------------------
Sub LinkNewDoc()
Dim strDirectory As String
Dim strFilename As String
Dim strThisFilename As String
Dim strName As String
Dim intMax As Integer
Dim intCompare As Integer
Dim intPos As Integer
Dim hypLink As Hyperlink
Dim docNew As Document
Dim rngDoc As Range
' Get the current document path
strThisFilename = ActiveDocument.FullName
' Make sure there is some text selected
If ActiveDocument.ActiveWindow.Selection.Start <>
ActiveDocument.ActiveWindow.Selection.End Then
strDirectory = ActiveDocument.Path
' Make sure this file is not unnamed
If Len(strDirectory) > 0 Then
intMax = 0
' Get the list of files matching pattern
strFilename = Dir(strDirectory & Application.PathSeparator
& "~????.doc")
Do While strFilename <> ""
intPos = InStr(1, strFilename, ".")
' Confirm pattern match
If (intPos = 6) And (Left(strFilename, 1) = "~") Then
' Parse out the number
strName = Mid(strFilename, 2, 4)
intCompare = CInt(strName)
' Get the highest number
If intCompare > intMax Then
intMax = intCompare
End If
End If
strFilename = Dir
Loop
intMax = intMax + 1
' Build the new filename
strFilename = strDirectory & Application.PathSeparator &
"~" & Format(intMax, "0000") & ".doc"
' Make sure the template file exists
If Dir(strDirectory & Application.PathSeparator &
"~0001.doc") <> "" Then
' Copy the template file to the new name
FileCopy strDirectory & Application.PathSeparator &
"~0001.doc", strFilename
' Create the hyperlink in the current document
Set hypLink =
ActiveDocument.Hyperlinks.Add(ActiveDocument.ActiveWindow.Selection.Range,
strFilename)
If Not hypLink Is Nothing Then
' Open the new document
Set docNew = Documents.Open(strFilename)
If Not docNew Is Nothing Then
' Write the link text into the new document
' and link it to the current document
Set rngDoc = docNew.Range(Start:=0, End:=0)
rngDoc.InsertBefore "Up" & vbCrLf & vbCrLf
Set rngDoc = docNew.Range(Start:=0, End:=2)
Set hypLink = docNew.Hyperlinks.Add(rngDoc,
strThisFilename)
If Not hypLink Is Nothing Then
' Save all open documents
Documents.Save True, wdWordDocument
' Close the new document
docNew.Close
Else
MsgBox "Failed to create hyperlink in new document."
End If
Else
MsgBox "Could not open new documnt."
End If
Else
MsgBox "Failed to create hyperlink in main document."
End If
Else
MsgBox "Template file does not exist."
End If
Else
MsgBox "Invalid document path."
End If
Else
MsgBox "No text selected!"
End If
' Clean up
strDirectory = ""
strFilename = ""
strThisFilename = ""
strName = ""
Set hypLink = Nothing
Set docNew = Nothing
Set rngDoc = Nothing
End Sub
|
,
0 Comments
)