Amreska
asked on
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?
Is this possible?. Is there a visual basic programming for this?
ASKER
Hi Chris,
Where would I put these lines?
Thanks,
Amreska
Where would I put these lines?
Thanks,
Amreska
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
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
ASKER
HI Chris,
Below is the code:
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
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
A simple line like:
msgbox("Are you Sure?", vbYesNo)
and test for the result i.e.
Regards,
Chris
Open in new window