[Last Call] Learn about multicloud storage options and how to improve your company's cloud strategy. Register Now

x
?
Solved

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

Posted on 2009-07-10
5
Medium Priority
?
172 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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 2000 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

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

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

This article describes how to use a set of graphical playing cards to create a Draw Poker game in Excel or VB6.
With so many activities to perform, Exchange administrators are always busy in organizations. If everything, including Exchange Servers, Outlook clients, and Office 365 accounts work without any issues, they can sit and relax. But unfortunately, it…
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
This is my first video review of Microsoft Bookings, I will be doing a part two with a bit more information, but wanted to get this out to you folks.

650 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