mightygrave
Goto Top

VB Script - Textabschnitte aus Outlook Email kopieren und speichern als doc oder pdf

erstellung eines Scripts für outlook

Hallo, ich habe folgende Aufgabenstellung bekommen.

Es soll ein Script angefertigt werden welches ermöglicht, das in einer bekommenen Email, automatisch nach Textabschnitten zu suchen. Diese sollen dann entsprechend kopiert werden und in *.doc oder *.pdf.

Bsp für die Suche:

Von dem Wort Kaufbestätigung bis zum Zeilenende des nächsten Wortes welches gesucht wurde.

von Wort A: Kaufbestätigung bis zum ende der Zeile von Wort B: Herkunft

dawzsichen ist dann wieder ganz viel uninteressanter Text.

danach soll wieder von

Wort C: Käufer bis zum ende der Teile von Wort D: Geldinstitut.


Dies soll dann alles markiert und ein eine DOC oder PDF Datei eingefügt werden, sodass diese dann manuell gespeichert werden muss.


Ich hoffe Ihr könnt mir da ein paar Tipps geben.


Vielen Dank

Content-Key: 79434

Url: https://administrator.de/contentid/79434

Ausgedruckt am: 28.03.2024 um 11:03 Uhr

Mitglied: miniversum
miniversum 29.01.2008 um 16:00:44 Uhr
Goto Top
Hier mal der Code zum Auslesen bestimmter Teile im Inhaltstext einer Email.
Sub Textausschnitte()
WortA = "Wort A"  
WortB = "Wort B"  
WortC = "Wort C"  
WortD = "Wort D"  


Set myOlApp = CreateObject("Outlook.Application")  
Set myNameSpace = myOlApp.GetNamespace("MAPI")  
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox)

Text = myfolder.Items(1).Body
posA = InStr(1, Text, WortA)
posB = InStr(posA, Text, WortB)
ABText = Mid(Text, posA, posB - posA)

posC = InStr(posB, Text, WortC)
posD = InStr(posC, Text, WortD)
ABText = Mid(Text, posA, posB - posA)
CDText = Mid(Text, posC, posD - posC)

MsgBox "ABText: " & ABText  
MsgBox "CDText: " & CDText  

End Sub

miniversum
Mitglied: MightyGrave
MightyGrave 30.01.2008 um 10:59:02 Uhr
Goto Top
hi,

das hat mir geholfen, bin jetzt auch scho nso weit, dass ein Word document geöffnet ist.

Kannst du mir kurz erklären, was die Befehle die du dort hingeschrieben hast bewirken?

vielen Dank
Mitglied: MightyGrave
MightyGrave 30.01.2008 um 11:38:56 Uhr
Goto Top
ich muss nur noch wissen, wie ich dieses automatisch in die zwischenablage kriege und von da aus
in Word eingefüge.

posC = InStr(posB, Text, WortC)
posD = InStr(posC, Text, WortD)
ABText = Mid(Text, posA, posB - posA)
CDText = Mid(Text, posC, posD - posC)

MsgBox "" & ABText
MsgBox "" & CDText
Mitglied: miniversum
miniversum 30.01.2008 um 12:22:37 Uhr
Goto Top
Hier der Code nochmal mit Komantaren zur Erklärung
Sub Textausschnitte()
' Suchbegriffe festlegen  
WortA = "Wort A"  
WortB = "Wort B"  
WortC = "Wort C"  
WortD = "Wort D"  

' Zugriff auf Posteingang herstellen (myfolder -> Posteingang)  
Set myOlApp = CreateObject("Outlook.Application")  
Set myNameSpace = myOlApp.GetNamespace("MAPI")  
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox)

' Hole den Bodytext der ersten/obersten Email im Posteingang und schreibe ihn in die Variable Text  
Text = myfolder.Items(1).Body

posA = InStr(1, Text, WortA)  ' Suche die Position von WortA im Text und schreibe diese in posA  
posB = InStr(posA, Text, WortB)  ' Suche die Position von WortB nach WortA im Text und schreibe diese in posB  
ABText = Mid(Text, posA, posB - posA) ' Hole den Textteil zwischen posA und posB in Text und schreibe ihn in die Variable ABText  

posC = InStr(posB, Text, WortC)  ' Suche die Position von WortC nach WortB im Text und schreibe diese in posC  
posD = InStr(posC, Text, WortD) ' Suche die Position von WortD nach WortC im Text und schreibe diese in posD  
CDText = Mid(Text, posC, posD - posC) ' Hole den Textteil zwischen posC und posD in Text und schreibe ihn in die Variable CDText  

MsgBox "ABText: " & ABText ' Zeige ABText an  
MsgBox "CDText: " & CDText ' Zeige CDText an  

End Sub
miniversum
Mitglied: miniversum
miniversum 30.01.2008 um 12:32:21 Uhr
Goto Top
Es geht direkt, also ohne Zwischenablage.
Wie sieht den dein Code aus um Word zu öffnen?
Ich würde es in der Art machen:
Set objWordApp = CreateObject("Word.application") ' Starten von Word  

'Starten der Word-Instanz und eine neues Dokument öffnen  
objWordApp.Visible = True ' Word sichtbar machen  
Set objWordDok = objWordApp.documents.Add ' En neues Dokument in Word erstellen  

' Text in Word schreiben  
objWordApp.TypeText Text:="Daten aus Outlook"  
objWordApp.TypeParagraph ' Neue Zeile  
objWordApp.TypeText Text:="ABText: " & ABText ' Schreibe ABText in das Word Dokument  
objWordApp.TypeParagraph ' Neue Zeile  
objWordApp.TypeText Text:="CDText: " & CDText ' Schreibe CDText in das Word Dokument  
objWordApp.TypeParagraph ' Neue Zeile  

miniversum
Mitglied: MightyGrave
MightyGrave 30.01.2008 um 12:34:38 Uhr
Goto Top
Dim wApp As Object

Set wApp = CreateObject("Word.Application.8")

With wApp
' Word anzeigen
.Application.Visible = True
.Application.Activate

Set wApp = wApp.Documents.Add


End With

Set wApp = Nothing

End Sub


Eigentlich wollte ich mir das kopieren über range holen. Klappt aber nicht. Werde es mal mit deiner Methode probieren


Dim aktRange As Object

Set aktRange = wApp.ActiveDocument.Section(1)

aktRange.Collapse

aktRange.Insert "ABText"
Mitglied: MightyGrave
MightyGrave 30.01.2008 um 12:40:34 Uhr
Goto Top
Private Sub UserForm_Click()

WortA = "Kaufbestätigung"
WortB = "Modellgruppe:"
WortC = "Käufer:"
WortD = "Sie"

Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox)

Text = myfolder.Items(1).Body
posA = InStr(1, Text, WortA)
posB = InStr(posA, Text, WortB)
ABText = Mid(Text, posA, posB - posA)

posC = InStr(posB, Text, WortC)
posD = InStr(posC, Text, WortD)
ABText = Mid(Text, posA, posB - posA)
CDText = Mid(Text, posC, posD - posC)

MsgBox "" & ABText
MsgBox "" & CDText

' Word-Objekt Variable definieren

Dim wApp As Object

' Word-Objekt erzeugen
Set wApp = CreateObject("Word.Application.8")

With wApp
' Word anzeigen
.Application.Visible = True
.Application.Activate

Set wApp = wApp.Documents.Add

End With

Set wApp = Nothing

End Sub


Bekomme immer einen Laufzeitfehler 5. O_O

jetzt fehlt mir nur noch die umsetzung mit kopieren udn einfügen. dann bin ich fertig
Mitglied: miniversum
miniversum 30.01.2008 um 16:33:08 Uhr
Goto Top
Jetzt nochmal alles in einem. Da ist woll was unübersichtlich geworden. und ein selection hat gefehlt...:
Sub Textausschnitte()
' Suchbegriffe festlegen  
WortA = "Kaufbestätigung"  
WortB = "Modellgruppe:"  
WortC = "Käufer:"  
WortD = "Sie"  

' Zugriff auf Posteingang herstellen (myfolder -> Posteingang)  
Set myOlApp = CreateObject("Outlook.Application")  
Set myNameSpace = myOlApp.GetNamespace("MAPI")  
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox)

' Hole den Bodytext der ersten/obersten Email im Posteingang und schreibe ihn in die Variable Text  
Text = myfolder.Items(1).Body

posA = InStr(1, Text, WortA)  ' Suche die Position von WortA im Text und schreibe diese in posA  
posB = InStr(posA, Text, WortB)  ' Suche die Position von WortB nach WortA im Text und schreibe diese in posB  
ABText = Mid(Text, posA, posB - posA) ' Hole den Textteil zwischen posA und posB in Text und schreibe ihn in die Variable ABText  

posC = InStr(posB, Text, WortC)  ' Suche die Position von WortC nach WortB im Text und schreibe diese in posC  
posD = InStr(posC, Text, WortD) ' Suche die Position von WortD nach WortC im Text und schreibe diese in posD  
CDText = Mid(Text, posC, posD - posC) ' Hole den Textteil zwischen posC und posD in Text und schreibe ihn in die Variable CDText  

Set objWordApp = CreateObject("Word.application") ' Starten von Word  

'Starten der Word-Instanz und eine neues Dokument öffnen  
objWordApp.Visible = True ' Word sichtbar machen  
Set objWordDok = objWordApp.documents.Add ' Ein neues Dokument in Word erstellen  

' Text in Word schreiben  
objWordApp.Selection.TypeText Text:="Daten aus Outlook"  
objWordApp.Selection.TypeParagraph ' Neue Zeile  
objWordApp.Selection.TypeText Text:="ABText: " & ABText ' Schreibe ABText in das Word Dokument  
objWordApp.Selection.TypeParagraph ' Neue Zeile  
objWordApp.Selection.TypeText Text:="CDText: " & CDText ' Schreibe CDText in das Word Dokument  
objWordApp.Selection.TypeParagraph ' Neue Zeile  

' Zuordnungen löschen  
Set myOlApp = Nothing
Set objWordApp = Nothing

End Sub
So hab ichs grade bei mir getestet udn es funktioniert

miniversum
Mitglied: MightyGrave
MightyGrave 31.01.2008 um 08:23:52 Uhr
Goto Top
Vielen vielen Dank,

also den Rest werde ich dann noch selber ergänzen.

Also automatisches Drucken
Mitglied: MightyGrave
MightyGrave 31.01.2008 um 08:26:51 Uhr
Goto Top
Vielen vielen Dank,

es klappt wunderbar.

Die letzten 2 Sachen werde ich nochmal Versuchen.

1. automatischer ausdruck aus Word
2. einen anderen Ordner verwenden und nicht den Posteingang.


Bin mal gespannt.
Mitglied: mblochi
mblochi 12.03.2008 um 10:25:56 Uhr
Goto Top
halli hallo...,

ich hab da mal eine frage ...

Wie kann man dieses Script so umschreiben, dass er beim senden von E-Mails im header nach "Disposition-Notification-To" suchen soll und wenn er es dann gefunden hat soll er den Item.Subject in einer Text datei rein schreiben.

Hat evtl. jemand eine Idee dazu???

Danke schön schon mal im voraus face-smile