关于用Notes做群发工具的例子

shenboo

去年我做了一个公司工资的群发工具.  现在贴出来，请指教。
用法如下：
1。在系统中建立一个数据源， 具体就不说了。 我把它起名叫Salary,(我是用EXCEL建的，你们可以用其它任何东西）
2。建立一Notes数据库，（可以用现有的）建立一个Agent. 并贴入下面内容。

Option Public
Uselsx "*LSXODBC"


'根据ODBC数据库(ODBC_DATA)里UserName_Col所在列发送M_mail(把ODBC_DATA_TABLE里每条记录发给UserName_COL所在列中显示的用户名)
Public Const ODBC_DATA="sal"                                '声名ODBC数据库的名称
Public Const ODBC_DATA_TABLE="Salary"                '声名数据库中所要调用的TABLE名
Dim FieldStr() As String  
Dim columns As Integer

Dim First_Say As String                         '发送前加入的文字               
Dim Title_Say As String                         '发送标题


Const SendTo_Col =1                                '声明所要发送的人名在那一行
Const SendYN_Col=2                                        '声明判断是否发送的列所在行， 如果为-1代表最右侧行。0代表无此判断
Const UserName_Col=3                                '发送人的人名所在列
Const Sendfrom_Col=4                                '从那一列开始发送数据

'－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
'把fromstr()数组及fieldstr()中的数据分别发送到每个用户











Sub Initialize
        Dim con As New ODBCConnection
        Dim qry As New ODBCQuery
        Dim result As New ODBCResultSet
       
        Dim DateRange As String
        Dim DataStr() As String
       
       
       
        If con.connectto(ODBC_DATA) Then
                Set qry.Connection =con
                qry.sql="Select * from " & odbc_Data_Table
                Set result.Query=qry
                If Not result.Execute() Then
                        Messagebox "Error:  " & _
                        result.GetErrorMessage(DB_LASTERROR)                       
                End If
                columns=result.NumColumns                        '得到列数
               
                Redim Fieldstr(columns+1) As String                '定义要发送标题所在动态数组
                Redim DataStr(columns+1) As String                 '定义要发送数据所在动态数组
               
                For K=1 To columns                  '确定第一行,即标题所在行内容.并保存在数组中
                        fieldstr(k)= result.FieldName(k)
                Next
                Call result.nextrow()
                Dim j As Integer  '用于统计共发送给了几个人
                j=0
                '读取循环记录直到要发送的用户地址为空。
                Dim nowT As Integer
                If Day(Now())>15 Then
                        nowT=Month(Now())
                Else
                        nowT=(Month(Now())-1)
                        If nowT<1 Then nowT=12
                End If
               
                Title_Say=Inputbox(Chr(13)&"请输入要发送给每位用户的标题信息？"& Chr(13) & " ","标题",nowT & "月工资单明细")
               
                First_Say=Inputbox(Chr(13)& "请输入要发送的数据前需要加入的说明文本。" & Chr(13) & Chr(13)& "如果有多段文字请将各段用\将段落进行分隔" & Chr(13),"发送前","")
               
                First_say=ReplaceStr(First_Say)
               
                While  Not(Result.IsEndOfData Or result.GetValue(SendTo_Col)="")
                       
                &#39;        Datastr(0)=result.Getvalue(SendTo_Col)        &#39;保存要发送的人的邮件地址.
                       
                        For k = 1 To columns                               
                                DataStr(k)=result.GetValue(k)                &#39;得到要发送数据行每一列的值并存放在数组中。
                        Next
                       
                        Call result.nextrow()                                &#39;下一数据行
                       
                        Dim SendYN As Boolean
                        If SendYN_Col =-1 Then
                                SendYN=Cbool(datastr(columns))        &#39;判断是否为最后一列
                        Else
                                sendYN=Cbool(datastr(SendYN_Col))                &#39;得到所在列数值
                        End If
                        If SendYN Or SendYN_Col=0 Then                &#39;如果SendYN为False，或者SendYN_Col(是否发送行为0）就停止发送此行信息
                                Call        SendtoEveryOne(Datastr)  &#39;把信息发给每位用户
                                j=j+1                               
                        End If
                Wend               
                Msgbox "发送已经完成,共向" & j & "位用户发送了信息，请通知用户查收."
        Else
                Messagebox("Could not connect to Server")
               
        End If
       
End Sub















Function ReplaceStr (Strs As String) As String
       
        Dim i As Integer
        Dim tmp As String
        Dim Chrs As String
        tmp=""
        For i =1 To Len(Strs)
                Chrs= Mid(Strs,i,1)
                If Chrs="\" Then
                        tmp=tmp & Chr(13)
                Else
                        tmp=tmp & Chrs
                End If
        Next
        ReplaceStr=tmp
End Function







Sub SendtoEveryOne(fromstr() As String)
       
        Dim tmpTitle As String                                &#39;标题字段所在字符串
        Dim tmpData As String                                &#39;数据所组成的字符串
        Dim tmpStr As String                                 &#39;整个字符串
       
        Dim tmp1 As String  
        Dim tmp2 As String
       
        Dim FirRow As String                                         &#39;第一段要显示内容
       
        Const Spc_Num  = 16                                                &#39;横行空余位置
        Const List_Rows  =3                                                &#39;每行几列
       
       
        Dim i As Integer
        Dim Row_Code As String
        Dim Col_Code As String
       
        Col_Code=Chr(9) & Chr(9)                                                                             &#39;字段间横向分隔符
        Row_Code=""                                                                                                 &#39;各段落之间用何分隔
       
        Dim lin As String        
        lin  =String(100,"_")& Chr(13)                                                                &#39;分隔线
       
       
        FirRow=fromstr(UserName_Col) & "&#39;s Salary:"                                                                &#39;首行显示某人的工资。
       
        For i=Sendfrom_Col To columns
                If SendYN_Col<>i Then                                        &#39;如果发送行中包括判断是否发送行，则将它过滤掉。
                       
                        tmp1= Ucase(Trim(fieldstr(i)))                &#39;列出标题
                        tmp2= Trim(fromstr(i))                                &#39;数据
                        tmpTitle=tmpTitle & Col_Code & tmp1 &        String(Spc_Num-Len(tmp1), " ")
                        tmpData =tmpData & Col_Code  & tmp2 &        String(Spc_Num-Len(tmp2), " ")
                       
                        If (i-Sendform_Col) Mod List_Rows=0 Then                                                                         &#39;如果超过指定行就自动分段
                               
                                tmpStr=tmpStr & Chr(13) & Row_Code & Chr(13) & tmpTitle & Chr(13) & tmpData  &#39;组成一个新段落
                                tmpTitle=""
                                tmpData=""
                        End If
                End If
        Next
       
       
       
        tmpStr=First_Say & Chr(13) & lin & Chr(13) & FirRow & Chr(13) & lin & Chr(13) & tmpStr & Chr(13) & Row_Code & Chr(13)  & tmpTitle & Chr(13) & tmpData                         &#39;当数据在最后位置时(未满一段）
       
        Dim Session As New NotesSession
        Dim db As NotesDatabase
        Dim doc As notesDocument
       
        Set db =Session.CurrentDatabase
        Set doc=New NotesDocument(db)
       
        Call doc.AppendItemValue("Subject",Title_Say)
        Call doc.AppendItemValue("Body",tmpStr)
        Call doc.appendItemvalue("IsSigned",True)
        Call doc.AppendItemValue("SendTo",fromstr(1))
        &#39;doc.EncryptOnSend =True
        Call doc.Send(False,fromstr(1))
        &#39;Msgbox fromstr(1)
        &#39;Messagebox("Row: " & fromstr(0) & Chr(13) & tmpStr)       
       
End Sub


现在大家都用6。5的Notes了， 我还在用老的， 所以发出去的内容都是用文本填充的。 不过大家可以看看指导指导。