• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 387
  • Last Modified:

Outlook 2007. Save attachment 2 times. Once to specific location, again to user-designated folder.

I want to open an email and run a macro (from ribbon is fine--I got that part).

I want to be prompted for a 4-digit number. The number gets punched in (example: 6677)

I want the macro to save the *.LIC file to:
\\MyBigFolder\MyLittleFolder\6677

(where 6677 is the 4-digit number entered by user, and it looks like we'll need 5 digits before you know it)

And to ALSO save it, without user intervention, to the folder named:

\\192.168.100.9\pas\Hospital Licenses

That would be incredible. :)

I could probably figure out the 2nd save using the first-save code.
0
Anne Troy
Asked:
Anne Troy
  • 5
  • 4
1 Solution
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Not sure about the syntax for the last part but hopefully this helps!

Sub savetwo(mai As Object)
Dim strIdent As String
Dim bolRetry As Boolean
Dim strQualifier As String
Dim fso As Object
Dim strFileSpec As String

    If TypeName(mai) <> "MailItem" Then
        MsgBox "Aborting Loop as incorrect object type supplied"
        Exit Sub
    End If
    If mai.Attachments.Count = 0 Then
        MsgBox "Aborting Loop as no attachments found for the supplied object"
        Exit Sub
    End If
    bolRetry = True
    Do While bolRetry
        strIdent = InputBox(strQualifier & "Enter the Series Identifier :>", "User Prompt")
        If strIdent = "" Then
            MsgBox "Aborting Loop with a null input"
            Exit Sub
        ElseIf Len(strIdent) < 4 Or Len(strIdent) > 4 Then
            strQualifier = "Input length incorrect" & vbCrLf & vbCrLf
        ElseIf Not IsNumeric(strIdent) Then
            strQualifier = "Input must be numeric" & vbCrLf & vbCrLf
        Else
            bolRetry = False
        End If
    Loop
    strFileSpec = "\\MyBigFolder\MyLittleFolder\" & strIdent & "\"
    md strFileSpec, True
    strFileSpec = strFileSpec & mai.Attachments(1).filename
    
    mai.Attachments(1).SaveAsFile strFileSpec
    
Set fso = Nothing
End Sub

Function md(dosPath As String, Optional createFolders As Boolean)
' Modified to account for UNC paths
Dim fso As Object
Dim fldrs() As String
Dim rootdir As String
Dim fldrIndex As Integer
Dim arr() As String
Dim elem As Integer
Dim strFilePath As String
    
    md = True
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(dosPath) Then
        If Left(dosPath, 2) = "\\" Then
            dosPath = Right(dosPath, Len(dosPath) - 2)
            fldrs = Split(dosPath, "\")
            fldrs(0) = "\\" & fldrs(0)
        Else
            fldrs = Split(dosPath, "\")
        End If
        If UBound(fldrs) = 1 Then
            md = False
            Exit Function
        Else
            strFilePath = fldrs(0)
            For elem = 1 To UBound(fldrs)
                strFilePath = strFilePath & "\" & fldrs(elem)
                If Not fso.FolderExists(strFilePath) Then
                    If createFolders Then
                        fso.CreateFolder strFilePath
                    Else
                        md = False
                        Exit Function
                    End If
                End If
            Next
        End If
    End If
End Function

Open in new window


Chris
0
 
Anne TroyEast Coast ManagerAuthor Commented:
Can't wait to try it, Chris! Leaving for work now.
0
 
Anne TroyEast Coast ManagerAuthor Commented:
Apparently, Outlook macros that contain something in the parentheses aren't available to run? (I have looked and looked to find why, and can't.)

Sub savetwo(mai As Object)

Must become

Sub savetwo()

So, of course, I try to run it like that and get the abort loop error.
0
Cloud Class® Course: CompTIA Healthcare IT Tech

This course will help prep you to earn the CompTIA Healthcare IT Technician certification showing that you have the knowledge and skills needed to succeed in installing, managing, and troubleshooting IT systems in medical and clinical settings.

 
Chris BottomleySoftware Quality Lead EngineerCommented:
Apologies I didn't define the calling mechanism ... I made it a parameter to allow the sub to be used from both code and a rule.  Therefore re-instate the parameter then call for example as:

savetwo application.activeexplorer.selection(1)

assuming an item is selected in the explorer window.

Chris
0
 
Anne TroyEast Coast ManagerAuthor Commented:
"an item is selected"

You mean a message? I'm not in Explorer, I am in Outlook saving an attachment.
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
The outlook activeexplorer is a reference to the folder in outlooks folder pane where the current item is selected

Replacing:

savetwo application.activeexplorer.selection(1)
with
savetwo application.activeinspector.currentitem

To work with the last opened outlook item

Chris
0
 
Anne TroyEast Coast ManagerAuthor Commented:
Okay, it's prompting for the number now. Phew!

I don't need it to create the folder if it doesn't exist. If it doesn't exist, it's a bad folder number. Could I have it throw an error "Folder doesn't exist" with an OK button? I have no idea what all parts of the code to remove.

Thanks so much!!
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
On a different machine, (code could be simplified in respect of the function but will work fine with the following ... I think) :

Sub savetwo(mai As Object)
Dim strIdent As String
Dim bolRetry As Boolean
Dim strQualifier As String
Dim fso As Object
Dim strFileSpec As String

    If TypeName(mai) <> "MailItem" Then
    End If
    If mai.Attachments.Count = 0 Then
        MsgBox "Aborting Loop as no attachments found for the supplied object"
        Exit Sub
    End If
    bolRetry = True
    Do While bolRetry
        strIdent = InputBox(strQualifier & "Enter the Series Identifier :>", "User Prompt")
        If strIdent = "" Then
            MsgBox "Aborting Loop with a null input"
            Exit Sub
        ElseIf Len(strIdent) < 4 Or Len(strIdent) > 4 Then
            strQualifier = "Input length incorrect" & vbCrLf & vbCrLf
        ElseIf Not IsNumeric(strIdent) Then
            strQualifier = "Input must be numeric" & vbCrLf & vbCrLf
        Else
            bolRetry = False
        End If
    Loop
    strFileSpec = "\\MyBigFolder\MyLittleFolder\" & strIdent & "\"
    if md( strFileSpec, False) = false then
        MsgBox "Aborting Loop ... Folder i.e. Series Identifier NOT found"
        Exit Sub
    end if
    strFileSpec = strFileSpec & mai.Attachments(1).filename
    
    mai.Attachments(1).SaveAsFile strFileSpec
    
Set fso = Nothing
End Sub

Function md(dosPath As String, Optional createFolders As Boolean)
' Modified to account for UNC paths
Dim fso As Object
Dim fldrs() As String
Dim rootdir As String
Dim fldrIndex As Integer
Dim arr() As String
Dim elem As Integer
Dim strFilePath As String
    
    md = True
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(dosPath) Then
        If Left(dosPath, 2) = "\\" Then
            dosPath = Right(dosPath, Len(dosPath) - 2)
            fldrs = Split(dosPath, "\")
            fldrs(0) = "\\" & fldrs(0)
        Else
            fldrs = Split(dosPath, "\")
        End If
        If UBound(fldrs) = 1 Then
            md = False
            Exit Function
        Else
            strFilePath = fldrs(0)
            For elem = 1 To UBound(fldrs)
                strFilePath = strFilePath & "\" & fldrs(elem)
                If Not fso.FolderExists(strFilePath) Then
                    If createFolders Then
                        fso.CreateFolder strFilePath
                    Else
                        md = False
                        Exit Function
                    End If
                End If
            Next
        End If
    End If
End Function

Open in new window


Chris
0
 
Anne TroyEast Coast ManagerAuthor Commented:
I'm sure this will work, I simply haven't had a chance to try it out. Thanks, Chris, for all your help!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Free Tool: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 5
  • 4
Tackle projects and never again get stuck behind a technical roadblock.
Join Now