Softpicks.Net Deutsch

[Michael Bauer]

Hallo Gerhard,

> wie bekomm ich eigentlich die mailadresse von und den betreff aus
einer
> Email die steht bestimmt in einer Variable oder ?

der Betreff steht in "Subject". Die Adresse zeigt Dir OL nicht immer an,
sondern den angezeigten Namen. Ein Beispiel, um an die Adresse zu
kommen, habe ich in "Mailadresse des Absenders" hier schon gepostet.

Du musst dafür in Deinem Projekt einen Verweis auf Microsoft CDO 1.21
Library setzen. Da es sich dabei um eine optionale Komponente OLs
handelt, die standardmäßig nicht installiert wird, musst Du die
Bibliothek evt. vorher erst von Deiner OL/Office-CD installieren.

--
Viele Grüße
Michael Bauer

.

[Brandmeir Gerhard]

Hallo Michael

> der Betreff steht in "Subject". Die Adresse zeigt Dir OL nicht immer an,
> sondern den angezeigten Namen. Ein Beispiel, um an die Adresse zu
> kommen, habe ich in "Mailadresse des Absenders" hier schon gepostet.

Dim mpSession As MAPI.Session
Dim mpMsg As MAPI.Message
Dim mpAdrEntry As MAPI.AddressEntry
Dim olMail As Outlook.MailItem
Dim sAdr As String

Set olApp = CreateObject("Outlook.Application")
Set myNameSpace = olApp.GetNamespace("MAPI")
Set ol_Posteingang = myNameSpace.GetDefaultFolder(olFolderInbox)

Set mpSession = New MAPI.Session
mpSession.Logon , , False, False, , True

For Each Item In ol_Posteingang.Items
If TypeOf Item Is Outlook.MailItem Then
Set olMail = Item
sAdr = vbNullString

Select Case InStr(olMail.SenderName, " [at] ")
Case Is > 0
sAdr = olMail.SenderName

Case Else
Set mpMsg = mpSession.GetMessage(olMail.EntryID,
ol_Posteingang.StoreID)
If IsObject(mpMsg.Sender) Then
Set mpAdrEntry = mpMsg.Sender
If Not mpAdrEntry Is Nothing Then
sAdr = mpAdrEntry.Address
End If
End If
End Select
'
' If Len(sAdr) > 0 Then
'
' MsgBox sAdr
' End If
End If
Next

ok das Funktioniert einwandfrei soweit nur bei funktioniert das ja nur in
dem Posteingangs ordner ich habe aber für mein ganzes script

Set oFld = GetFolder("Persönliche Ordner\Posteingang")
If Not oFld Is Nothing Then
For Each obj In oFld.Items
If TypeOf obj Is Outlook.MailItem Then

das hier stehen wie kann ich das nun kombinieren damit mir die Von Adressen
in dem jeweiligen angegebenen ordner ausgelesen werden ?



Vielen Dank
Gruss Gerhard

Bald ists fertig "hächl hächl tropf schmatz !!!!"



.

[Michael Bauer]

Hallo Gerhard,

> ok das Funktioniert einwandfrei soweit nur bei funktioniert das ja nur
in
> dem Posteingangs

das ist jetzt nicht Dein Ernst, oder?

> Set ol_Posteingang = myNameSpace.GetDefaultFolder(olFolderInbox)

Wegen dieser Zeile arbeitet das Beispiel auf dem Posteingang und ...

> Set oFld = GetFolder("Persönliche Ordner\Posteingang")

.... dieses ist die Zeile in Deinem Code, um an den gewünschten Ordner zu
kommen.

Und nun rate bitte mal, welche Zeile bzw. Variable des Beispiels Du
ersetzen mußt!

--
Viele Grüße
Michael Bauer

.

[Brandmeir Gerhard]

Hallo

hier also mal der fertige VBA Code für Ebay und die Datenbank für Access mit
Edikettendruck

http://home.t-online.de/home/twister.1/EbayAdressen.mdb

Gruss Gerhard

und nochmal einen Riessssssieges Dankeschön an Michael Bauer


Private WithEvents Element As Office.CommandBarButton

Private Sub Application_Startup()
Dim SB As CommandBar
Set SB =
Application.ActiveExplorer.CommandBars.Add(Name:="EigenEbayLeiste",
Temporary:=True)
With SB
.Visible = True
.Position = msoBarBottom
End With
Set Element =
Application.ActiveExplorer.CommandBars("EigenEbayLeiste").Controls.Add(Type:=msoControlButton,
before:=1)
With Element
.Caption = "Ebay Daten Speichern Html"
.OnAction = "ebayfunktion"
End With
End Sub

Private Sub Element_Click(ByVal Ctrl As Office.CommandBarButton,
CancelDefault As Boolean)
LoopMailFolderByFolderPath_HTML
End Sub

Public Sub LoopMailFolderByFolderPath_HTML()
On Error GoTo ERR_HANDLER

Dim oFld As Outlook.MAPIFolder
Dim oFld1 As Outlook.MAPIFolder
Dim obj As Variant
Dim Teilstring As Variant
Dim TeilstringVon As Variant
Dim TeilstringName As Variant
Dim TeilstringStrasse As Variant
Dim TeilstringPostanschrift As Variant
Dim TeilstringLand As Variant
Dim TeilstringArtikelNummer As Variant
Dim TeilstringArtikelBEZ As Variant
Dim TeilstringArtikelBEZvergleich As Variant
Dim TeilstringArtikelBEZvergleich1 As Variant
Dim ArtikelNummerCount As Long
Dim Subjektvergleich1 As Variant
Dim Subjektvergleich2 As Variant
Dim Subjektvergleich3 As Variant
Dim Pos1 As Long
Dim Pos2 As Long
Dim mpSession As MAPI.Session
Dim mpMsg As MAPI.Message
Dim mpAdrEntry As MAPI.AddressEntry
Dim olMail As Outlook.MailItem
Dim sAdr As String

Subjektvergleich1 = "Bitte teilen Sie mir den Gesamtbetrag für "
Subjektvergleich2 = "Ich werde die Bezahlung für den "

Set oFld = GetFolder("Persönliche Ordner\Posteingang")
Set olApp = CreateObject("Outlook.Application")
Set myNameSpace = olApp.GetNamespace("MAPI")
Set mpSession = New MAPI.Session
mpSession.Logon , , False, False, , True

If Not oFld Is Nothing Then
For Each obj In oFld.Items
If TypeOf obj Is Outlook.MailItem Then

On Error Resume Next

Set olMail = obj
sAdr = vbNullString

Select Case InStr(olMail.SenderName, " [at] ")
Case Is > 0
sAdr = olMail.SenderName

Case Else
Set mpMsg = mpSession.GetMessage(olMail.EntryID, oFld.StoreID)
If IsObject(mpMsg.Sender) Then
Set mpAdrEntry = mpMsg.Sender
If Not mpAdrEntry Is Nothing Then
sAdr = mpAdrEntry.Address
End If
End If
End Select
Pos1 = 0
Pos2 = 0
treffer = 0
Teilstring = ""
TeilstringName = ""
TeilstringStrasse = ""
TeilstringPostanschrift = ""
TeilstringLand = ""
TeilstringVon = sAdr
TeilstringArtikel = ""
' ################ Ersatz VON ###########################
'For treffer = 1 To 1
' Pos1 = Pos1 + 1
' Pos1 = InStr(Pos1, obj.HTMLBody, "<B>Von:</B>", vbTextCompare)
'Next
'Teilstring = Mid$(obj.HTMLBody, Pos1)
'
''#########################################################
'Pos1 = 0
'Pos2 = 0
'For treffer = 1 To 1
' Pos1 = Pos1 + 1
' Pos1 = InStr(Pos1, Teilstring, "<B>Von:</B>", vbTextCompare)
'Next
'
'For treffer = 1 To 1
' Pos2 = Pos2 + 1
' Pos2 = InStr(Pos2, Teilstring, "<BR><B>Gesendet:</B>", vbTextCompare)
'Next
'Pos1 = Pos1 + 11
'Pos2 = Pos2 - Pos1
'TeilstringVon = Mid$(Teilstring, Pos1, Pos2)
''###########################################################
Teilstring = ""
For treffer = 1 To 1
Pos1 = Pos1 + 1
Pos1 = InStr(Pos1, obj.HTMLBody, "eBayISAPI.dll?ViewItem&item=",
vbTextCompare)
Next
Teilstring = Mid$(obj.HTMLBody, Pos1)

'#########################################################
Pos1 = 0
Pos2 = 0
For treffer = 1 To 1
Pos1 = Pos1 + 1
Pos1 = InStr(Pos1, Teilstring, "eBayISAPI.dll?ViewItem&item=",
vbTextCompare)
Next

Pos2 = InStr(Pos1, Teilstring, ">", vbTextCompare)
Pos1 = Pos1 + 32
Pos2 = Pos2 - Pos1 - 1
TeilstringArtikelNummer = Mid$(Teilstring, Pos1, Pos2)
'########################Ersatz Artikelbezeichnung##########################
'ArtikelNummerCount = Len(TeilstringArtikelNummer)
'Teilstring = ""
'For treffer = 1 To 1
' Pos1 = Pos1 + 1
' Pos1 = InStr(Pos1, obj.HTMLBody, "eBayISAPI.dll?ViewItem&item=" &
TeilstringArtikelNummer, vbTextCompare)
'Next
'Teilstring = Mid$(obj.HTMLBody, Pos1)
'
''#########################################################
'Pos1 = 0
'Pos2 = 0
'For treffer = 1 To 1
' Pos1 = Pos1 + 1
' Pos1 = InStr(Pos1, Teilstring, "eBayISAPI.dll?ViewItem&item=" &
TeilstringArtikelNummer, vbTextCompare)
'Next
'
' Pos2 = InStr(Pos1, Teilstring, "", vbTextCompare)
'Pos1 = Pos1 + ArtikelNummerCount + 34
'Pos2 = Pos2 - Pos1
'TeilstringArtikelBEZ = Mid$(Teilstring, Pos1, Pos2)
''###########################################################


Pos1 = 0
Pos2 = 0
Teilstring = ""
For treffer = 1 To 1
Pos1 = Pos1 + 1
Pos1 = InStr(Pos1, obj.HTMLBody, "folgende Adresse:", vbTextCompare)
Next
Teilstring = Mid$(obj.HTMLBody, Pos1)
'#########################################################
Pos1 = 0
Pos2 = 0
For treffer = 1 To 1
Pos1 = Pos1 + 1
Pos1 = InStr(Pos1, Teilstring, "<FONT", vbTextCompare)
Next

For treffer = 1 To 2
Pos2 = Pos2 + 1
Pos2 = InStr(Pos2, Teilstring, " Next

Pos1 = Pos1 + 35
Pos2 = Pos2 - Pos1
TeilstringName = Mid$(Teilstring, Pos1, Pos2)
'###########################################################
Pos1 = 0
Pos2 = 0
treffer = 0
For treffer = 1 To 2
Pos1 = Pos1 + 1
Pos1 = InStr(Pos1, Teilstring, "<FONT", vbTextCompare)
Next

For treffer = 1 To 3
Pos2 = Pos2 + 1
Pos2 = InStr(Pos2, Teilstring, " Next
Pos1 = Pos1 + 35
Pos2 = Pos2 - Pos1
TeilstringStrasse = Mid$(Teilstring, Pos1, Pos2)
'###########################################################
'###########################################################
Pos1 = 0
Pos2 = 0
treffer = 0
For treffer = 1 To 3
Pos1 = Pos1 + 1
Pos1 = InStr(Pos1, Teilstring, "<FONT", vbTextCompare)
Next

For treffer = 1 To 4
Pos2 = Pos2 + 1
Pos2 = InStr(Pos2, Teilstring, " Next
Pos1 = Pos1 + 35
Pos2 = Pos2 - Pos1
TeilstringPostanschrift = Mid$(Teilstring, Pos1, Pos2)
'###########################################################
'###########################################################
Pos1 = 0
Pos2 = 0
treffer = 0
For treffer = 1 To 4
Pos1 = Pos1 + 1
Pos1 = InStr(Pos1, Teilstring, "<FONT", vbTextCompare)
Next

For treffer = 1 To 5
Pos2 = Pos2 + 1
Pos2 = InStr(Pos2, Teilstring, " Next
Pos1 = Pos1 + 35
Pos2 = Pos2 - Pos1
TeilstringLand = Mid$(Teilstring, Pos1, Pos2)
'###########################################################
'###########################################################
Pos1 = 0
Pos2 = 0
treffer = 0
TeilstringArtikelBEZ = Replace(obj.Subject, " ", "")
TeilstringArtikelBEZ = Replace(TeilstringArtikelBEZ, vbCrLf, " ")
For treffer = 1 To 1
Pos1 = Pos1 + 1
Pos1 = InStr(Pos1, TeilstringArtikelBEZ, Subjektvergleich1,
vbTextCompare)
Next
Pos2 = Len(Subjektvergleich1)
Pos2 = Pos2 - Pos1 + 1
TeilstringArtikelBEZvergleich = Mid$(TeilstringArtikelBEZ, Pos1, Pos2)
'###########################################################
'###########################################################
Pos1 = 0
Pos2 = 0
treffer = 0
TeilstringArtikelBEZ = Replace(obj.Subject, " ", "")
TeilstringArtikelBEZ = Replace(TeilstringArtikelBEZ, vbCrLf, " ")
For treffer = 1 To 1
Pos1 = Pos1 + 1
Pos1 = InStr(Pos1, TeilstringArtikelBEZ, Subjektvergleich2,
vbTextCompare)
Next
Pos2 = Len(Subjektvergleich2)
Pos2 = Pos2 - Pos1 + 1
TeilstringArtikelBEZvergleich1 = Mid$(TeilstringArtikelBEZ, Pos1, Pos2)
'###########################################################

If Subjektvergleich2 = TeilstringArtikelBEZvergleich1 Then
TeilstringArtikelBEZ = Replace(TeilstringArtikelBEZ,
TeilstringArtikelBEZvergleich1, "")
ElseIf Subjektvergleich1 = TeilstringArtikelBEZvergleich Then
TeilstringArtikelBEZ = Replace(TeilstringArtikelBEZ,
TeilstringArtikelBEZvergleich, "")
End If

TeilstringVon = Replace(TeilstringVon, " ", "")

TeilstringName = Replace(TeilstringName, " ", "")
TeilstringName = Replace(TeilstringName, vbCrLf, " ")

TeilstringStrasse = Replace(TeilstringStrasse, " ", "")
TeilstringStrasse = Replace(TeilstringStrasse, vbCrLf, " ")

TeilstringPostanschrift = Replace(TeilstringPostanschrift, " ", "")
TeilstringPostanschrift = Replace(TeilstringPostanschrift, vbCrLf, " ")

TeilstringLand = Replace(TeilstringLand, " ", "")
TeilstringLand = Replace(TeilstringLand, vbCrLf, " ")

'
'MsgBox TeilstringVon
'MsgBox TeilstringArtikelBEZ
'MsgBox TeilstringName
'MsgBox TeilstringStrasse
'MsgBox TeilstringPostanschrift
'MsgBox TeilstringLand

'##############################################
Dim dbs As DAO.Database
Set dbs = OpenDatabase("C:\EbayAdressen.mdb")
dbs.Execute "INSERT INTO Adressen (Name, Strasse, Postanschrift,
Land, Von, ArtikelNr, ArtikelBEZ) VALUES ('" & TeilstringName & "', '" &
TeilstringStrasse & "', '" & TeilstringPostanschrift & "', '" &
TeilstringLand & "', '" & TeilstringVon & "', '" & TeilstringArtikelNummer &
"', '" & TeilstringArtikelBEZ & "');"
dbs.Close


End If
Next
End If



Set oFld1 = GetFolder("Persönliche Ordner\Erledigte Antworten")

If Not oFld1 Is Nothing Then
For Each obj In oFld.Items
If TypeOf obj Is Outlook.MailItem Then

obj.Move oFld1

End If
Next
End If

Exit Sub
ERR_HANDLER:
MsgBox Err.Description, vbExclamation
End Sub

'###################################################################################################################

Public Function GetFolder(strFolderPath As String) As Outlook.MAPIFolder
'
' Author: Sue Mosher
'
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim I As Long
On Error Resume Next

strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objNS = Application.Session
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For I = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(I))
If objFolder Is Nothing Then
Exit For
End If
Next
End If

Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
End Function


.