Stimmt schon...
aber ich finde es unsinnig, da noch eine Komp. selber zu erstellen; ausser
man macht ein totales Nobel-Teil.
MfG
Christian Thuer
PS: noch ein VB Modul (leider VBScript) zum versenden von E-Mails mit
Attachments...
quiet easy. (aber nat�rlich nicht 100% sicher...)
Den meisten code braucht der MiMe Base64; den habe ich aber geklaut.
Option Explicit
'Deklarationen von SMTP
Type WSADataType
wVersion As Integer
wHighVersion As Integer
szDescription As String * 257
szSystemStatus As String * 129
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End Type
Type HostEnt
h_name As Long
h_aliases As Long
h_addrtype As Integer
h_length As Integer
h_addr_list As Long
End Type
Type sockaddr
sin_family As Integer
sin_port As Integer
sin_addr As Long
sin_zero As String * 8
End Type
Public Declare Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (Dest As
Any, Src As Any, ByVal cb&)
Public Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVR As Long,
lpWSAD As WSADataType) As Long
Public Declare Function WSACleanup Lib "wsock32.dll" () As Long
Public Declare Function inet_addr Lib "wsock32.dll" (ByVal CP As String) As
Long
Public Declare Function htons Lib "wsock32.dll" (ByVal hostshort As Long) As
Integer
Public Declare Function gethostbyname Lib "wsock32.dll" (ByVal host_name As
String) As Long
Public Declare Function Socket Lib "wsock32.dll" Alias "socket" (ByVal af As
Long, ByVal s_type As Long, ByVal protocol As Long) As Long
Public Declare Function closesocket Lib "wsock32.dll" (ByVal S As Long) As
Long
Public Declare Function Connect Lib "wsock32.dll" Alias "connect" (ByVal S
As Long, addr As sockaddr, ByVal namelen As Long) As Long
Public Declare Function Send Lib "wsock32.dll" Alias "send" (ByVal S As
Long, buf As Any, ByVal buflen As Long, ByVal FLAGS As Long) As Long
Public Declare Function recv Lib "wsock32.dll" (ByVal S As Long, ByVal buf
As Any, ByVal buflen As Long, ByVal FLAGS As Long) As Long
'Ende Deklarationen von SMTP
' Deklaration von Radix 64
Private aDecTab(255) As Integer
Private Const sEncTab As String = _
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
' Ende Deklaration von Radix 64
Private Function GetHostByNameAlias(ByVal HostName$) As Long
'Return IP address as a long, in network byte order
Dim phe&
Dim heDestHost As HostEnt
Dim addrList&
Dim retIP&
retIP = inet_addr(HostName$)
If retIP = &HFFFF Then
phe = gethostbyname(HostName$)
If phe <> 0 Then
MemCopy heDestHost, ByVal phe, 16
MemCopy addrList, ByVal heDestHost.h_addr_list, 4
MemCopy retIP, ByVal addrList, heDestHost.h_length
Else
retIP = &HFFFF
End If
End If
GetHostByNameAlias = retIP
End Function
Private Function SendData(ByVal S&, vMessage As Variant) As Long
Dim TheMsg() As Byte, sTemp$
TheMsg = ""
Select Case VarType(vMessage)
Case 8209 'byte array
sTemp = vMessage
TheMsg = sTemp
Case 8 'string, if we recieve a string, its assumed we are linemode
sTemp = StrConv(vMessage, vbFromUnicode)
Case Else
sTemp = CStr(vMessage)
sTemp = StrConv(vMessage, vbFromUnicode)
End Select
TheMsg = sTemp
If UBound(TheMsg) > -1 Then
SendData = Send(S, TheMsg(0), UBound(TheMsg) + 1, 0)
End If
End Function
Public Function SendMail(SMTPServer As String, PortNummer As Integer,
SenderEmail As String, SenderName As String, EmpfaengerEmail As String,
EmpfaengerName As String, Subject As String, Nachricht As String, Optional
AttachmentFileArray As Variant, Optional AttachmentNameArray As Variant) As
Variant
'SendMail sendet Mail mit oder ohne Anhang an bestimmte Adresse
'Es braucht kein Outlock. Es braucht einen direkten Zugang auf einen SMTP
Server.
'Parameter:
'SMTPServer Name oder IP adresse vom SMTP-Server
'PortNummer Port auf welchem der SMTPServer l�uft (Normal 25)
'SenderEmail Absender E-Mailadresse
'SenderName Name des Absenders
'EmpfaengerEmail Empf�nger Emailadresse
'EmpfaengerName Name des Empf�ngers
'Subject Titel der Nachricht
'Nachricht Textmitteilung
'AttachmentFileArray Tabelle der Pfad und filename von Anh�ngen
' Dieser Parameter ist Optional
'AttachmentNameArray Tabelle der Namen der Anh�nge wie sie im Mail
ersichtlich sind
' Dieser Parameter ist Optional
' wenn dieser nicht angegeben wurde, dann wird der
Filename verwendet
'Returnwert: True kein Fehleraufgetreten, das Mail konnte an
Server �bermittelt werden
' Text Fehleraufgetreten keine �bermittlung
stattgefunden, Fehlertext
'Autor: Christian Th�r
'Erstelldatum: 09.01.2002
'�nderung: 10.01.2002 von Marcel Knill �berarbeitung der
Funktion
' __.__.____ von ___________
'***************************************************************************
******************************
'Test: SendMail("gfsc04", 25, "[EMAIL PROTECTED]", "Download Server",
"[EMAIL PROTECTED]", "Datenempf�nger", "Ihr Downloadauftrag",
"Attachmentversand stabil und sicher" + Chr(13) + Chr(10) + "Gruss Marcel",
"c:\badsimson.gif", "badsimson.gif")
'Test: SendMail("gfsc04", 25, "[EMAIL PROTECTED]", "Download Server",
"[EMAIL PROTECTED]", "Datenempf�nger", "Ihr Downloadauftrag",
"Attachmentversand stabil und sicher" + Chr(13) + Chr(10) + "Gruss Marcel",
Array("c:\marcel.txt"))
'Test: SendMail("gfsc04", 25, "[EMAIL PROTECTED]", "Download Server",
"[EMAIL PROTECTED]", "Datenempf�nger", "Ihr Downloadauftrag",
"Attachmentversand stabil und sicher" + Chr(13) + Chr(10) + "Gruss Marcel",
Array("c:\marcel.txt", "c:\marcel2.txt"), array("marcel.txt",
"marcel2.txt"))
'Test: SendMail("gfsc04", 25, "[EMAIL PROTECTED]", "Download Server",
"[EMAIL PROTECTED]", "Dtenempf�nger", "Ihr Downloadauftrag",
"Attachmentversand stabil und sicher" + Chr(13) + Chr(10) + "Gruss Marcel",
Array("c:\marcel3.txt"), array("marcel.txt"))
Dim wsadata As WSADataType
Dim destination_sin As sockaddr
Dim intSocket As Integer
Dim AttachBuffer As String
Dim FSO As Variant
Dim File As Variant
Dim Buff As String * 255
Dim Buffer As Integer
Dim i As Integer
If WSAStartup(&H101, wsadata) Then
SendMail = "Fehler: WinSock kann nicht gestartet werden"
Exit Function
End If
intSocket = Socket(2, 1, 0)
If intSocket < 0 Then
WSACleanup
SendMail = "Fehler: Kann Speicher f�r Socket nicht reservieren"
Exit Function
End If
destination_sin.sin_family = 2
destination_sin.sin_port = htons(PortNummer)
destination_sin.sin_addr = GetHostByNameAlias(SMTPServer)
If destination_sin.sin_port = -1 Then
closesocket (intSocket)
WSACleanup
SendMail = "Fehler: Falsche Portnummer <" & PortNummer & ">"
Exit Function
End If
If Not (Connect(intSocket, destination_sin, 16) = 0) Then
closesocket (intSocket)
WSACleanup
SendMail = "Fehler: Connect auf Server <" & SMTPServer & ">"
Exit Function
End If
'Hello
Buffer = SendData(intSocket, "HELO " & SMTPServer + Chr(13) + Chr(10))
Buffer = recv(intSocket, Buff, Len(Buff), 0)
'Sender
Buffer = SendData(intSocket, "mail from: " & SenderEmail + Chr(13) +
Chr(10))
Buffer = recv(intSocket, Buff, Len(Buff), 0)
'Empf�nger
Buffer = SendData(intSocket, "rcpt to: " & EmpfaengerEmail + Chr(13) +
Chr(10))
Buffer = recv(intSocket, Buff, Len(Buff), 0)
'Body
Buffer = SendData(intSocket, "data" + Chr(13) + Chr(10))
Buffer = recv(intSocket, Buff, Len(Buff), 0)
'Zuerst jedoch E-Mail Header
Buffer = SendData(intSocket, "From: " & SenderName & "<" & SenderEmail & ">"
+ Chr(13) + Chr(10))
Buffer = SendData(intSocket, "To: " & EmpfaengerName & "<" & EmpfaengerEmail
& ">" + Chr(13) + Chr(10))
Buffer = SendData(intSocket, "Reply-To: " & SenderName & "<" & SenderEmail &
">" + Chr(13) + Chr(10))
Buffer = SendData(intSocket, "Subject: " & Subject + Chr(13) + Chr(10))
Buffer = SendData(intSocket, "Date: " & Format(Now, "ddd, dd mmm yyyy
hh:mm:ss") & " +0100" + Chr(13) + Chr(10))
Buffer = SendData(intSocket, "MIME-Version: 1.0" + Chr(13) + Chr(10))
Buffer = SendData(intSocket, "Content-Type: multipart/mixed;" + Chr(13) +
Chr(10) + Chr(9) + "boundary=""----_=_NextPart_000_015D_32584_1245_XD""" +
Chr(13) + Chr(10))
Buffer = SendData(intSocket, Chr(13) + Chr(10))
'Mime Header
Buffer = SendData(intSocket, "This Message is in MIME Format. Since your
Mail reader doesn't understand this format, some or all of this messages may
not be legitime." + Chr(13) + Chr(10))
Buffer = SendData(intSocket, Chr(13) + Chr(10))
'Text Header
Buffer = SendData(intSocket, "------_=_NextPart_000_015D_32584_1245_XD" +
Chr(13) + Chr(10))
Buffer = SendData(intSocket, "Content-Type: text/plain;" + Chr(13) + Chr(10)
+ Chr(9) + "charset=""iso-8859-1""" + Chr(13) + Chr(10))
Buffer = SendData(intSocket, Chr(13) + Chr(10))
'Nun Kommt der Text
Buffer = SendData(intSocket, Nachricht)
'Hier kommt der Attachment Header
Buffer = SendData(intSocket, Chr(13) + Chr(10))
Buffer = SendData(intSocket, Chr(13) + Chr(10))
'Attachment verarbeiten
If Not IsMissing(AttachmentFileArray) Then
If IsMissing(AttachmentNameArray) Then
'AttachmentnameArray nicht vorhanden
ReDim AttachmentNameArray(LBound(AttachmentFileArray) To
UBound(AttachmentFileArray)) As String
For i = LBound(AttachmentFileArray) To UBound(AttachmentFileArray)
AttachmentNameArray(i) = Right(AttachmentFileArray(i),
Len(AttachmentFileArray(i)) - InStrRev(AttachmentFileArray(i), "\"))
Next i
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
'Attachment's verarbeitung
For i = LBound(AttachmentFileArray) To UBound(AttachmentFileArray)
On Error Resume Next
'Attachmentname nicht vorhanden
If IsNull(AttachmentNameArray(i)) Or AttachmentNameArray(i) = ""
Then
ReDim Preserve AttachmentNameArray(LBound(AttachmentFileArray)
To UBound(AttachmentFileArray))
AttachmentNameArray(i) = Right(AttachmentFileArray(i),
Len(AttachmentFileArray(i)) - InStrRev(AttachmentFileArray(i), "\"))
End If
On Error GoTo 0
'Reading the Attachment
On Error Resume Next
Set File = FSO.OpenTextFile(AttachmentFileArray(i), 1, False, 0)
If Err <> 0 Then
SendMail = "Fehler: AttachmendFile <" & AttachmentFileArray(i) &
"> nicht vorhanden"
Exit Function
End If
On Error GoTo 0
If Not File.AtEndOfStream Then
Buffer = SendData(intSocket,
"------_=_NextPart_000_015D_32584_1245_XD" + Chr(13) + Chr(10))
Buffer = SendData(intSocket, "Content-Type:
application/octet-stream;" + Chr(13) + Chr(10) + Chr(9) + "name=""" &
AttachmentNameArray(i) & """" + Chr(13) + Chr(10))
Buffer = SendData(intSocket, "Content-Transfer-Encoding: base64"
+ Chr(13) + Chr(10))
Buffer = SendData(intSocket, "Content-Disposition: attachment;"
+ Chr(13) + Chr(10) + Chr(9) + "filename=""" & AttachmentNameArray(i) & """"
+ Chr(13) + Chr(10))
'Hier kommt das Attachment
Buffer = SendData(intSocket, Chr(13) + Chr(10))
Do While Not File.AtEndOfStream
AttachBuffer = File.Read(60)
'Transforming and sending the Attachment
Buffer = SendData(intSocket, EncodeStr64(AttachBuffer))
Buffer = SendData(intSocket, Chr(13) + Chr(10))
Loop
Buffer = SendData(intSocket, Chr(13) + Chr(10))
End If
File.Close
Next i
Set FSO = Nothing
End If
'Mime End
Buffer = SendData(intSocket, "." + Chr(13) + Chr(10))
Buffer = recv(intSocket, Buff, Len(Buff), 0)
closesocket (intSocket)
WSACleanup
SendMail = True
End Function
Private Function EncodeStr64(sInput As String) As String
' Return radix64 encoding of string of binary values
' Does not insert CRLFs. Just returns one long string,
' so it's up to the user to add line breaks or other formatting.
' Version 2. Published 12 May 2001 with improved SHR/SHL functions.
' with thanks to Doug J Ward.
' Version 1. Published 28 December 2000
'************************COPYRIGHT NOTICE*************************
' Copyright (C) 2000-1 DI Management Services Pty Ltd,
' Sydney Australia <www.di-mgt.com.au>. All rights reserved.
' This code was originally written in Visual Basic by David Ireland.
' You are free to use this code in your applications without liability
' or compensation, but the courtesy of both notification of use and
' inclusion of due credit are requested. You must keep this copyright
' notice intact.
' It is PROHIBITED to distribute or reproduce this code for profit
' or otherwise, on any web site, ftp server or BBS, or by any
' other means, including CD-ROM or other physical media, without the
' EXPRESS WRITTEN PERMISSION of the author.
' Use at your own risk.
' David Ireland and DI Management Services Pty Limited
' offer no warranty of its fitness for any purpose whatsoever,
' and accept no liability whatsoever for any loss or damage
' incurred by its use.
' If you use it, or found it useful, or can suggest an improvement
' please let us know at <[EMAIL PROTECTED]>.
' Credit where credit is due:
' Some parts of this VB code are based on original C code
' by Carl M. Ellison. See "cod64.c" published 1995.
'*****************************************************************
Dim sOutput As String, sLast As String
Dim b(2) As Byte
Dim j As Integer
Dim i As Long, nLen As Long, nQuants As Long
nLen = Len(sInput)
nQuants = nLen \ 3
sOutput = ""
' Now start reading in 3 bytes at a time
For i = 0 To nQuants - 1
For j = 0 To 2
b(j) = Asc(Mid(sInput, (i * 3) + j + 1, 1))
Next
sOutput = sOutput & EncodeQuantum(b)
Next
' Cope with odd bytes
Select Case nLen Mod 3
Case 0
sLast = ""
Case 1
b(0) = Asc(Mid(sInput, nLen, 1))
b(1) = 0
b(2) = 0
sLast = EncodeQuantum(b)
' Replace last 2 with =
sLast = Left(sLast, 2) & "=="
Case 2
b(0) = Asc(Mid(sInput, nLen - 1, 1))
b(1) = Asc(Mid(sInput, nLen, 1))
b(2) = 0
sLast = EncodeQuantum(b)
' Replace last with =
sLast = Left(sLast, 3) & "="
End Select
EncodeStr64 = sOutput & sLast
End Function
Private Function EncodeQuantum(b() As Byte) As String
'Teilfunktion von radix64
Dim sOutput As String
Dim c As Integer
sOutput = ""
c = SHR(b(0), 2) And &H3F
sOutput = sOutput & Mid(sEncTab, c + 1, 1)
c = SHL(b(0) And &H3, 4) Or (SHR(b(1), 4) And &HF)
sOutput = sOutput & Mid(sEncTab, c + 1, 1)
c = SHL(b(1) And &HF, 2) Or (SHR(b(2), 6) And &H3)
sOutput = sOutput & Mid(sEncTab, c + 1, 1)
c = b(2) And &H3F
sOutput = sOutput & Mid(sEncTab, c + 1, 1)
EncodeQuantum = sOutput
End Function
Private Function SHL(ByVal bytValue As Byte, intShift As Integer) As Byte
'Teilfunktion von radix64
' Version 2: ShiftLeft and ShiftRight functions improved.
' Thanks to Doug J Ward for these functions.
' Identical functions are also used as public functions in basByteUtils
If intShift > 0 And intShift < 8 Then
SHL = bytValue * (2 ^ intShift) Mod 256
ElseIf intShift = 0 Then
SHL = bytValue
Else
SHL = 0
End If
End Function
Private Function SHR(ByVal bytValue As Byte, intShift As Integer) As Byte
'Teilfunktion von radix64
If intShift > 0 And intShift < 8 Then
SHR = bytValue \ (2 ^ intShift)
ElseIf intShift = 0 Then
SHR = bytValue
Else
SHR = 0
End If
End Function
-----Original Message-----
From: Claudius Ceteras [mailto:[EMAIL PROTECTED]]
Sent: Mittwoch, 13. Februar 2002 16:06
To: ASP Datenbankprogrammierung
Subject: [aspdedatabase] RE: AW: RE: AW: RE: News - Danke
>
> SMTP... ist total easy...
Also ich stehe immer noch zu meiner Aussage, dass das alles nicht so
trivial ist und man lieber nicht das Rad neu erfinden soll...
Ich w�rde wenn ich SMTP, POP3 und HTTP ben�tigen w�rde, immer lieber
drei Komponenten installieren, als eine Socket-Komponente....
Das man viele Fehler machen kann sieht man schon daran, dass Du z.B.
vergessen hast zu sagen, was man machen soll, wenn in der Mail eine
Zeile vorkommt, in der sich nur ein Punkt befindet...
Und was machst Du, wenn nach der "rcpt to:"-Zeile kein OK vom server
zur�ckkommt, sondern eine Fehlermeldung? Alles Gr�nde wieso ich SMTP
nicht selber implementieren w�rde... ist halt doch nicht so einfach,
wenn man es richtig machen will...
Und Attachments sind noch unangenehmer... wer will schon MIME-Mails zu
Fuss generieren.. nein, Danke...
Sockets-Komponenten w�rde ich nur f�r nicht standardsierte Protokolle,
oder aber f�r Protokolle, f�r die es noch keine Komponenten gibt
benutzen...
Claudius
>
> Connection zu SMTP...
> Commands zum senden:
>
> 'Hallo Sagen
> HELO MeinName oder MeineDomain
> mail from: [EMAIL PROTECTED]
> rcpt to: [EMAIL PROTECTED]
> data
> 'Zuerst der Mail Header (kann in jeder MSG Datei bewundert werden)
> mail from: Christian Thuer <[EMAIL PROTECTED]>
> reply-to: Du <[EMAIL PROTECTED]>
> subject: testmail
>
> 'Nach 2 CRLF beginnt der Body
> Gugus du, dies ist ein Testmail
>
> Gruss
>
> Christian Thuer
>
> .
> 'ein . auf einer einzelnen Linie schliesst das mail ab.
>
> Dies ist die Grundstrucktur... auch attachments lassen sich relativ
> schnell
> und einfach realisieren.
>
> MfG
>
> Christian Thuer
>
| [aspdedatabase] als [EMAIL PROTECTED] subscribed
| http://www.aspgerman.com/archiv/aspdedatabase/ = Listenarchiv
| Sie k�nnen sich unter folgender URL an- und abmelden:
| http://www.aspgerman.com/aspgerman/listen/anmelden/aspdedatabase.asp
| [aspdedatabase] als [email protected] subscribed
| http://www.aspgerman.com/archiv/aspdedatabase/ = Listenarchiv
| Sie k�nnen sich unter folgender URL an- und abmelden:
| http://www.aspgerman.com/aspgerman/listen/anmelden/aspdedatabase.asp
