Word cannot complete the save due to a file permission error?

Need VBA/Word macro to create a new file with a hyperlink to it.

• I need a VBA/Word macro that works in MS Word 97 AND MS Word 2000 and does the following: 1. If there is no text currently highlighted in current document (the 'initial' document) or it was not loaded from a file, then return an error. 2. Identify the directory this document was loaded from. 3. Find all files in this directory of the form '~XXXX.doc', where XXXX is a zero-padded 4 digit positive integer. Add one to the largest such value to get YYYY. 4. Copy the file '~0001.doc' to the file '~YYYY.doc' and make the currently highlighted text a hyperlink to this document. 5. Modify this new document to add a hyperlink labelled '[up]' to the top of the document, which links back to the initial document. Save and close the new document.

• Answer:

  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