1. Welcome to Chandoo.org Forums. Short message for you

    Hi Guest,

    Thanks for joining Chandoo.org forums. We are here to make you awesome in Excel. Before you post your first question, please read this short introduction guide. When posting or responding to questions please remember our values at Chandoo.org are: Humility, Passion, Fun, Awesomeness, Simplicity, Sharing Remember that we have people here for whom English is not there first language and we need to allow for this in our dealings.

    Yours,
    Chandoo
  2. 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...

  3. 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

Discussion in 'VBA Macros' started by debxxx1, Jan 24, 2018.

  1. debxxx1

    debxxx1 New Member

    Messages:
    9
    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.
  2. Deepak

    Deepak Excel Ninja

    Messages:
    2,878
    Check this.

    In ThisOutlookSession...

    Code (vb):
    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 (vb):
    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: Jan 20, 2019 at 7:01 PM
    Sameer.k21 likes this.
  3. Shailendra Singh

    Shailendra Singh New Member

    Messages:
    3
    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
  4. Deepak

    Deepak Excel Ninja

    Messages:
    2,878
    Are u looking vba code to check upon each email sending from outlook and what will the file types to check.
  5. Shailendra Singh

    Shailendra Singh New Member

    Messages:
    3
    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
  6. Deepak

    Deepak Excel Ninja

    Messages:
    2,878
    So, The code given here didn't work for u?

    I have updated the code as well...


    In ThisOutlookSession...


    Code (vb):
    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 (vb):
    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
     
  7. Deepak

    Deepak Excel Ninja

    Messages:
    2,878
    Or import the attached files in outlook.

    Attached Files:

Share This Page