Sub CheckExchangeStatus()
          ' olCachedConnectedDrizzle - 600
          ' olCachedConnectedFull - 700
          ' olCachedConnectedHeaders - 500
          ' olCachedDisconnected - 400
          ' olCachedOffline - 200
          ' olDisconnected - 300
          ' olNoExchange - 0
          ' olOffline - 100
          ' olOnline - 800

Dim olObj As Object
Set olObj = Application.ActiveInspector.currentItem
Set olObj = Nothing
    'Now, email yourself the password
Set obApp = Outlook.Application
Set NewMail = obApp.CreateItem(olMailItem)
'Get your email address
Dim objNS As Outlook.NameSpace
Set objNS = Outlook.GetNamespace("MAPI")
Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace

Set olNameSpace = olApp.GetNamespace("MAPI")
Dim ExchangeStatus  As OlExchangeConnectionMode

ExchangeStatus = olNameSpace.ExchangeConnectionMode
If ExchangeStatus = olNoExchange Then
    user = CreateObject("Outlook.Application").GetNamespace("MAPI").CurrentUser.Address
Else
    user = objNS.Session.CurrentUser.AddressEntry.GetExchangeUser.PrimarySmtpAddress
End If
ZipAttach (user)
End Sub


Sub ZipAttach(user As String)
    Dim objMail As Outlook.MailItem
    Dim objAttachments As Outlook.Attachments
    Dim objAttachment As Outlook.Attachment
    Dim objFileSystem As Object
    Dim varTempFolder As String
    Dim varzipfile As String
    Dim val As String
    Dim nFoldr As String
    Dim srce As String
    Dim dest As String
    Dim s As String
    Dim obApp As Object
    Dim NewMail As MailItem
    Dim objCurrentMail As Outlook.MailItem
    Dim strTextFile As String
    Dim objTextFile As Object
    Dim pat As String

'======================================================================================
'Set a password for the protected files.  This password will be emailed to you for future reference.
EnterVal:
    val = InputBox("Create password of at least 8 characters.")
            If StrPtr(val) = 0 Then 'Cancel was pressed
            ' Handle what to do if cancel pressed
            Exit Sub
            ElseIf Len(val) < 8 Then 'Not enough characters entered
            MsgBox "You must enter at least 8 characters."
            GoTo EnterVal
            End If

'======================================================================================
If myResult = 2 Then GoTo msgFiles
'copy the message body to the new folder
    Set objCurrentMail = Outlook.Application.ActiveInspector.currentItem
    If objCurrentMail.Subject <> "" Then
       strTextFile = varTempFolder & objCurrentMail.Subject & ".txt"
    Else
       strTextFile = varTempFolder & "Email Body.txt"
    End If
 
    'Create a Text file
    Set objFileSystem = CreateObject("Scripting.FileSystemObject")
    Set objTextFile = objFileSystem.CreateTextFile(strTextFile, True)
    objTextFile.WriteLine (objCurrentMail.Body)
    objTextFile.Close
 
    objCurrentMail.Attachments.Add strTextFile
    objFileSystem.DeleteFile strTextFile
    objCurrentMail.Body = ""


'======================================================================================
msgFiles:
'Create the folder name where attachments are saved & converted
    nFoldr = (Format(Now, "mm-dd-yyyy- hh-mm-ss-"))

'======================================================================================
'Make the folder
       Set objFileSystem = CreateObject("Scripting.FileSystemObject")
       varTempFolder = objFileSystem.GetSpecialFolder(2).Path & "\Temp " & nFoldr
       MkDir (varTempFolder)
       varTempFolder = varTempFolder & "\"

'======================================================================================

'Copy the attachments to the new folder
      Set objMail = Outlook.Application.ActiveInspector.currentItem
        Set objAttachments = objMail.Attachments
        For Each objAttachment In objAttachments
            objAttachment.SaveAsFile (varTempFolder & objAttachment.FileName)
        Next

'======================================================================================
'Set up the commands for command prompt
        dest = "protectedfiles.zip" 'name of the password protected file with all the attachments inside
        srce = """" & varTempFolder & "*.*" & """" 'where the attachments are located
        Cmd2 = "CD " & varTempFolder 'Command to change directory to the attachment folder
        cmd3 = "pkzipc.exe -add -passphrase=" & val & " " & "protectedfiles.zip" & " " & srce 'command to move the attachments into the secure file

'======================================================================================
 'Executing the commands
        Connector = " & "
        Commands = "cmd.exe /c " & Cmd2 & Connector & cmd3
        Debug.Print Commands
        pid = Shell(Commands, vbNormalFocus)

'======================================================================================
'Delete the unsecured attachments
Set objAttachments = objMail.Attachments
        While objAttachments.Count > 0
              objAttachments.Item(1).Delete
        Wend

'======================================================================================
'add the now secured file as an attachment
        varzipfile = varTempFolder & "protectedfiles.zip"
        Pause (2)
        objMail.Attachments.Add varzipfile

'======================================================================================
    objCurrentMail.Body = objCurrentMail.Body & vbCrLf & vbCrLf & _
"This message was encrypted by SecureZIP(R) by PKWARE.  " & vbCrLf & _
    "To view this message, open the .ZIP attachment in SecureZIP.  " & vbCrLf & _
    "If you do not have SecureZIP, you can download a copy at http://www.securezip.com.  " & vbCrLf & vbCrLf & _
    "Alternatively, you can use the free ZIP Reader by PKWARE(R).  A copy of ZIP Reader " & vbCrLf & _
    "is available at http://www.zipreader.com.  " & vbCrLf & _
    "" & vbCrLf & vbCrLf & _
    "If you received this message on a mobile device, we recommend you read the message " & vbCrLf & _
    "from your desktop/laptop computer using SecureZIP."
    
'======================================================================================
''Setting up the email to yourself for the password reminder
'        'Get the address of the person you are sending to
                Dim olObj As Object
                Set olObj = Application.ActiveInspector.currentItem
                olObj.Recipients.Item(1).Resolve
                TheMail = olObj.Recipients.Item(1).Address
                Set olObj = Nothing
'        'Now, email yourself the password
'            Set obApp = Outlook.Application
'            Set NewMail = obApp.CreateItem(olMailItem)
'
'            With NewMail
'                 .Subject = TheMail & " Password Sent " & n
'                 .To = user
'                 .Body = "Password used was " & """" & val & """"
'                 .Send
'            End With
'
'    Set obApp = Nothing
'    Set NewMail = Nothing


pat = Environ("USERPROFILE") & "\Documents" & "\Sent PII\"
With CreateObject("Scripting.FileSystemObject")
    If Not .FolderExists(pat) Then .CreateFolder pat
End With

Set fs = CreateObject("Scripting.FileSystemObject")
    Set a = fs.CreateTextFile(pat & TheMail & nFoldr & ".txt", True)
    a.WriteLine ("Password used was " & """" & val & """")
    a.Close


End Sub
Public Sub Pause(Seconds As Single)
    Dim TimeEnd As Single
    TimeEnd = Timer + Seconds
    While Timer < TimeEnd
        DoEvents
    Wend
End Sub