<%
Option Explicit
Response.Buffer = true
Session.LCID = 1031
%>
Kontakt
<%
Dim Schritt, Text, Name, Email, FehlerName, FehlerEmail, FehlerText, Adresse, PLZ, Ort, Tel, Fax
Dim FehlerOrt, FehlerAdresse, FehlerTel, FehlerPLZ, FehlerFax
Schritt = Request("Schritt")
Text = Request("Text")
Name = Request("Name")
Adresse = Request("Adresse")
PLZ = Request("PLZ")
Ort = Request("Ort")
Tel = Request("Tel")
Fax = Request("Fax")
Email = Request("Email")
Select Case Schritt
Case 2
Call Schritt2
Case 3
Call Schritt3
Case Else
Call Formular
End Select
%>
<%
Public Sub Formular()
%>
<%
End Sub
Public Sub Schritt2()
If NOT len(Name) > 0 Then
FehlerName = true
End if
If NOT PruefEmail(Email) Then
FehlerEmail = true
End if
If NOT len(Text) > 0 Then
FehlerText = true
End if
If FehlerName OR FehlerEmail OR FehlerText Then
Call Formular
else
Dim Sender, Subject, Body, Recipient
Sender = Email
'Empfänger: Wohin soll die Mail gesandt werden? Adresse noch angeben!
Recipient = "info@bdmag.de"
Subject="Kontakt vom " & Date() & " von " & Name & ", Email: " & Email
Body = "Beiliegend erhalten Sie Nachricht von:" & vbcrlf & name & vbcrlf
Body = Body & "Email-Adresse: " & Email & vbcrlf &vbcrlf
Body = Body & "Anschrift: " & vbcrlf & "___________________" & vbcrlf
Body = Body & Name & vbcrlf
Body = Body & Adresse & vbcrlf
Body = Body & PLZ & " " & ORT & vbcrlf
Body = Body & "T:" & Tel & vbcrlf
Body = Body & "F:" & Fax & vbcrlf & vbcrlf
Body = Body & "Text: " & vbcrlf & Text
Call SendEmail(Name, Sender, Subject, Body, Recipient)
End if
End Sub
Public Sub Schritt3() %>
Vielen Dank für Ihre Nachricht!
<%
End Sub
Public Function SendEmail(ByRef Name, ByRef Sender, ByRef Subject, ByRef Body, ByRef Recipient)
Dim strFrom, strTo, strSubject, strBody
Dim objMessage, objConfig
strFrom = Sender 'Absender
strTo = "info@bdmag.de" 'Empfänger
strSubject = Subject 'Mail Subject
strBody = Body 'Mail Body(Text)
'Erzeugen des Email Server Objects
Set objMessage = CreateObject("CDO.Message")
Set objConfig = CreateObject("CDO.Configuration")
'Hier wird festgelegt wie die Mails versendet werden (lokal oder extern)
'Bitte immer externen Versand angeben, da eine lokaler Versand nicht
'möglich ist.
objConfig.Fields(cdoSendUsingMethod) = cdoSendUsingPort
'Ausgehender SMTP Server mit SMTP-Auth
objConfig.Fields(cdoSMTPServer) = "smtp.1und1.com"
'SMTP Port
objConfig.Fields(cdoSMTPServerPort) = 25
'Klartext Authentifizierung
objConfig.Fields(cdoSMTPAuthenticate) = cdoBasic
'Accountname
objConfig.Fields(cdoSendUserName) = "m36368482-info"
objConfig.Fields(cdoSendPassword) = "bdm1013"
objConfig.Fields.Update
Set objMessage.Configuration = objConfig
objMessage.To = strTo
objMessage.From = strFrom
objMessage.Subject = strSubject
objMessage.TextBody = strBody 'Plain Text Modus
On Error Resume Next
objMessage.Send
If Err.Number = "0" Then
Response.Redirect("kontakt.asp?Schritt=3")
Else
Response.Write("Waehrend des Versendens ist ein Fehler aufgetreten.")
response.write Err.Number & " " & Err.Description
Err.Number = "0"
End If
End Function
Public Function PruefEmail(ByRef PruefAdresse)
Dim strDomains, arrDomains, i, Adresse
If len(PruefAdresse) > 0 Then
If instr(2,PruefAdresse,"@") > 0 Then
If instr(instr(1,PruefAdresse,"@") + 4,PruefAdresse, ".") > 0 then
Adresse=Right(PruefAdresse,len(PruefAdresse)-InstrRev(PruefAdresse,".",-1))
strDomains = "aero,ac,ad,ae,af,ag,ai,al,am,an,ao,aq,ar,arpa,as,at,au," & _
"aw,az,ba,bb,bd,be,bf,bg,bh,bi,biz,bj,bm,bn,bo,br,bs,bt,bv,bw,by,bz," & _
"ca,cc,cd,cf,cg,ch,ci,ck,cl,cm,cn,co,com,coop,cr,cu,cv,cx,cy,cz,de," & _
"dj,dk,dm,do,dz,ec,edu,ee,eg,eh,er,es,et,eu,fi,fj,fk,fm,fo,fr,ga,gd," & _
"ge,gf,gg,gh,gi,gl,gm,gn,gov,gp,gq,gr,gs,gt,gu,gw,gy,hk,hm,hn,hr,ht," & _
"hu,id,ie,il,im,in,info,io,iq,ir,is,it,je,jm,jo,jp,ke,kg,kh,ki,km,kn," & _
"kp,kr,kw,ky,kz,la,lb,lc,li,lk,lr,ls,lt,lu,lv,ly,ma,mc,md,mg,mh,mk," & _
"ml,mm,mn,mo,mp,mq,mr,ms,mt,mu,museum,mv,mw,mx,my,mz,na,name,nc,ne," & _
"net,nf,ng,ni,nl,no,np,nr,nu,nz,om,org,pa,pe,pf,pg,ph,pk,pl,pm,pn,pr," & _
"pro,ps,pt,pw,py,qa,re,ro,ru,rw,sa,sb,sc,sd,se,sg,sh,si,sj,sk,sl,sm," & _
"sn,so,sr,st,sv,sy,sz,tc,td,tf,tg,th,tj,tk,tm,tn,to,tp,tr,tt,tv,tw,tz," & _
"ua,ug,uk,um,us,uy,uz,va,vc,ve,vg,vi,vn,vu,wf,ws,ye,yt,yu,za,zm,zr,zw"
arrDomains = Split(strDomains,",")
For i = 0 to Ubound(arrDomains)
If arrDomains(i) = LCase(Adresse) Then
PruefEmail = true
Exit Function
End if
Next
End if
End if
end if
PruefEmail = false
End Function %>
