Attribute VB_Name = "OL_Anhänge"
Option Explicit

'Erfordert:
'- Installiertes Open-Source-Packprogramm 7-Zip
'- Microsoft Windows Image Acquisition Library v2.0 und Verweis darauf
'- Installiertes ActiveX-Control UniversalTools.ocx
'- Aktiven Windows Scripting Host

'© 2006, Ralf Nebelo

'Anwendungsnamen festlegen
Public Const APPNAME As String = "Anhang-Manager für Outlook"

'**************************************************************
'Makros
'**************************************************************

Public Sub SymLeisteAnzeigen(Optional objInspector As Inspector)
    Dim objCB As CommandBar

    'Fehlerverfolgung ausschalten
    On Error Resume Next

    With objInspector
        'Aktuelle Befehlsleiste aus Inspector-Fenster löschen
        .CommandBars(APPNAME).Delete
        'Befehlsleiste neu anlegen
        Set objCB = .CommandBars.Add(APPNAME, msoBarBottom, , True)
    End With

    'Befehlsleiste mit Makrostart-Schaltfläche(n) bestücken.
    Call ButtonAnlegen(objCB, APPNAME, 144, "AnhängeEinfügen", False)

    'Befehlsleiste sichtbar machen
    objCB.Visible = True
End Sub

Public Sub AnhängeEinfügen()
    'Userform frmZipEinfügen aufrufen
    frmAnhänge.Show
End Sub

'**************************************************************
'WIA-Routinen
'**************************************************************

Public Function WIA_GerätVorhanden(GeräteTyp As WIA.WiaDeviceType) As String
    Dim wiaManager As New WIA.DeviceManager
    Dim wiaGeräteInfo As WIA.DeviceInfo

    'Alle Geräte im WIA-Device-Manager durchlaufen
    For Each wiaGeräteInfo In wiaManager.DeviceInfos
        'Wenn Typ des aktuellen Geräts dem angegebenen Typ entspricht, dann...
        If wiaGeräteInfo.Type = GeräteTyp Then
            '... ID des Gerät zurückgeben
            WIA_GerätVorhanden = wiaGeräteInfo.DeviceID
            'Schleife verlassen
            Exit For
        End If
    Next
End Function

'**************************************************************
'Allgemeine Routinen
'**************************************************************

Private Sub ButtonAnlegen(objCB As CommandBar, strCaption As String, intFaceID As Integer, strMakro As String, blnGruppe As Boolean)
    Dim objCTL As CommandBarControl
            
    'Schaltfläche anlegen
    Set objCTL = objCB.Controls.Add(Type:=msoControlButton)
    With objCTL
        .BeginGroup = blnGruppe
        'Beschriftung festlegen
        .Caption = strCaption
        'Grafisches Symbol festlegen
        .FaceId = intFaceID
        'Stil festlegen
        .Style = msoButtonIconAndCaption
        'Makro zuweisen
        .OnAction = strMakro
    End With
End Sub

Public Function Hol7ZipPfadname() As String
    Dim objWSH As Object
    Dim strPfad As String
    
    'Fehlerverfolgung ausschalten
    On Error Resume Next
    
    'Verweis auf Windows Scripting Host holen
    Set objWSH = CreateObject("WScript.Shell")
    
    'Installationspfad aus Registry lesen
    strPfad = objWSH.RegRead("HKLM\SOFTWARE\7-Zip\Path")
    'Wenn Kommandozeilen-Tool 7za.exe vorhanden, dann...
    If Dir(AddSlash(strPfad) & "7za.exe") > "" Then
        '... dessen Pfadnamen zurückgeben
        Hol7ZipPfadname = AddSlash(strPfad) & "7za.exe"
    'Ansonsten...
    Else
        '... leere Zeichenkette zurückgeben
        Hol7ZipPfadname = ""
    End If
    
    'Verweis auf Windows Scripting Host löschen
    Set objWSH = Nothing
End Function

Public Function AddSlash(strPfad As String) As String
    'Wenn Pfad nicht mit Backslash endet, dann...
    If Right(strPfad, 1) <> "\" Then
        '... Backslash anfügen und Pfad zurückgeben
        AddSlash = strPfad & "\"
    'Ansonsten...
    Else
        '... Pfad unverändert zurückgeben
        AddSlash = strPfad
    End If
End Function

Public Function ProgrammStarten(strProgramm As String, Optional strParameter As String = "", Optional blnSichtbar As Boolean = False) As Integer
    Dim objWSH As Object
    
    'Fehlerverfolgung ausschalten
    On Error Resume Next
        
    'Verweis auf Windows Scripting Host holen
    Set objWSH = CreateObject("WScript.Shell")

    'Programm in gewünschter Sichtbarkeit starten und ggf. Parameter
    'übergeben, Rückgabe-Code als Funktionswert zurückgeben
    ProgrammStarten = objWSH.Run(strProgramm & IIf(strParameter > "", " " & strParameter, ""), blnSichtbar, True)
    
    'Verweis auf Windows Scripting Host löschen
    Set objWSH = Nothing
End Function

Public Function HolAnhangName(objMail As MailItem, strBasisname As String, strExtension As String) As String
    Dim intZähler As Integer
    Dim strTmp As String
    
    'Endlosschleife starten
    Do
        'Laufende Bildnummer jeweils um 1 erhöhen
        intZähler = intZähler + 1
        'Anhangnamen aus Basisnamen, Nummerierung und Extension zusammensetzen
        strTmp = strBasisname & Format(intZähler, "000") & "." & strExtension
    'Schleife wiederholen, bis es keinen Anhang mehr in der
    'aktuellen Nachricht gibt, der den aktuellen Namen trägt
    Loop Until AnhangVorhanden(objMail, strTmp) = False
        
    'Anhangnamen zurückgeben
    HolAnhangName = strTmp
End Function

Private Function AnhangVorhanden(objMail As MailItem, strAnhangName As String) As Boolean
    Dim objAnhang As Attachment
    
    'Alle Anhänge der Nachricht durchlaufen
    For Each objAnhang In objMail.Attachments
        'Wenn es einen Anhang mit dem gleichen Dateinamen gibt, dann...
        If LCase(objAnhang.FileName) = LCase(strAnhangName) Then
            '... den Wert True zurückgeben
            AnhangVorhanden = True
            'Schleife verlassen
            Exit For
        End If
    Next
End Function

Public Function HolDateigröße(strDatei As String) As Currency
    Dim objFSO As Object
    Dim objDatei As Object
    
    'Fehlerverfolgung ausschalten
    On Error Resume Next
    
    'Verweis auf FileSystemObject-Objekt holen
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'Wenn Datei existiert, dann...
    If objFSO.FileExists(strDatei) Then
        '...Verweis auf Datei holen
        Set objDatei = objFSO.GetFile(strDatei)
        'Dateigröße in Bytes zurückgeben
        HolDateigröße = CCur(objDatei.Size)
    End If
    
    'Verweis auf FileSystemObject-Objekt löschen
    Set objFSO = Nothing
End Function

Public Function DateiVorhanden(strDatei As String) As Boolean
    Dim objFSO As Object
    Dim objDatei As Object
    
    'Fehlerverfolgung ausschalten
    On Error Resume Next
    
    'Verweis auf FileSystemObject-Objekt holen
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    'Status der Existenz zurückgeben
    DateiVorhanden = objFSO.FileExists(strDatei)
    
    'Verweis auf FileSystemObject-Objekt löschen
    Set objFSO = Nothing
End Function

Public Function HolPfadEigeneDateien() As String
    Dim objWSH As Object
    
    'Fehlerverfolgung ausschalten
    On Error Resume Next
    
    'Verweis auf Windows Scripting Host einrichten
    Set objWSH = CreateObject("WScript.Shell")

    'Pfad des Ordners "Eigene Dateien" zurückgeben
    HolPfadEigeneDateien = objWSH.SpecialFolders("MyDocuments")
    
    'Verweis auf Windows Scripting Host löschen
    Set objWSH = Nothing
End Function

Public Function MB2Bytes(dblMB As Double) As Currency
    'Anzahl der Bytes zurückgeben
    MB2Bytes = Round(dblMB * CCur(1024) * CCur(1024), 0)
End Function

Public Function Bytes2MB(curBytes As Currency) As Double
    'Anzahl der MB zurückgeben
    Bytes2MB = Round(curBytes / 1024 / 1024, 2)
End Function

Public Function HolDateinamenMitZähler(strPfad As String, strBasisname As String, strExtension As String) As String
    Dim intZähler As Integer
    Dim strDateiname As String
    
    'Schleife starten
    Do
        'Zähler erhöhen
        intZähler = intZähler + 1
        'Dateinamen aus Basisnamen, dreistellig formatiertem
        'Zähler und Extension zusammensetzen
        strDateiname = strBasisname & "_" & Format(intZähler, "000") & "." & strExtension
        'Wenn keine Datei mit diesem Namen existiert, dann...
        If Dir(strPfad & IIf(Right(strPfad, 1) = "\", "", "\") & strDateiname) = "" Then
            '... Schleife verlassen
            Exit Do
        End If
    Loop Until intZähler = 100
        
    'Dateinamen zurückgeben
    HolDateinamenMitZähler = strDateiname
End Function

Public Function HolGültigenDateinamen(strMöglicherDateiname As String) As String
    Dim strTmp As String
    Dim strNichtErlaubt As String
    Dim intI As Integer
    
    'Übergebenen Dateinamen in strTmp kopieren
    strTmp = strMöglicherDateiname
    'Nicht erlaubte Zeichen definieren
    strNichtErlaubt = "\/:*?<>|" & Chr(34)
    
    'Jedes Zeichen in strTmp durchlaufen
    For intI = 1 To Len(strTmp)
        'Wenn aktuelles Zeichen nicht erlaubt ist, dann...
        If InStr(strNichtErlaubt, Mid(strTmp, intI, 1)) > 0 Then
            '... durch Unterstrich ersetzen
            Mid(strTmp, intI, 1) = "_"
        End If
    Next
    
    'Gültigen Dateinamen zurückgeben
    HolGültigenDateinamen = strTmp
End Function

Public Function OrdnerAnlegen(strParentOrdner As String, strNeuerOrdner As String) As Boolean
    Dim objFSO As Object
    Dim strPfad As String
    Dim objParentOrdner
    Dim objNeuerOrdner

    'Fehlerverfolgung ausschalten
    On Error Resume Next
    
    'Verweis auf FileSystemObject-Objekt holen
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    
    'Pfad des neuen Ordners aus Parentordnerpfad und Ordnernamen bilden
    strPfad = objFSO.BuildPath(strParentOrdner, strNeuerOrdner)

    'Wenn neuer Ordner noch nicht existiert, dann...
    If objFSO.FolderExists(strPfad) = False Then
        '... Verweis auf Parentordner holen
        Set objParentOrdner = objFSO.GetFolder(strParentOrdner)
        'Neuen Ordner als Unterordner des Parentordners anlegen
        Set objNeuerOrdner = objParentOrdner.SubFolders.Add(strNeuerOrdner)
    End If

    'Verweis auf FileSystemObject-Objekt löschen
    Set objFSO = Nothing

    'Wenn keine Probleme, True zurückgeben sonst False
    OrdnerAnlegen = Err = 0
End Function
