Need Help: VBA to name and save a merged doc

[tx7399]

Hi everyone,

Help needed (vba newbie):
I have a word doc (template.docx) that I open and mail merge to one record (from excel file). This creates “Letter1”. Using vba, I would like to be able to save “ Letter1” using the text of the entire first line of “Letter1” as the filename. The newly named file needs to be saved on the user desktop (ie the desktop of ANY user running this merge) but remain open. Then automatically close “template.docx” without saving changes. Now I would be able to edit the newly named file which remained open on the desktop as necessary and save my changes with a simple “save” and “close”.

Any help would be greatly appreciated.

[gmayor]

The following will save the previously merged document with the first line of the merged document that contains text on the desktop and close the merge document without saving it, leaving the named document open.




Option Explicit

Private Declare Function SHGetSpecialFolderLocation _
Lib "shell32" (ByVal hwnd As Long, _
ByVal nFolder As Long, ppidl As Long) As Long
Private Declare Function SHGetPathFromIDList _
Lib "shell32" Alias "SHGetPathFromIDListA" _
(ByVal Pidl As Long, ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32" (ByVal pvoid As Long)
Private Const CSIDL_DESKTOP = &H0 'Desktop
Private Const MAX_PATH = 260
Private Const NOERROR = 0

Sub SaveDoc()
Dim oDoc As Document
Dim oSource As Document
Dim strFilename As String
Dim orng As Range
Dim oPara As Paragraph
Set oDoc = ActiveDocument
For Each oSource In Documents
If Not oSource.MailMerge.MainDocumentType = wdNotAMergeDocument Then
If LCase(oSource.name) = "template.docx" Then
oSource.Close 0
Exit For
End If
End If
Next oSource
On Error GoTo lbl_Exit
For Each oPara In oDoc.Range.Paragraphs
If Len(oPara.Range) > 2 Then
Set orng = oPara.Range
orng.End = orng.End - 1
Exit For
End If
Next oPara
strFilename = orng.Text & ".docx"
strFilename = Trim(CleanFileName(strFilename, "docx"))
strFilename = SpecFolder(&H0) & strFilename
oDoc.SaveAs strFilename
lbl_Exit:
Set oSource = Nothing
Set oDoc = Nothing
Set oPara = Nothing
Set orng = Nothing
Exit Sub
End Sub

Private Function SpecFolder(ByVal lngFolder As Long) As String
Dim lngPidlFound As Long
Dim lngFolderFound As Long
Dim lngPidl As Long
Dim strPath As String

strPath = Space(MAX_PATH)
lngPidlFound = SHGetSpecialFolderLocation(0, lngFolder, lngPidl)
If lngPidlFound = NOERROR Then
lngFolderFound = SHGetPathFromIDList(lngPidl, strPath)
If lngFolderFound Then
SpecFolder = Left$(strPath, _
InStr(1, strPath, vbNullChar) - 1) & Chr(92)
End If
End If
CoTaskMemFree lngPidl
lbl_Exit:
Exit Function
End Function

Private Function CleanFileName(strFilename As String, strExtension As String) As String
Dim vfName As Variant
Dim lng_Name As Long
If InStr(1, strFilename, Chr(92)) > 0 Then
vfName = Split(strFilename, Chr(92))
CleanFileName = vfName(UBound(vfName))
vfName = Split(CleanFileName, Chr(46))
Else
vfName = Split(strFilename, Chr(46))
End If
CleanFileName = vfName(0)
If UBound(vfName) > 1 Then
For lng_Name = 1 To UBound(vfName) - 1
CleanFileName = CleanFileName & Chr(46) & vfName(lng_Name)
Next lng_Name
End If
vfName = Split(CleanFileName, Chr(11))
CleanFileName = vfName(0)
vfName = Split(CleanFileName, Chr(13))
CleanFileName = vfName(0) & Chr(46) & strExtension
CleanFileName = Replace(CleanFileName, Chr(9), "")
CleanFileName = Replace(CleanFileName, Chr(34), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(42), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(47), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(58), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(60), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(62), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(63), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(92), Chr(95))
CleanFileName = Replace(CleanFileName, Chr(124), Chr(95))
lbl_Exit:
Exit Function
End Function

[tx7399]

12992
12993

Thanks Graham,

Your code obviously represents a lot of work. However, I can not get it to work for me and don't know what I am doing wrong.
I pasted all the code into Project(Template)This Workbook, but it would not save saying that it needed to be in a macro enabled document.
Sorry for my lack of understanding - but I really don't know how to implement all your hard work. Not even where to paste the code.:dunno
I have included two small attachments, the template and the excel list.
I still need your help but trying to learn.

[gmayor]

Macro code must be saved in a macro enabled document or template. You can either save it in your normal template (which would be a reasonable place to save it for testing, but wouldn't be accessible to other users) or you can save it in a template for use as an add-in. Note that if you put it in the merge document itself, then the first thing the macro does is close that document, so the code is ended with it.

A template to be used as an add-in is the best option here, but that causes some difficulties with distribution.

See http://www.gmayor.com/installing_macro.htm

Incidentally you should put the code in an ordinary module and not 'ThisDocument'.

[tx7399]

Graham,

I pasted your code into a 'new module' in my 'Normal' document and saved it.
When I open template.docx it appears that your code is available to template.docx.
When I complete the merge a new doc (Letters1) is created with the merge fields filled.
However, the first line is there but it is not highlighted and Letters1 is not automatically saved with the first line as its filename. Also, template.docx does not close.

Still struggling,

Paul

[gmayor]

There is nothing 'automatic' about it. You need to run the macro 'SaveDoc'. The macro does not highlight the first line. It samples the document for the first line with text and saves the document with the text from that line (with illegal filename characters removed). The linked web page from my site explains how to add a button or to associate the macro with a keyboard shortcut.

If the 'first line' is provided by a merge field, you might find it easier all round to use http://www.gmayor.com/individual_merge_letters.htm

[tx7399]

gmayor,

Sorry for the newbie comments and misunderstandings. You are an excellent teacher. I feel like I've learned a lot from this exchange. I am going to http://www.gmayor.com/individual_merge_letters.htm (http://www.gmayor.com/individual_merge_letters.htm) to utilize the solution presented there. Thank you very much !!!