Solved

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

Posted on 2009-07-10
5
166 Views
Last Modified: 2012-05-07
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?
0
Comment
Question by:Amreska
  • 3
  • 2
5 Comments
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 24825907
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
 

Author Comment

by:Amreska
ID: 24825928
Hi Chris,

Where would I put these lines?

Thanks,

Amreska
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 24826161
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
 

Author Comment

by:Amreska
ID: 24830508
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
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 500 total points
ID: 24831752
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

Featured Post

Announcing the Most Valuable Experts of 2016

MVEs are more concerned with the satisfaction of those they help than with the considerable points they can earn. They are the types of people you feel privileged to call colleagues. Join us in honoring this amazing group of Experts.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Resolve DNS query failed errors for Exchange
Finding original email is quite difficult due to their duplicates. From this article, you will come to know why multiple duplicates of same emails appear and how to delete duplicate emails from Outlook securely and instantly while vital emails remai…
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

816 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now