mjburgard
asked on
Replace .xxx in a variable if it exists. VBA
I am using a macro that will convert a word doc to a pdf and then attach to Outlook to be mailed. Occasionally, depending on how the document was generated, the name of the pdf will be xxxxx.docx.pdf.
The name of the file is stored in a variable called myfile - I need to replace the .docx with nothing. so that the file is called xxxxx.pdf.
This should be simple, but I don't know VBA very well - yet. :)
I inherited this code, but it looks like it was downloaded from the net. Any help would be appreciated.
The name of the file is stored in a variable called myfile - I need to replace the .docx with nothing. so that the file is called xxxxx.pdf.
This should be simple, but I don't know VBA very well - yet. :)
I inherited this code, but it looks like it was downloaded from the net. Any help would be appreciated.
Attribute VB_Name = "savetopdfplus"
'Get content control function
Function getContent(ByRef wdDoc As Word.Document, ccName As String) As String
For i = 1 To wdDoc.ContentControls.Count
If wdDoc.ContentControls(i).Title = ccName Then
getContent = wdDoc.ContentControls(i).Range.Text
Exit Function
End If
Next
getContent = "n/a"
End Function
Sub Send_original_and_pdf()
'
' This macro creates a pdf-file of the current document and adds
' both the original and the pdf-version of the document as an
' attachment to a new Outlook message.
'
' This macro requires
' -Word 2007
' -The SaveAsPDFandXPS.exe addin to be installed
' -A reference added to the Microsoft Outlook <version> Object Library
'
' The SaveAsPDFandXPS.exe addin can be downloaded from;
' http://www.microsoft.com/downloads/details.aspx?FamilyId=4D951911-3E7E-4AE6-B059-A2E79ED87041
'
On Error Resume Next
' save the file
Dim salesman As String, descr As String, day As String
descr = getContent(Application.ActiveDocument, "description")
salesman = getContent(Application.ActiveDocument, "salesman")
day = Format$(Date, "YYYY-MM-DD")
ActiveDocument.SaveAs FileName:="\\DEV\quotes\" & salesman & "\" & day & "-" & descr
'Get the name of the open file and strip any extension.
Dim MyFile As String
MyFile = ActiveDocument.name
intPos = InStrRev(MyFile, ".")
If intPos > 0 Then
MyFile = Left(MyFile, intPos - 1)
End If
'Get the user's TempFolder to store the created pdf item in.
Dim FSO As Object, TmpFolder As Object
Set FSO = CreateObject("scripting.filesystemobject")
Set FileName = FSO.GetSpecialFolder(2)
'Create the full path name for the pdf-file
FileName = FileName & "\" & MyFile & ".pdf"
'Save the current document as pdf in the user's temp folder.
'Note that we are going to include the document properties as well.
'If you do not want this set "IncludeDocProps" to False.
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
FileName, ExportFormat:= _
wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=0, To:=0, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
'Declare an Outlook application an a mail item.
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
'Start Outlook if it isn't running.
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
End If
'Create a new message.
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
.To = getContent(ActiveDocument, "email")
.Subject = ActiveDocument.name
End With
'Add the attachments.
oItem.Attachments.Add FileName
'Show the message.
oItem.Display
'Cleanup
Set FSO = Nothing
Set FileName = Nothing
Set oOutlookApp = Nothing
Set oItem = Nothing
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER