sms funktion
hejsa jer eksperten! jeg sidder og leger med en sms funktion der skulle kunne opdele en besked i flere email på 160 tegn: den vil dog ikke sende??jeg har vedlagt koden forneden:
----------------------------------------------------
<% Option Explicit
Response.Buffer = True
Sub TLdelaySec(DelaySeconds)
Dim SecCount, Sec2, Sec1
SecCount = 0
Sec2 = 0
While SecCount < DelaySeconds + 1
Sec1 = Second(Time())
If Sec1 <> Sec2 Then
Sec2 = Second(Time())
SecCount = SecCount + 1
End If
Wend
End Sub
Dim messageSend, returnMessage
messageSend = False
returnMessage = ""
If (Request("action") = "send") Then
Dim sender, receiver, message
sender = Trim(CStr(Request.Form("ediSender")))
receiver = Trim(CStr(Request.Form("ediReceiver")))
message = Trim(CStr(Request.Form("ediMessage")))
receiver = Replace(receiver, " ", "")
' message = Replace(message, "Æ", Chr(28))
' message = Replace(message, "æ", Chr(29))
' message = Replace(message, "Ø", Chr(11))
' message = Replace(message, "ø", Chr(12))
' message = Replace(message, "Å", Chr(14))
' message = Replace(message, "å", Chr(15))
If (NOT IsNumeric(receiver)) Then
receiver = 0
End If
receiver = Int(receiver)
' Dim sonofon, teledanmark, mobilix, fejl, selskab
Dim teledk, sonofon, telia, mobilix, tele1, telepartner, mfs, tele1020, rslcom, netsource, facilicom, telepassport
Dim fejl, selskab
' make sure this is a valid email address -- some SMTP servers does
' not allow sending emails if FROM: email is a non existing address
Const SERVEREMAIL = "anders@stein-graphic.dk"
' list of recognized telcos for sending out SMS
teledk = "sms.tdm.dk"
sonofon = "note.sonofon.dk"
telia = "gsm1800.telia.dk"
mobilix = "sms.mobilix.dk"
tele1 = "sms.mobilix.dk"
telepartner = "sms.mobilix.dk"
mfs = "sms.mobilix.dk"
tele1020 = "sms.mobilix.dk"
rslcom = "sms.mobilix.dk"
netsource = "sms.mobilix.dk"
facilicom = "sms.mobilix.dk"
telepassport = "sms.mobilix.dk"
fejl = "fejl"
Dim identifier, invalid
identifier = Int(Left(receiver, 4))
invalid = (identifier < 2010) OR (Len(receiver) < 8)
If ( (identifier >= 2010) AND (identifier <= 2059) ) Then
selskab = teledk
ElseIf ( (identifier >= 2060) AND (identifier <= 2099) ) Then
selskab = sonofon
ElseIf ( (identifier >= 2110) AND (identifier <= 2199) ) then
selskab = teledk
ElseIf ( (identifier >= 2210) AND (identifier <= 2299) ) then
selskab = sonofon
ElseIf ( (identifier >= 2310) AND (identifier <= 2399) ) Then
selskab = teledk
ElseIf ( (identifier >= 2610) AND (identifier <= 2699) ) Then
selskab = mobilix
ElseIf ( (identifier >= 2810) AND (identifier <= 2899) ) Then
selskab = telia
ElseIf ( (identifier >= 3010) AND (identifier <= 3689) ) Then
selskab = teledk
ElseIf ( (identifier >= 3690) AND (identifier <= 3309) ) Then
selskab = tele1
ElseIf ( (identifier >= 3810) AND (identifier <= 4049) ) Then
selskab = teledk
ElseIf ( (identifier >= 4050) AND (identifier <= 4099) ) Then
selskab = sonofon
ElseIf ( (identifier >= 4320) AND (identifier <= 4679) ) Then
selskab = teledk
ElseIf ( (identifier >= 4690) AND (identifier <= 4709) ) Then
selskab = tele1
ElseIf ( (identifier >= 4710) AND (identifier <= 6199) ) Then
selskab = teledk
ElseIf (identifier = 6910) Then
selskab = telepartner
ElseIf (identifier = 6911) Then
selskab = mfs
ElseIf (identifier = 6912) Then
selskab = tele1020
ElseIf ( (identifier >= 6960) AND (identifier <= 6964) ) Then
selskab = rslcom
ElseIf (identifier = 6966) Then
selskab = netsource
ElseIf (identifier = 6969) Then
selskab = netsource
ElseIf ( (identifier >= 6980) AND (identifier <= 6989) ) Then
selskab = facilicom
ElseIf (identifier = 6996) Then
selskab = telepassport
End If
If (NOT invalid) Then
' try to send message if a valid number were entered
Dim userAddress
userAddress = receiver & "@" & selskab
Dim Mailer
' patch sender to include some pre/post characters for nicer
' formatting when printing in message
If (Len(sender) > 0) Then
sender = "Fra " & sender & ":"
Else
sender = ""
End If
Dim formattedMessage, partMessage, sIdx
sIdx = 1
formattedMessage = ""
Dim cnt, wordCutPos
cnt = 0
Do
partMessage = Mid(message, sIdx, 140-Len(sender)-1)
' do some word cutting, finding a word to split up
' message nicely. We need to check for the end of
' this partial message thus we use InStrRev()
wordCutPos = InStrRev(partMessage, " ")
If ((wordCutPos > 0) AND (Len(message) > (sIdx+Len(partMessage)))) Then
' formattedMessage = formattedMessage & "<b>WORDBRE <font color=yellow>"&partMessage &"</font> AKFOUND</b>"
partMessage = Left(partMessage, wordCutPos)
' sIdx = sIdx + 1
End If
formattedMessage = formattedMessage & partMessage & "<p>"
' I need to create a new one every time in order to send
' multiple emails -- it's a bug in this object.
Set Mailer = Server.CreateObject("SMTPsvg.Mailer")
Mailer.CharSet = 2
Mailer.RemoteHost = "websmtp.stein-graphic.dk"
' Mailer.FromName = sender
Mailer.FromAddress = SERVEREMAIL
Mailer.AddRecipient userAddress, userAddress
Mailer.Subject = ""
Mailer.BodyText = sender & partMessage
If (Mailer.SendMail) Then
messageSend = True
Else
messageSend = False
End If
Mailer.ClearRecipients()
' TLdelaySec(3)
' next message
sIdx = sIdx + Len(partMessage)
cnt = cnt + 1
If (cnt > 10) Then
' do NOT send more than ten messages total
messageSend = False
End If
Set Mailer = Nothing
Loop While ( messageSend AND (Len(message) > sIdx) )
If (NOT messageSend) Then
returnMessage = Mailer.Response
' returnMessage = Mailer.RemoteHost & " | " & userAddress
End If
Set Mailer = Nothing
Else
messageSend = False
End If
Else
Response.Redirect "indexin.asp"
End If ' // > If (Request("action") = "send") Then
%>
