LoutScript 实现群发短信

LoutScript 实现群发短信

Sub Initialize
 
 On Error Goto errormsg
 Dim session As New notessession
 Dim cdoc As notesdocument
 Dim doc As notesdocument
 Dim view As notesview
 Dim db As notesdatabase
 Dim db_user As NotesDatabase
 Set db=session.currentdatabase
 Set cdoc=session.documentcontext
 Dim mdoc As NotesDocument
 cdocUnid = cdoc.UniversalID
 Set db_user = session.GetDatabase(db.Server,"sctel\lyuser.nsf")
 
 NotesMacro$ = |@AttachmentNames|
 attList = Evaluate(NotesMacro$,cdoc)
 attNames = ""
 For i = Lbound(attList) To Ubound(attList)
  If Trim(attList(i))<> "" Then
   If attNames = "" Then
    attNames = attList(i)
   Else
    attNames = attNames + "," + attList(i)
   End If
  End If
 Next
 Set view=db.getview("SMS_showFile")
 For i=0 To Ubound(cdoc.alldeptName)  
  If Len(Trim(cdoc.alldeptName(i)))>0 Then    
   key=cdocUnid+cdoc.alldeptName(i)
   Msgbox "key;"+key
   Set dc=view.getalldocumentsbykey(key,True)
   Msgbox "dc.count:"+Cstr(dc.count)
   If dc.count>0 Then
    Set doc=dc.getfirstdocument
   Else
    Set doc = New NotesDocument(db)
    Dim authorsItem As New NotesItem(doc, "Author",  _
    "admin", Readers)
    Dim readersItem As New NotesItem(doc, "yhuser",  _
    Trim(cdoc.alldeptName(i)), Authors)
   End If  
   doc.HYUNID=cdocUnid
   doc.SMS_Subject=cdoc.SMS_Subject(0)
   '根据人员取出部门，部门编号
   Set view_user = db_user.GetView("viewShowfileByUserName")
   Set doc_user = view_user.GetDocumentByKey(cdoc.alldeptName(i),True)
   If Not doc_user Is Nothing Then
    doc.TypeNum = doc_user.TypeNum(0)
    Set view_dept = db_user.GetView("viewDeptByNum")
    Set doc_dept = view_dept.getdocumentbykey(doc_user.TypeNum(0),True)
    If Not doc_dept Is Nothing Then
     doc.TypeName = doc_dept.Type(0)
     doc.deptNa = doc_dept.Type(0)
    End If
   End If
   Call doc.save(True,True)'存储    
   Dim SendTo(1) As String   
   SendTo(0) = cdoc.alldeptName(i)
   Call sendMessge(SendTo)
  End If   
 Next
 cdoc.htmls="消息已经发送！"
 'doc.SMS_riqi=Evaluate("@Created")  '重新创建时间
 Call cdoc.save(True,True)'存储 
 cdoc.htmls="<script>alert('发送成功！');</script>" 
 Exit Sub
errormsg:
 Msgbox "save Error:" & Str(Erl) & "  " & Error
 
End Sub


Sub sendMessge(SendTo As Variant)
 On Error  Goto processError 
 Dim session As New notessession
 Set db=session.currentdatabase
 Set cdoc=session.documentcontext
 Dim doc As NotesDocument
 Dim view As NotesView
 Dim UserDB As NotesDatabase
 Dim tel As String
 Dim content As String
 query = cdoc.Query_String_Decoded(0)
 Dim smsitem As NotesItem
 Set smsitem =cdoc.GetFirstItem("SMS_Body") 
 content="您好！请即时处理委机关办公系统中的《"+cdoc.foldername(0)+":"+smsitem.Text+"》文件，谢谢！["+cdoc.PUser(0)+"]"
 'Msgbox"短信内容:"+content
 Dim i,j As Integer
 i = 0
 Set UserDB = session.GetDatabase("","sctel/lyuser.nsf")
 Set view = UserDB.GetView( "cellPhoneByUser" )
 content=Replace(content,">","＞")
 content=Replace(content,"<","＜")
 Forall p In SendTo
  If p <> "" Then
   '获取处理人号码
   Set doc = view.GetDocumentByKey (p)
   If Not (doc Is Nothing) Then
    tel=doc.CellPhoneNumber(0)
    'Msgbox "tel--->"+tel
    If tel <> "" Then
     Msgbox "开始测试短信"
     Dim xmlhttp As Variant
     Dim data, URL  As String
     Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
     data = |<?xml version="1.0" encoding="utf-8"?>|
     data = data + |<soap:Envelope xmlns:xsi=" http://www.w3.org/2001/XMLSchema-instance" xmlns:xsd=" http://www.w3.org/2001/XMLSchema" xmlns:soap=" http://schemas.xmlsoap.org/soap/envelope/">|
     data = data + |<soap:Body>|
     data = data+|<sendMessageToNextPerson xmlns=" http://www.chinatelecom.com.cn/schema/ctcc/common/v2_1">|
     data = data +|<senderaddr>|+Trim(tel)+|</senderaddr>|
     data = data + |<content>|+content+|</content>|
     data = data + |</sendMessageToNextPerson>|
     data = data + |</soap:Body>|
     data = data +|</soap:Envelope>|
     URL=" http://localhost:82/sendSMS/gzwSendSM.asmx?op=sendMessageToNextPerson"
     xmlhttp.Open "POST",url, False
     xmlhttp.SetRequestHeader "Content-Type", "text/xml; charset=utf-8"
     xmlhttp.SetRequestHeader "Content-Length", "length"
     xmlhttp.SetRequestHeader "SOAPAction"," http://Ip:5080/isag/North/SMS/SendSms"
     xmlhttp.Send(data)
    Else     
     Msgbox "未找到号码"
    End If
   Else
    Messagebox "未找到号码"
   End If 
  End If
 End Forall
 
 Exit Sub
 
processError:
 Dim sTemp As String
 sTemp = "ini出错行:" + Cstr(Erl()) + " 出错信息:" + Error() +  " 请与管理员联系!"
 Print |<script>alert("|+sTemp+|")</script>|
 
 Exit Sub
 
End Sub