Solved

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

Posted on 2009-07-10
5
164 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

Windows Server 2016: All you need to know

Learn about Hyper-V features that increase functionality and usability of Microsoft Windows Server 2016. Also, throughout this eBook, you’ll find some basic PowerShell examples that will help you leverage the scripts in your environments!

Join & Write a Comment

Granting full access permission allows users to access mailboxes present in their database. By giving full access permission one can open and read the content of any mailbox but cannot send emails from that mailbox.
Set OWA language and time zone in Exchange for individuals, all users or per database.
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …
This video shows how to remove a single email address from the Outlook 2010 Auto Suggestion memory. NOTE: For Outlook 2016 and 2013 perform the exact same steps. Open a new email: Click the New email button in Outlook. Start typing the address: …

746 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

15 Experts available now in Live!

Get 1:1 Help Now