How to have a macro security warning for each email sent?

I have a macro but I want to control when to use the macro by a popup message that says do you want to use this macro.  I have outlook 2007

Is this possible?.  Is there a visual basic programming for this?
AmreskaAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Chris BottomleySoftware Quality Lead EngineerCommented:
Hello Amreska,

A simple line like:
msgbox("Are you Sure?", vbYesNo)

and test for the result i.e.

Regards,
Chris
if msgbox("Are you Sure?", vbYesNo) = vbyes
    'vbYes option
else
    'otherwise
end if

Open in new window

0
AmreskaAuthor Commented:
Hi Chris,

Where would I put these lines?

Thanks,

Amreska
0
Chris BottomleySoftware Quality Lead EngineerCommented:
Sorry a clue is needed.

I have a macro but I want to control when to use the macro  >>>

SO what is the macro and how is it called as a strater.

Chris
0
AmreskaAuthor Commented:
HI Chris,

Below is the code:
Sub processMai(ByVal Item As Object, Cancel As Boolean)
Dim itm As Variant
Dim saveFolder As MAPIFolder
'Const saveTo As String = "C:\Name"
Const saveTo As String = "C:\Name"
Dim subject As String
Dim intcount As Integer
Dim strSaveTo As String
Dim ret() As String
Dim entry As Variant
Dim foundit As Boolean
Dim olkAttachment As Outlook.Attachment
Dim olkTemp As Outlook.MailItem
Dim strFilename As String
 
For Each olkAttachment In Item.Attachments
    strFilename = "C:\eeTesting\" & olkAttachment.FILENAME
    olkAttachment.SaveAsFile strFilename
    Set olkTemp = Application.CreateItemFromTemplate(strFilename)
    If testStr(olkTemp.subject) Then
        foundit = True
        extractStr olkTemp.subject, ret
    Else
        If testStr(olkTemp.Body) Then
            foundit = True
            extractStr olkTemp.Body, ret
        End If
    End If
    If foundit Then
        For Each itm In ret
            Set saveFolder = olNav2Folder("\\Network Folder\Sent Items2\" & itm, True)
            strSaveTo = md(saveTo & "\" & itm, False)
            If strSaveTo <> "" Then
                olkAttachment.SaveAsFile strSaveTo & "\" & olkTemp.Subject & " " & ".msg"
            End If
        Next
    End If
    Set olkTemp = Nothing
    Kill strFilename
Next
End Sub
 
Function md(dosPath As String, Optional createFolders As Boolean) As String
Dim fso As Object
Dim fldrs() As String
Dim rootdir As String
Dim fldrIndex As Integer
Dim bolret As Boolean
    
    md = ""
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(dosPath) Then
        fldrs = Split(dosPath, "\")
        rootdir = fldrs(0)
        If Not fso.FolderExists(rootdir) Then
            Exit Function
        End If
 
        bolret = True
        For fldrIndex = 1 To UBound(fldrs) - 1
            rootdir = rootdir & "\" & fldrs(fldrIndex)
            If Not fso.FolderExists(rootdir) Then
                If createFolders Then
                    fso.CreateFolder rootdir
                Else
                    bolret = False
                End If
            End If
        Next
        If bolret Then
            For Each fldr In fso.getfolder(rootdir).SubFolders
                If Left(fldr.Name, 2) = fldrs(UBound(fldrs)) Then
                    md = fldr.Path
                    Exit Function
                End If
            Next
        End If
        Exit Function
    End If
End Function
Function testStr(str As String) As String
Dim regEx As Object
    Set regEx = CreateObject("vbscript.regexp")
    With regEx
        .IgnoreCase = True
        .Pattern = ".*NC[0-9]{2}([0-9]{2})[0-9]{3}.*"
    End With
    testStr = regEx.test(str)
End Function
Function extractStr(str As String, ret() As String) As Boolean
Dim regEx As Object
Dim matches As Object
Dim cnt As Integer
    Set regEx = CreateObject("vbscript.regexp")
    With regEx
        .Global = True
        .IgnoreCase = True
        .Pattern = "NC[0-9]{2}[0-9]{2}[0-9]{3}"
    End With
    Set matches = regEx.Execute(str)
'MsgBox CStr(matches(0))
    If matches.Count = 0 Then
        extractStr = False
    Else
        extractStr = True
        For cnt = 0 To matches.Count - 1
            ReDim Preserve ret(0 To cnt)
            ret(cnt) = Mid(CStr(matches(cnt)), 5, 2)
        Next
    End If
End Function
 
 
 
Public Function olNav2Folder(foldername As String, Optional createFolders As Boolean) As Object
Dim olApp As Object
Dim olNs As Object
Dim olfldr As Object
Dim reqdFolder As Object
Dim arrFolders() As String
Dim nestCount As Integer
 
    On Error Resume Next
    foldername = Replace(Replace(foldername, "/", "\"), "\\", "")
    If Right(foldername, 1) = "\" Then foldername = Left(foldername, Len(foldername) - 1)
    arrFolders() = Split(foldername, "\")
    Set olApp = CreateObject("Outlook.Application")
    Set olNs = olApp.GetNamespace("MAPI")
    Set reqdFolder = olNs.Folders.Item(arrFolders(0))
    For nestCount = 1 To UBound(arrFolders)
        If Not reqdFolder Is Nothing Then
            Set olfldr = reqdFolder.Folders
            Set reqdFolder = olfldr.Item(arrFolders(nestCount))
            If reqdFolder <> olfldr.Item(arrFolders(nestCount)) Then
                If createFolders Then
                    reqdFolder.Folders.Add (arrFolders(nestCount))
                    Set olfldr = reqdFolder.Folders
                    Set reqdFolder = olfldr.Item(arrFolders(nestCount))
                Else
                    Set reqdFolder = Nothing
                    Exit For
                End If
            End If
        Else
        End If
    Next
    Set olNav2Folder = reqdFolder
    Set olApp = Nothing
    Set olNs = Nothing
    Set olfldr = Nothing
    Set reqdFolder = Nothing
End Function
 
 
 
Dim WithEvents olkSentItems As Outlook.Items
 
Private Sub Application_Quit()
    Set olkSentItems = Nothing
End Sub
 
Private Sub Application_Startup()
    Set olkSentItems = Session.GetDefaultFolder(olFolderSentMail).Items
End Sub
 
Private Sub olkSentItems_ItemAdd(ByVal Item As Object)
    processMai Item, False
End Sub

Open in new window

0
Chris BottomleySoftware Quality Lead EngineerCommented:
Probably just a change to the last sub as below, fiddle with the message as you like.

Chris
Private Sub olkSentItems_ItemAdd(ByVal Item As Object)
    if msgbox("Do you want to run the move process?", vbYesNo) = vbyes
        processMai Item, False
    end if
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Outlook

From novice to tech pro — start learning today.