Consulting

Results 1 to 11 of 11

Thread: Complex outlook email export macro

  1. #1

    Complex outlook email export macro

    Hey Guys,


    can you hepl me with macro below ?


    I found macro somwhere on the internet, it is possible to upgrade it with foloowing function ?

    • open "Save as window" like when you Save As Excel file
    • The macro create sub-folder in the picked location from previous step. Folder name: yyyymmdd hh.mm senders name - mail subject
    • Open this subfolder and save Outlook msg file (already do this macro below)
    • Save email to PDF file
    • Save all email attachements




    It is possible to upgrade this awesome macro ?


    Option Explicit
    
    
    Sub SaveMessage()
    'An Outlook macro by Graham Mayor - www.gmayor.com
    'Saves the currently selected message
    Dim olMsg As MailItem
        On Error Resume Next
        Set olMsg = ActiveExplorer.Selection.Item(1)
        SaveItem olMsg
    lbl_Exit:
        Set olMsg = Nothing
        Exit Sub
    End Sub
    
    
    Sub SaveAllMessagesInFolder()
    'An Outlook macro by Graham Mayor - www.gmayor.com
    'Saves all the messages in a selected Outlook folder
    Dim olItems As Outlook.Items
    Dim olItem As Outlook.MailItem
        Set olItems = Session.PickFolder.Items
        For Each olItem In olItems
            SaveItem olItem
        Next olItem
        Set olItem = Nothing
        Set olItems = Nothing
    lbl_Exit:
        Exit Sub
    End Sub
    
    
    
    
    Private Sub SaveItem(olItem As MailItem)
    'An Outlook macro by Graham Mayor - www.gmayor.com
    'The main macro called by the above macros.
    'This macro can be used as a script to save the messages as they arrive
    'provided you change fPath = to a fixed path, so you are not prompted each time a message arrives
    Dim fName As String
    Dim fPath As String
        fPath = InputBox("Enter the path to save the message." & vbCr & _
                         "The path will be created if it doesn't exist.", _
                         "Save Message", "C:\!Outlook saved mails\")
        CreateFolders fPath
    
    
        If olItem.Sender Like "*** Email address is removed for privacy ***" Then    'Your domain
            fName = Format(olItem.SentOn, "yyyymmdd") & Chr(32) & _
                    Format(olItem.SentOn, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        Else
            fName = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) & _
                    Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.SenderName & " - " & olItem.Subject
        End If
        fName = Replace(fName, Chr(58) & Chr(41), "")
        fName = Replace(fName, Chr(58) & Chr(40), "")
        fName = Replace(fName, Chr(34), "-")
        fName = Replace(fName, Chr(42), "-")
        fName = Replace(fName, Chr(47), "-")
        fName = Replace(fName, Chr(58), "-")
        fName = Replace(fName, Chr(60), "-")
        fName = Replace(fName, Chr(62), "-")
        fName = Replace(fName, Chr(63), "-")
        fName = Replace(fName, Chr(124), "-")
        SaveUnique olItem, fPath, fName
    lbl_Exit:
        Exit Sub
    End Sub
    
    
    Private Function CreateFolders(strPath As String)
    'An Office macro by Graham Mayor - www.gmayor.com
    'Creates the full path 'strPath' if missing or incomplete
    Dim strTempPath As String
    Dim lngPath As Long
    Dim vPath As Variant
    Dim oFSO As Object
        Set oFSO = CreateObject("Scripting.FileSystemObject")
        vPath = Split(strPath, "\")
        strPath = vPath(0) & "\"
        For lngPath = 1 To UBound(vPath)
            strPath = strPath & vPath(lngPath) & "\"
            If Not oFSO.FolderExists(strPath) Then MkDir strPath
        Next lngPath
    lbl_Exit:
        Set oFSO = Nothing
        Exit Function
    End Function
    
    
    Private Function SaveUnique(oItem As Object, _
                                strPath As String, _
                                strFileName As String)
    'An Outlook macro by Graham Mayor - www.gmayor.com
    'Ensures that filenames are not overwritten
    Dim lngF As Long
    Dim lngName As Long
    Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        lngF = 1
        lngName = Len(strFileName)
        Do While fso.FileExists(strPath & strFileName & ".msg") = True
            strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
            lngF = lngF + 1
        Loop
        oItem.SaveAs strPath & strFileName & ".msg"
    lbl_Exit:
        Exit Function
    End Function

  2. #2
    The short answer is no. It requires a different technique to save a message as PDF and frankly there is not a lot of point selecting the folder for each save (and the dialog in question is not in any case available from Outlook). It is better to fix the root folder in code and then you can create sub folders to provide the pattern you specified on the fly. The following will save the messages as PDF in a sub folder of that named folder as requested and also save any attachments in that same folder:

    Option Explicit
    
    Private wdApp As Object
    Private wdDoc As Object
    Private bStarted As Boolean
    Private strSavePath As String
    Private strName As String
    Const strPath As String = "D:\Path\Email Messages\" 'The root folder
    
    
    Sub SaveSelectedMessagesAsPDF()
    'Graham Mayor - https://www.gmayor.com - Last updated - 13 Jul 2019
    'Select the messages to process and run this macro
    Dim olMsg As Object
    Dim strFname As String, strExt As String
    Dim j As Long
        'Create the folder to store the messages if not present
        If CreateFolders(strPath) = False Then GoTo lbl_Exit
        'Open or Create a Word object
        On Error Resume Next
        Set wdApp = GetObject(, "Word.Application")
        If Err Then
            Set wdApp = CreateObject("Word.Application")
            bStarted = True
        End If
        On Error GoTo 0
        For Each olMsg In Application.ActiveExplorer.Selection
            SaveAsPDFfile olMsg
        Next olMsg
        MsgBox "Completed"
    lbl_Exit:
        If bStarted Then wdApp.Quit
        Set olMsg = Nothing
        Set wdApp = Nothing
        Exit Sub
    End Sub
    
    
    Private Sub SaveAsPDFfile(olItem As MailItem)
    'Graham Mayor - https://www.gmayor.com - Last updated - 13 Jul 2019
    Dim olNS As NameSpace
    Dim fso As Object, TmpFolder As Object
    Dim tmpPath As String
    Dim strFileName As String
    Dim oRegex As Object
    
    
        Set olNS = Application.GetNamespace("MAPI")
    
    
        'Get the user's TempFolder to store the temporary file
        Set fso = CreateObject("Scripting.FileSystemObject")
        tmpPath = fso.GetSpecialFolder(2)
    
    
        'construct the filename for the temp mht-file
        strName = "email_temp.mht"
        tmpPath = tmpPath & "\" & strName
    
    
        'Save temporary file
        olItem.SaveAs tmpPath, 10
    
    
        'Open the temporary file in Word
        Set wdDoc = wdApp.Documents.Open(fileName:=tmpPath, _
                                         AddToRecentFiles:=False, _
                                         Visible:=False, _
                                         Format:=7)
    
    
        'Create a file name from the message subject
        strFileName = Format(olItem.ReceivedTime, "yyyymmdd hh.mm") & "-" & olItem.SenderName & "-" & olItem.Subject
        'Remove illegal filename characters
        Set oRegex = CreateObject("vbscript.regexp")
        oRegex.Global = True
        oRegex.Pattern = "[\/:*?""<>|]"
        strFileName = Trim(oRegex.Replace(strFileName, ""))
        strSavePath = strPath & strFileName
        CreateFolders strSavePath
        strFileName = strFileName & ".pdf"
        strFileName = FileNameUnique(strSavePath, strFileName, "pdf")
        strFileName = strSavePath & strFileName
    
    
        'Save the attachments
        SaveAttachments olItem, strSavePath
    
    
        'Save As pdf
        wdDoc.ExportAsFixedFormat OutputFilename:= _
                                  strFileName, _
                                  ExportFormat:=17, _
                                  OpenAfterExport:=False, _
                                  OptimizeFor:=0, _
                                  Range:=0, _
                                  From:=0, _
                                  To:=0, _
                                  Item:=0, _
                                  IncludeDocProps:=True, _
                                  KeepIRM:=True, _
                                  CreateBookmarks:=0, _
                                  DocStructureTags:=True, _
                                  BitmapMissingFonts:=True, _
                                  UseISO19005_1:=False
    
    
        ' close the document
        wdDoc.Close 0
    lbl_Exit:
        'Cleanup
        Set olNS = Nothing
        Set olItem = Nothing
        Set wdDoc = Nothing
        Set oRegex = Nothing
        Exit Sub
    End Sub
    
    
    Private Sub SaveAttachments(olItem As MailItem, strSaveFldr As String)
    'Graham Mayor - http://www.gmayor.com - Last updated - 26 May 2017
    Dim olAttach As Attachment
    Dim strFname As String
    Dim strExt As String
    Dim j As Long
    
    
        On Error Resume Next
        If olItem.Attachments.Count > 0 Then
            For j = 1 To olItem.Attachments.Count
                Set olAttach = olItem.Attachments(j)
                strFname = olAttach.fileName
                strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                strFname = FileNameUnique(strSaveFldr, strFname, strExt)
                olAttach.SaveAsFile strSaveFldr & strFname
            Next j
        End If
    lbl_Exit:
        Set olAttach = Nothing
        Set olItem = Nothing
        Exit Sub
    End Sub
    
    
    
    
    Private Function CreateFolders(strPath As String) As Boolean
    'Graham Mayor - https://www.gmayor.com - Last updated - 13 Jul 2019
    Dim strTempPath As String
    Dim lngPath As Long
    Dim VPath As Variant
        VPath = Split(strPath, "\")
        strPath = VPath(0) & "\"
        For lngPath = 1 To UBound(VPath)
            strPath = strPath & VPath(lngPath) & "\"
            On Error GoTo Err_Handler
            If Not FolderExists(strPath) Then MkDir strPath
        Next lngPath
        CreateFolders = True
    lbl_Exit:
        Exit Function
    Err_Handler:
        MsgBox "The path " & strPath & " is invalid!"
        CreateFolders = False
        Resume lbl_Exit
    End Function
    
    
    Private Function FileNameUnique(strPath As String, _
                                    strFileName As String, _
                                    strExtension As String) As String
    'Graham Mayor - https://www.gmayor.com - Last updated - 13 Jul 2019
    Dim lngF As Long
    Dim lngName As Long
        lngF = 1
        lngName = Len(strFileName) - (Len(strExtension) + 1)
        strFileName = Left(strFileName, lngName)
        Do While FileExists(strPath & strFileName & Chr(46) & strExtension) = True
            strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
            lngF = lngF + 1
        Loop
        FileNameUnique = strFileName & Chr(46) & strExtension
    lbl_Exit:
        Exit Function
    End Function
    
    
    Private Function FolderExists(fldr) As Boolean
    'Graham Mayor - https://www.gmayor.com - Last updated - 13 Jul 2019
    Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        If (fso.FolderExists(fldr)) Then
            FolderExists = True
        Else
            FolderExists = False
        End If
    lbl_Exit:
        Set fso = Nothing
        Exit Function
    End Function
    
    
    Private Function FileExists(filespec) As Boolean
    'Graham Mayor - https://www.gmayor.com - Last updated - 13 Jul 2019
    Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        If fso.FileExists(filespec) Then
            FileExists = True
        Else
            FileExists = False
        End If
    lbl_Exit:
        Set fso = Nothing
        Exit Function
    End Function
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    Quote Originally Posted by gmayor View Post
    The short answer is no. It requires a different technique to save a message as PDF and frankly there is not a lot of point selecting the folder for each save (and the dialog in question is not in any case available from Outlook). It is better to fix the root folder in code and then you can create sub folders to provide the pattern you specified on the fly. The following will save the messages as PDF in a sub folder of that named folder as requested and also save any attachments in that same folder:

    Option Explicit
    
    Private wdApp As Object
    Private wdDoc As Object
    Private bStarted As Boolean
    Private strSavePath As String
    Private strName As String
    Const strPath As String = "D:\Path\Email Messages\" 'The root folder
    
    
    Sub SaveSelectedMessagesAsPDF()
    'Graha
    lbl_Exit:
        Set fso = Nothing
        Exit Function
    End Function

    Wow man, its amazing :-)

    How to add macro for saveMeaasge as msg file in the same subfolder?

    Thank youuuuuuuuuuu

  4. #4
    You already have the SaveUnique function from the previous macro. Add that function to the module and insert the line as indicated in the SaveAsPDFFile sub after the CreateFolders strSavePath line

    CreateFolders strSavePath    'add this line to save the message as msg format
        SaveUnique olItem, strSavePath, strFileName
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    Quote Originally Posted by gmayor View Post
    You already haP
    I added a code show below but this error showed and no exported mails:

    screenshot.png

    Private Sub SaveAsPDFfile(olItem As MailItem)
    'Graham Mayor - https://www.gmayor.com - Last updated - 13 Jul 2019
    Dim olNS As NameSpace
    Dim fso As Object, TmpFolder As Object
    Dim tmpPath As String
    Dim strFileName As String
    Dim oRegex As Object
    
        Set olNS = Application.GetNamespace("MAPI")
    
        'Get the user's TempFolder to store the temporary file
        Set fso = CreateObject("Scripting.FileSystemObject")
        tmpPath = fso.GetSpecialFolder(2)
    
        'construct the filename for the temp mht-file
        strName = "email_temp1.mht"
        tmpPath = tmpPath & "\" & strName
    
        'Save temporary file
        olItem.SaveAs tmpPath, 10
    
    
    
    
        'Open the temporary file in Word
        Set wdDoc = wdApp.Documents.Open(FileName:=tmpPath, _
                                         AddToRecentFiles:=False, _
                                         Visible:=False, _
                                         Format:=7)
    
        'Create a file name from the message subject
        strFileName = Format(olItem.ReceivedTime, "yyyymmdd hh.mm") & "-" & olItem.SenderName & "-" & olItem.Subject
        'Remove illegal filename characters
        Set oRegex = CreateObject("vbscript.regexp")
        oRegex.Global = True
        oRegex.Pattern = "[\/:*?""<>|]"
        strFileName = Trim(oRegex.Replace(strFileName, ""))
        strSavePath = strPath & strFileName
        CreateFolders strSavePath
        strFileName = strFileName & ".pdf"
        strFileName = FileNameUnique(strSavePath, strFileName, "pdf")
        strFileName = strSavePath & strFileName
    
        'Save message as msg
        CreateFolders strSavePath    'add this line to save the message as msg format
        SaveUnique olItem, strSavePath, strFileName
    
        'Save As pdf
        wdDoc.ExportAsFixedFormat OutputFilename:= _
                                  strFileName, _
                                  ExportFormat:=17, _
                                  OpenAfterExport:=False, _
                                  OptimizeFor:=0, _
                                  Range:=0, _
                                  From:=0, _
                                  To:=0, _
                                  Item:=0, _
                                  IncludeDocProps:=True, _
                                  KeepIRM:=True, _
                                  CreateBookmarks:=0, _
                                  DocStructureTags:=True, _
                                  BitmapMissingFonts:=True, _
                                  UseISO19005_1:=False
    
        ' close the document
        wdDoc.Close 0
    lbl_Exit:
        'Cleanup
        Set olNS = Nothing
        Set olItem = Nothing
        Set wdDoc = Nothing
        Set oRegex = Nothing
        Exit Sub
    End Sub
    
    
    ....
    and this

    Private Function SaveUnique(oItem As Object, _
                                strPath As String, _
                                strFileName As String)
    'An Outlook macro by Graham Mayor - www.gmayor.com
    'Ensures that filenames are not overwritten
    Dim lngF As Long
    Dim lngName As Long
    Dim fso As Object
        Set fso = CreateObject("Scripting.FileSystemObject")
        lngF = 1
        lngName = Len(strFileName)
        Do While fso.FileExists(strSavePath & strFileName & ".msg") = True
            strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
            lngF = lngF + 1
        Loop
        oItem.SaveAs strSavePath & strFileName & ".msg"
    lbl_Exit:
        Exit Function
    End Function

  6. #6
    You should have added the line where I indicated, not added both lines, as that simply screws things up. The CreateFolders line was already present.
    It seems you have now crashed Word and it is running as a background task with the temporary file open. You might be able to open Word and close the file or you can force Word closed using Task Manager (or reboot).

    Private Sub SaveAsPDFfile(olItem As MailItem)'Graham Mayor - https://www.gmayor.com - Last updated - 15 Jul 2019
    Dim olNS As NameSpace
    Dim fso As Object, TmpFolder As Object
    Dim tmpPath As String
    Dim strFileName As String
    Dim oRegex As Object
    
    
        Set olNS = Application.GetNamespace("MAPI")
    
    
        'Get the user's TempFolder to store the temporary file
        Set fso = CreateObject("Scripting.FileSystemObject")
        tmpPath = fso.GetSpecialFolder(2)
    
    
        'construct the filename for the temp mht-file
        strName = "email_temp1.mht"
        tmpPath = tmpPath & "\" & strName
    
    
        'Save temporary file
        olItem.SaveAs tmpPath, 10
    
    
        'Open the temporary file in Word
        Set wdDoc = wdApp.Documents.Open(fileName:=tmpPath, _
                                         AddToRecentFiles:=False, _
                                         Visible:=False, _
                                         Format:=7)
    
    
        'Create a file name from the message subject
        strFileName = Format(olItem.ReceivedTime, "yyyymmdd hh.mm") & "-" & olItem.SenderName & "-" & olItem.Subject
        'Remove illegal filename characters
        Set oRegex = CreateObject("vbscript.regexp")
        oRegex.Global = True
        oRegex.Pattern = "[\/:*?""<>|]"
        strFileName = Trim(oRegex.Replace(strFileName, ""))
        strSavePath = strPath & strFileName
        CreateFolders strSavePath
        'add this line to save the message as msg format
        SaveUnique olItem, strSavePath, strFileName
    
    
        strFileName = strFileName & ".pdf"
        strFileName = FileNameUnique(strSavePath, strFileName, "pdf")
        strFileName = strSavePath & strFileName
    
    
        'Save As pdf
        wdDoc.ExportAsFixedFormat OutputFilename:= _
                                  strFileName, _
                                  ExportFormat:=17, _
                                  OpenAfterExport:=False, _
                                  OptimizeFor:=0, _
                                  Range:=0, _
                                  From:=0, _
                                  To:=0, _
                                  Item:=0, _
                                  IncludeDocProps:=True, _
                                  KeepIRM:=True, _
                                  CreateBookmarks:=0, _
                                  DocStructureTags:=True, _
                                  BitmapMissingFonts:=True, _
                                  UseISO19005_1:=False
    
    
        ' close the document
        wdDoc.Close 0
    lbl_Exit:
        'Cleanup
        Set olNS = Nothing
        Set olItem = Nothing
        Set wdDoc = Nothing
        Set oRegex = Nothing
        Exit Sub
    End Sub
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  7. #7
    Quote Originally Posted by gmayor View Post
    You should have ad..
    Thank you, but this feature generate a lots of trouble.

    Could you please update macro with no extraction to pdf ? do the same thing but only - extract attachements and save email as msg file ? with selection to save like "save As" ?

    I relly appriciate your work :-)
    Last edited by marlowwe; 07-17-2019 at 04:06 AM.

  8. #8
    Quote Originally Posted by gmayor View Post
    You should have added the Set oRegex = Nothing
    Exit Sub
    End Sub
    [/CODE]
    Could you please help me to downgrade the macro above and exclude the save as pdf file ? (the big problem with Word app running in background)

    Thank you.

    Vojtech

  9. #9
    i Tried this but with error:
    Option Explicit
    
    Sub SaveMSGandATTACHEMENTS()
    Dim olMsg As MailItem
        On Error Resume Next
        Set olMsg = ActiveExplorer.Selection.Item(1)
        
        ' ============================== save function start =========================
        Dim xShell As Object
        Dim xFolder As Object
        Dim strStartingFolder As String
        Dim xFolderItem As Object
        Dim xFileName As String
        Dim objOL As Outlook.Application
        
        Set xShell = CreateObject("Shell.Application")
    
    
        On Error Resume Next
        ' Bypass error when xFolder is nothing on Cancel
        Set xFolder = xShell.BrowseForFolder(0, "Select a folder:", 0, strStartingFolder)
        ' Remove error bypass as soon as the purpose is served
        On Error GoTo 0
        
        If Not TypeName(xFolder) = "Nothing" Then
            Set xFolderItem = xFolder.self
            xFileName = xFolderItem.Path
            ' missing path separator
            If Right(xFileName, 1) <> "\" Then xFileName = xFileName & "\"
        Else
            xFileName = ""
            Exit Sub
        End If
         ' ============================== save function end =========================
        
        SaveAttachments olMsg
        SaveMessageAsMsg olMsg
    lbl_Exit:
        Exit Sub
    End Sub
    
    
    
    
    Public Sub SaveAttachments(olItem As MailItem)
    'Graham Mayor - 
    Dim olAttach As Attachment
    Dim strFname As String
    Dim strExt As String
    Dim j As Long, lng_Index As Long
    Dim arrInvalid() As String
    Dim xFileName As String
    
    
        arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
        On Error Resume Next
        If olItem.Attachments.Count > 0 Then
            For j = 1 To olItem.Attachments.Count
                Set olAttach = olItem.Attachments(j)
                'If Not olAttach.fileName Like "image*.*" Then
                strFname = olItem.Subject & "_" & olAttach.FileName
                For lng_Index = 0 To UBound(arrInvalid)
                    strFname = Replace(strFname, Chr(arrInvalid(lng_Index)), Chr(95))
                Next lng_Index
                strExt = Right(strFname, Len(strFname) - InStrRev(strFname, Chr(46)))
                strFname = FileNameUnique(xFileName, strFname, strExt)
                olAttach.SaveAsFile xFileName & strFname
                'End If
            Next j
            olItem.Save
        End If
    lbl_Exit:
        Set olAttach = Nothing
        Set olItem = Nothing
        Exit Sub
    End Sub
    Public Sub SaveMessageAsMsg(olItem As MailItem)
    'Update by Extendoffice 2018/3/5
    Dim xMail As Outlook.MailItem
    Dim xObjItem As Object
    Dim xPath As String
    Dim xDtDate As Date
    Dim xName, xFileName As String
    Dim xSender As String
    Dim xFileName As String
    
    
                
    On Error Resume Next
    For Each xObjItem In Outlook.ActiveExplorer.Selection
        If xObjItem.Class = olMail Then
            Set xMail = xObjItem
            xName = Left(CleanFileName(xMail.Subject), 40)
            xSender = CleanFileName(xMail.senderName)
            xDtDate = xMail.ReceivedTime
            xName = Format(xDtDate, "yyyymmdd", vbUseSystemDayOfWeek, _
                  vbUseSystem) & Format(xDtDate, "-hhnn", _
                  vbUseSystemDayOfWeek, vbUseSystem) & "-" & xSender & "-" & xName & ".msg"
            xPath = xFileName + xName
            xMail.SaveAs xPath, olMsg
        End If
    Next
    End Sub
    
    
    Private Function FileNameUnique(strPath As String, _
                                    strFileName As String, _
                                    strExtension As String) As String
    'Graham Mayor - https://www.gmayor.com - Last updated - 22 Jul 2019
    Dim lngF As Long
    Dim lngName As Long
    Dim fso As Object
        lngF = 1
        Set fso = CreateObject("Scripting.FileSystemObject")
        lngName = Len(strFileName) - (Len(strExtension) + 1)
        strFileName = Left(strFileName, lngName)
        Do While fso.FileExists(strPath & strFileName & Chr(46) & strExtension) = True
            strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
            lngF = lngF + 1
        Loop
        FileNameUnique = strFileName & Chr(46) & strExtension
    lbl_Exit:
        Set fso = Nothing
        Exit Function
    End Function
    
    
    Public Function CleanFileName(strFileName As String) As String
    
    
        
        Dim Invalids
        Dim e
        Dim strTemp As String
        
        Invalids = Array("?", "*", ":", "|", "<", ">", "[", "]", """", "/")
        
        strTemp = strFileName
        
        For Each e In Invalids
            strTemp = Replace(strTemp, e, " ")
            'strTemp = Replace(strTemp, e, "")
        Next
        
        CleanFileName = strTemp
        
    End Function
    Private Function CreateFolders(strPath As String) As Boolean
    'Graham Mayor
    Dim strTempPath As String
    Dim lngPath As Long
    Dim VPath As Variant
        VPath = Split(strPath, "\")
        strPath = VPath(0) & "\"
        For lngPath = 1 To UBound(VPath)
            strPath = strPath & VPath(lngPath) & "\"
            On Error GoTo Err_Handler
            If Not FolderExists(strPath) Then MkDir strPath
        Next lngPath
        CreateFolders = True
    lbl_Exit:
        Exit Function
    Err_Handler:
        MsgBox "The path " & strPath & " is invalid!"
        CreateFolders = False
        Resume lbl_Exit
    End Function

  10. #10
    If you don't want the PDF comment out the line wdDoc.ExportAsFixedFormat in my original code.
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  11. #11
    Thank you

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •