• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA Code to Detect Non Password Protected Attachment

Status
Not open for further replies.
debxxx1

debxxx1

New Member
Hi Genius People,

I have designed a VBA code which handles all my outlook outgoing emails.

Currently I am trying to enhance it like: When I will send a Zip/Excel attachment through outlook, my code can able to check and warn whether the attachment is password protected or not.

Please Help.
 
Check this.

In ThisOutlookSession...

Code: 
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim strCheck As String

Cancel = True

On Error GoTo xEnd
strCheck = CheckAttachmentPassword(Item)

If Len(strCheck) > 0 Then
    If strCheck <> "ERROR" Then
        MsgBox "Following attachments are unprotected." & vbCr & strCheck, vbCritical, "Result"
        Exit Sub
    End If
Else
    Cancel = False
End If

Exit Sub

xEnd:
Err.Clear
Cancel = True
End Sub


In a module...


Code: 
Option Explicit

Function CheckAttachmentPassword(ByVal oMail As Object) As String
Dim atmnt As Attachment, oFolder As String, strpath As String, vProtect As String
Dim appXL As Object, oFile As Object, strExt As String, oApp As Object

CheckAttachmentPassword = ""
vProtect = ""
On Error GoTo xError

If oMail.Attachments.Count > 0 Then
oFolder = "c:\temp"
Set appXL = CreateObject("Excel.Application")
Set oApp = CreateObject("Shell.Application")

If Len(Dir(oFolder, vbDirectory)) = 0 Then
    MkDir oFolder
Else
On Error Resume Next
    Kill oFolder & "\*.*"
On Error GoTo 0
End If

    For Each atmnt In oMail.Attachments
        With atmnt
            Randomize
            strpath = .DisplayName
            strExt = Mid(strpath, InStrRev(strpath, ".") + 1)
            strpath = oFolder & "\" & Left(Split(Str(Rnd), ".")(1), 5) & OnlyAlphaNumeric(Replace(strpath, "." & strExt, "")) & "." & strExt
            .SaveAsFile strpath
                Select Case strExt
                    Case "xls", "xlsx", "xlsb", "xlsm" 'add
                        Set oFile = appXL.workbooks.Open(strpath)
                            If oFile.ProtectWindows Or oFile.ProtectStructure Then
                          
                            Else
                                vProtect = vProtect & vbCr & .DisplayName
                            End If
                        oFile.Close 0
                    Case "zip", "rar"
                        On Error GoTo nxt
                            oApp.NameSpace(CVar(oFolder)).CopyHere oApp.NameSpace(CVar(strpath)).Items
                        On Error GoTo 0
                      vProtect = vProtect & vbCr & .DisplayName
                    Case Else
                  
                End Select
nxt:
                Kill strpath
            If Not oFile Is Nothing Then Set oFile = Nothing
        End With
    Next
CheckAttachmentPassword = vProtect
If Not oApp Is Nothing Then Set oApp = Nothing
If Not appXL Is Nothing Then Set appXL = Nothing
End If

Exit Function

xError:
Err.Clear
CheckAttachmentPassword = "ERROR"
MsgBox "Something went wrong!", vbCritical, "Error"
End Function


Function OnlyAlphaNumeric(strSource As String) As String
'only allow alpha and Numeric
    Dim i As Integer
    Dim strResult As String

    For i = 1 To Len(strSource)
        Select Case Asc(Mid(strSource, i, 1))
            Case 65 To 90, 97 To 122, 48 To 57
                strResult = strResult + Mid(strSource, i, 1)
        End Select
    Next
    OnlyAlphaNumeric = strResult
End Function
 
Last edited:
Dear All,

I need a outlook VBA code to check if the atatched file is password protected or not and if it is ot then it should stop sending mail otherwise mail can be sent.Kindly help
 
Are u looking vba code to check upon each email sending from outlook and what will the file types to check.
 
Hi Deepak,

Yes, I want to check all the outgoing mails for password protection. If the file is not password protected then it should give msg and stop that mail. Otherwise it send the mail. File type us momostky Excel or word.

Regards
 
Shailendra Singh said:
Hi Deepak,

Yes, I want to check all the outgoing mails for password protection. If the file is not password protected then it should give msg and stop that mail. Otherwise it send the mail. File type us momostky Excel or word.

Regards
Click to expand...

So, The code given here didn't work for u?

I have updated the code as well...


In ThisOutlookSession...


Code: 
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Dim strCheck As String

Cancel = True

On Error GoTo xEnd
strCheck = CheckAttachmentPassword(Item)

If Len(strCheck) > 0 Then
    If strCheck <> "ERROR" Then
        MsgBox "Following attachments are unprotected." & vbCr & strCheck, vbCritical, "Result"
        Exit Sub
    End If
Else
    Cancel = False
End If

Exit Sub

xEnd:
Err.Clear
Cancel = True
MsgBox "Something went wrong in the automated script!", vbCritical, "Error"
End Sub


In a module...

Code: 
Option Explicit

Function CheckAttachmentPassword(ByVal oMail As Object) As String
Dim atmnt As Attachment, oFolder As String, strpath As String, vProtect As String
Dim appXL As Object, oFile As Object, strExt As String, oApp As Object
Dim appWord As Object, oDoc As Object, FSO As Object


CheckAttachmentPassword = ""
vProtect = ""
On Error GoTo xError

If oMail.Attachments.Count > 0 Then
oFolder = "c:\temp"
Set appXL = CreateObject("Excel.Application")
Set oApp = CreateObject("Shell.Application")
Set appWord = CreateObject("Word.Application")

Set FSO = CreateObject("scripting.filesystemobject")

With FSO
    If .FolderExists(oFolder) Then
        On Error Resume Next
            .deletefile oFolder & "\*.*", True
            .deletefolder oFolder & "\*.*", True
        On Error GoTo 0
    End If
End With

If Not FSO.FolderExists(oFolder) Then MkDir (oFolder)

    For Each atmnt In oMail.Attachments
        With atmnt
            Randomize
            strpath = .DisplayName
            strExt = Mid(strpath, InStrRev(strpath, ".") + 1)
            strpath = oFolder & "\" & Left(Split(Str(Rnd), ".")(1), 5) & OnlyAlphaNumeric(Replace(strpath, "." & strExt, "")) & "." & strExt
            .SaveAsFile strpath
                Select Case strExt
                    Case "xls", "xlsx", "xlsb", "xlsm"
                      Set oFile = appXL.workbooks.Open(strpath)
                            If oFile.ProtectWindows Or oFile.ProtectStructure Then
                         
                            Else
                                vProtect = vProtect & vbCr & .DisplayName
                            End If
                        oFile.Close 0
                    Case "zip", "rar"
                        On Error GoTo nxt
                            oApp.NameSpace(CVar(oFolder)).CopyHere oApp.NameSpace(CVar(strpath)).Items
                        On Error GoTo 0
                       
                      vProtect = vProtect & vbCr & .DisplayName
                    Case "doc", "docx"
                    'https://wordmvp.com/FAQs/MacrosVBA/CheckIfPWProtectB4Open.htm
                            On Error Resume Next
                            Set oDoc = appWord.Documents.Open(FileName:=strpath, _
                                                PasswordDocument:="ABCDXYZ", ReadOnly:=True)
                                Select Case Err.Number
                                    Case 0
                                        vProtect = vProtect & vbCr & .DisplayName
                                    Case 5408 'Protected
                                            Err.Clear
                                                On Error GoTo 0
                                    Case Else
                                        vProtect = vProtect & vbCr & .DisplayName
                                End Select
                            On Error GoTo 0
                            If Not oDoc Is Nothing Then oDoc.Close ': Set oDoc = Nothing
                    Case Else
                 
                End Select
nxt:
                Kill strpath
            If Not oFile Is Nothing Then Set oFile = Nothing
        End With
    Next
CheckAttachmentPassword = vProtect
appWord.Quit
If Not oFile Is Nothing Then Set oFile = Nothing
If Not oApp Is Nothing Then Set oApp = Nothing
If Not appXL Is Nothing Then Set appXL = Nothing
If Not appWord Is Nothing Then Set appWord = Nothing

End If

Exit Function

xError:
Err.Clear
CheckAttachmentPassword = "ERROR"
MsgBox "Something went wrong!", vbCritical, "Error"
End Function


Function OnlyAlphaNumeric(strSource As String) As String
'only allow alpha and Numeric
  Dim i As Integer
    Dim strResult As String

    For i = 1 To Len(strSource)
        Select Case Asc(Mid(strSource, i, 1))
            Case 65 To 90, 97 To 122, 48 To 57
                strResult = strResult + Mid(strSource, i, 1)
        End Select
    Next
    OnlyAlphaNumeric = strResult
End Function
 
Hi Deepak,

The above code is brilliant at detecting non passworded attachments.. However if an attachment has a password the code opens the application of the attachment and asks for the password. How can we change the code to send the email if the attachment is passworded.

Thanks a lot
 
Professorpanda said:
Hi Deepak,

The above code is brilliant at detecting non passworded attachments.. However if an attachment has a password the code opens the application of the attachment and asks for the password. How can we change the code to send the email if the attachment is passworded.

Thanks a lot
Click to expand...

I assume it should send the email. pls check and confirm.
 
Dear Deepak,

I tried it once again, however the email is not send if the attachment does have password. It opens up the file and asks for the password.Please see screenshots of the error


upload_2019-2-13_16-52-11.png

upload_2019-2-13_16-52-29.png
 
Thanks everyone for contributing. If you find any other solutions and alternatives while testing with above please share here.

Cheers
 
Hello,

First of all, thank you for the code provided as it might be very helpful to as a guard rails in case of forgetting to add password on file and helping to keep my bosses happy :)
Unfortunately vba does not work for me (i have copied the code as it is said) and I get "Something Went Wrong" error.
As I'm novice with VBA, could anyone take a look at the code above and maybe post updated working code?

I really appreciate the help.
 
Status
Not open for further replies.
Back
Top