Sub MailExport()
  MailExportSub ("WITH")
End Sub

Sub MailExportWithoutAttachments()
  MailExportSub ("WITHOUT")
End Sub

Sub MailExportSub(cFlag As String)
 Dim strname As String
 Dim cPath   As String
 Dim myItem  As Inspector
 Dim objItem As Object
 
 
  
 cPath = RegRead("HKEY_CURRENT_USER\Software\SSS\PC CADDIE\ImportPath")
            
 Set myItem = Application.ActiveInspector
  
  If Not TypeName(myItem) = "Nothing" Then
      Set objItem = myItem.CurrentItem
      
      
      If objItem.Class = olMail Then
        If objItem.Sent And objItem.Sent Then
          objItem.FlagStatus = olFlagComplete
        Else
          objItem.FlagIcon = olGreenFlagIcon
        End If
        objItem.Save
      Else
        objItem.Importance = olImportanceLow
      End If
      
      
      strname = URLEncode(VBA.Strings.Left(objItem.Subject, 100))
      If objItem.SenderEmailAddress = "" Then
        ' 20080928: CurrentUser geht bei BS nicht Or objItem.SenderEmailAddress = objItem.Session.CurrentUser.Address Then
        strname = strname & URLEncode(" [" & objItem.To & " (" & objItem.CreationTime & ")]")
      Else
        If objItem.SenderEmailAddress Like "*SMALLBUSINESS*" Then
          strname = strname & URLEncode(" [" & objItem.SenderName & " (" & objItem.SentOn & ")]")
        Else
          strname = strname & URLEncode(" [" & objItem.SenderEmailAddress & " (" & objItem.SentOn & ")]")
        End If
      End If
      
           
      objItem.SaveAs cPath & strname & ".msg", olMSG
      
      ' objitem.FlagStatus = olFlagComplete
      
      ' objitem.Save
      
      If Not objItem.Sent Then
        objItem.Send
      End If
      
      If cFlag = "WITHOUT" Then
        While objItem.Attachments.Count > 0
          'entferne es (wird für Outlook 2002/2003 benötigt)
          objItem.Attachments.Remove 1
          
          'entferne es (wird für Outlook 2000 benötigt)
          'myAnhänge(1).Delete
        
        Wend
        
        objItem.SaveAs cPath & strname & ".msg", olMSG
          
     End If
     
  Else
      MsgBox "Es ist keine Mail geöffnet, die gespeichert werden könnte."
  End If

End Sub

Public Function RegRead(Path As String) As String

Dim objRegObjekt As Object

'On Error GoTo RegRead_Error

  Set objRegObjekt = CreateObject("WScript.Shell")
  objRegObjekt.RegRead (Path)
  RegRead = objRegObjekt.RegRead(Path)
  Exit Function

'On Error GoTo 0
End Function

Function testURLEncode(Str As String) As String
  URLEncode = Str
End Function

Function URLEncode(Str As String) As String
  Dim i As Integer
  Dim nAsc As Integer
  
  URLEncode = Str
  For i = VBA.Strings.Len(URLEncode) To 1 Step -1
    nAsc = Asc(VBA.Strings.Mid$(URLEncode, i, 1))
    Select Case nAsc
      Case 48 To 57, 65 To 90, 97 To 122
      Case VBA.Strings.Asc(" ")
      Case VBA.Strings.Asc("(")
      Case VBA.Strings.Asc(")")
      Case VBA.Strings.Asc("[")
      Case VBA.Strings.Asc("]")
      Case VBA.Strings.Asc(".")
      'Case 32
      '  VBA.Strings.Mid$(URLEncode, i, 1) = "+"
      Case Else
        URLEncode = VBA.Strings.Left$(URLEncode, i - 1) & _
         "%" & VBA.Hex$(nAsc) & VBA.Strings.Mid$(URLEncode, i + 1)
    End Select
  Next
End Function




Sub orgMailExport()
 Dim strname As String
 Dim cPath As String
 Dim myItem As Inspector
 Dim objItem As Object
 
 
    
 
 
 cPath = "C:\ADRESSEN\Server\"
 ' cPath = "F:\Data\User\BS\ADRESSEN\IMPORT\"
 ' cPath = "\\192.168.115.1\BS\ADRESSEN\IMPORT\"
 ' cPath = "C:\PCCADDIE\IMPORT\"
 ' cPath = "L:\ADRESSEN\IMPORT\"
  
 Set myItem = Application.ActiveInspector
  
  If Not TypeName(myItem) = "Nothing" Then
      Set objItem = myItem.CurrentItem
      
      If objItem.Sent Then
        objItem.FlagStatus = olFlagComplete
      Else
        objItem.FlagIcon = olGreenFlagIcon
      End If
      
      objItem.Save
      
      strname = URLEncode(VBA.Strings.Left(objItem.Subject, 60))
      If objItem.SenderEmailAddress = "" Or objItem.SenderEmailAddress = objItem.Session.CurrentUser.Address Then
            strname = strname & URLEncode(" [" & objItem.To & " (" & objItem.CreationTime & ")]")
      Else
            strname = strname & URLEncode(" [" & objItem.SenderEmailAddress & " (" & objItem.SentOn & ")]")
      End If
      
      objItem.SaveAs cPath & strname & ".msg", olMSG
      
      ' objitem.FlagStatus = olFlagComplete
      
      ' objitem.Save
      
      If Not objItem.Sent Then
        objItem.Send
      End If
      
  Else
      MsgBox "Es ist keine Mail geöffnet, die gespeichert werden könnte."
  End If

End Sub