Outlook VBA to detect non-password protected attachements

[Oredo]

Hello All,

I would like to look for some help with the Outlook VBA script. I found the scrip on Chandoo and all cudos goes to author "Deepak"
(VBA Code to Detect Non Password Protected Attachment)

In short, the task is to check each of outgoing emails with (doc, ppt or excel files) to be password protected.

I did the author for advise, but as it is quite urgent matter, so i decided to ask it here as well.
Code gives me an error "Something went Wrong" in a script and me being a novice in VBA, i fail to detect the issue. Code is as follows:

In ThisOutlookSession

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 Module:

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

I appreciate your input guys

Also asked here Outlook VBA to detect non-password protected attachements