voici le debut
Sub MailSocos(textBody, Eingangsdatum, Absender)
'Es wird ein Array mit den Informationen aus der Socos E-Mail erstellt.
Dim Sachgebiet As String
Sachgebiet = SocosFindeSachgebiet(textBody)
Dim Anfangswort As String
Dim Endwort As String
Dim gekuerzterText As String
Anfangswort = "Hinweis"
Endwort = "Spalte"
'Textkörper aus der E-Mail wird gekürzt. (Nur die Tabelle in der Socos E-Mail ist wichtig)
gekuerzterText = KuerzeText(textBody, Anfangswort, Endwort)
'Unnötige Zeichen an Textanfang und -ende werden entfernt
gekuerzterText = SocosEntferneLeerzeichen(gekuerzterText)
If gekuerzterText Like "0" Then
Exit Sub
End If
Dim socosArray() As String
'Informationen aus der Tabelle werden in Array überführt.
'In diesem Schritt ist das socosArray 1:1 so augebaut, wie die Tabelle in der E-Mail
socosArray = SocosErstelleArray(gekuerzterText)
'Link wird aus erster Spalte entfernt, es bleibt nur noch das Dokument (Dokumentennummer) übrig
socosArray = SocosBearbeiteErsteSpalte(socosArray)
'Der Eintrag 'Titel' aus der Tabelle wird in zwei Spalten (Dokument und Titel) aufgeteilt
socosArray = SocosFuegeSpalteHinzu(socosArray)
'Es wird ein Array erstellt, dass alle relevanten Zeilennummern enthält
'Gibt es den gleichen Eintrag in mehreren Sprachen, wird nur der deutsche berücksichtigt
Dim WichtigeZeilenArray() As Integer
WichtigeZeilenArray = SocosFindeWichtigeZeilen(socosArray)
'Mit Hilfe der wichtigen Zeilen, werden aus dem socosArray die unwichtigen entfernt
socosArray = SocosEntferneUeberfluessigeZeilen(socosArray, WichtigeZeilenArray)
'Der Link wir angepasst, so dass er im weiteren Verlauf verwendet werden kann
socosArray = BearbeiteLink(socosArray)
'socosArray wird übergeben, um es in Excel einzutragen
Call ExcelEintragen(socosArray, Eingangsdatum, Absender, Sachgebiet)
End Sub
Function SocosFindeWichtigeZeilen(socosArray)
'Es wird ein Array erstellt, dass alle relevanten Zeilennummern enthält
'Gibt es den gleichen Eintrag in mehreren Sprachen, wird nur der deutsche berücksichtigt
Dim socosRows As Integer
Dim SocosCols As Integer
socosRows = UBound(socosArray)
SocosCols = UBound(socosArray, 2)
Dim targetArray() As Integer
Dim targetArrayLength As Integer
targetArrayLength = -1
Dim targetColIndex
Dim AnzahlGleicheZeilen
AnzahlGleicheZeilen = 1
Dim socosRowIndex As Integer
Dim SocosRowDeutsch As Integer
If socosRows > 0 Then
For socosRowIndex = 0 To (socosRows - 1)
If socosArray(socosRowIndex, 0) = socosArray(socosRowIndex + 1, 0) And socosArray(socosRowIndex, 9) = socosArray(socosRowIndex + 1, 9) Then
AnzahlGleicheZeilen = AnzahlGleicheZeilen + 1
'Sonderbedingung, wenn das Array Ende erreicht ist:
If socosRowIndex = socosRows - 1 Then
socosRowIndex = socosRowIndex + 1
SocosRowDeutsch = SocosFindeDeutsch(socosArray, socosRowIndex, AnzahlGleicheZeilen)
targetArrayLength = targetArrayLength + 1
ReDim Preserve targetArray(targetArrayLength)
targetArray(targetArrayLength) = SocosRowDeutsch
AnzahlGleicheZeilen = 1
End If
Else
targetArrayLength = targetArrayLength + 1
ReDim Preserve targetArray(targetArrayLength)
If AnzahlGleicheZeilen = 1 Then
targetArray(targetArrayLength) = socosRowIndex
Else
SocosRowDeutsch = SocosFindeDeutsch(socosArray, socosRowIndex, AnzahlGleicheZeilen)
targetArray(targetArrayLength) = SocosRowDeutsch
End If
AnzahlGleicheZeilen = 1
'Sonderbedingung, wenn das Array Ende erreicht ist:
If socosRowIndex = socosRows - 1 Then
targetArrayLength = targetArrayLength + 1
ReDim Preserve targetArray(targetArrayLength)
targetArray(targetArrayLength) = socosRowIndex + 1
End If
End If
Next socosRowIndex
Else
ReDim targetArray(0)
targetArray(0) = 0
End If
SocosFindeWichtigeZeilen = targetArray
End Function
Function SocosFindeDeutsch(socosArray, socosRowIndex, SocosRowAnzahl)
'In mehreren inhaltlich gleichen Zeilen wird die deutsche gesucht und deren Zeilennummer zurückgegeben
Dim DeutschIndex As Integer
DeutschIndex = socosRowIndex - SocosRowAnzahl + 1
Dim findeDeutschIndex As Integer
Dim Start As Integer
Dim Ende As Integer
Start = socosRowIndex - SocosRowAnzahl + 1
Ende = socosRowIndex
For findeDeutschIndex = Start To Ende
If socosArray(findeDeutschIndex, 5) Like "DE" Then
DeutschIndex = findeDeutschIndex
End If
Next findeDeutschIndex
SocosFindeDeutsch = DeutschIndex
End Function
Function SocosEntferneUeberfluessigeZeilen(socosArray, WichtigeZeilenArray)
'Zeilen, die mehrfach in verschiedenen Sprachen vorkommen, werden entfernt
Dim targetArray() As String
Dim targetRows As Integer
Dim targetCols As Integer
targetRows = UBound(WichtigeZeilenArray)
targetCols = UBound(socosArray, 2)
ReDim targetArray(targetRows, targetCols)
Dim targetRowIndex As Integer
Dim targetColIndex As Integer
For targetRowIndex = 0 To targetRows
For targetColIndex = 0 To targetCols
targetArray(targetRowIndex, targetColIndex) = socosArray(WichtigeZeilenArray(targetRowIndex), targetColIndex)
Next targetColIndex
Next targetRowIndex
SocosEntferneUeberfluessigeZeilen = targetArray
End Function
Sub ExcelEintragen(originalArray, Eingangsdatum, Absender, Sachgebiet)
'Die mit den Informationen bestückten Arrays werden in Excel eingetragen
Dim freieZeile As Long
Dim OriginalRows As Integer
OriginalRows = UBound(originalArray)
Dim originalRowIndex As Integer
For originalRowIndex = 0 To OriginalRows
'Wenn in Spalte 6 ein Eintrag vorhanden ist, wird dieser genommen, ansonsten der aus Spalte 0
Dim Dokument As String
If originalArray(originalRowIndex, 6) Like "" Then
Dokument = originalArray(originalRowIndex, 0)
Else
Dokument = originalArray(originalRowIndex, 6)
End If
'Zeile aus SocosArray wird nur in Excel eingetragen, wenn die Zeile nicht bereits in Excel vorhanden ist
'PS und CC werden immer eingetragen
Dim Eintragen As Boolean
Dim BereitsVorhanden As Boolean
Eintragen = True
'If Absender Like "C/AOO Regelungsdatenbank*" Then
If Absender Like "*SOCOS-C*;C/AOO*" Then
BereitsVorhanden = ExcelZeileBereitsVorhanden(originalArray, originalRowIndex, Dokument, Sachgebiet)
If BereitsVorhanden = True Then
Eintragen = False
End If
End If