📄 mainform.frm

📁 中日邮件短信网关
💻 FRM
📖 第 1 页 / 共 4 页
字号:
               RS.Close
       End If
      
    End If
 adoPrimaryRS.MoveNext
 Next
 adoPrimaryRS.Update
 adoPrimaryRS.Close
  
 
End If


OnError:
   If BadStatusMessage <> "" Then
      StatusBar.Panels(1).Text = "ERROR:邮件处理错误 "
      Label5.Caption = BadStatusMessage
       Z = App.Path & "\web\errorlog.txt"
       Open Z For Append As #2
       Print #2, "邮件处理错误:" & Now() & BadStatusMessage
        Close #2
       BadStatusMessage = ""
    Resume Next
    End If



End Sub

' _________________________________________________________________________________
'|
'|
'|                                   短信发送进程ok 2005-11-24
'|
'|
'|_________________________________________________________________________________
'
Private Sub SMS_Sent()

On Error GoTo OnError
Dim Smsok
Dim resultmsg
Dim backAccount As String
Dim backPrice As Integer
Dim Acces As String

sql = "select * from Turnover where action_lable like '0'"
RS.Open sql, db, adOpenStatic, adLockOptimistic
If RS.RecordCount > 0 Then


   StatusBar.Panels(1).Text = "Sending SMS ... "
   '以中文文本格式发送短信
 For i = 1 To RS.RecordCount
     If Left(RS.Fields("tomb").Value, 3) = "130" Or Left(RS.Fields("tomb").Value, 3) = "131" Or Left(RS.Fields("tomb").Value, 3) = "132" Or Left(RS.Fields("tomb").Value, 3) = "133" Then
     '使用联通通道发送短信
     
          Smsok = alasunsms1.SendMsg(RS.Fields("tomb").Value, RS.Fields("Mail_text").Value, , 0)
     
     Else
    '使用移动通道发送短信
         Acces = Right(RS.Fields("turnover_id").Value, 3)
         
         resultmsg = Inet1.OpenURL("http://211.136.104.4:9080/httpserver?enterpriseid=00541&accountid=" & Acces & "&pswd=P37652&mobs=" & RS.Fields("tomb").Value & "&msg=" & RS.Fields("Mail_text").Value)
         
         If Left(resultmsg, 3) = "100" Then
         Smsok = 0
         Else
         Smsok = 1
         End If
 
     End If
     
    '处理返回的结果---------------------------------------------------------------------
   
    If Smsok = 0 Then
    
    
    
        '发送成功，则把流水表的帐务状态改为1

         RS.Fields("Action_lable").Value = "1"
         RS.Fields("Action_date").Value = str(Now())
         RS.Update

    Else
        '发送no成功，则把流水表的帐务状态改为2，
         RS.Fields("Action_lable").Value = "2"
         backAccount = RS.Fields("Account_id").Value
         backPrice = Val(RS.Fields("turnover_amount").Value)
         RS.Fields("Action_date").Value = str(Now())
         RS.Update
         '同时返回流水金额到帐号表
         sql = "select * from Account where Account_id like '" & backAccount & "'"
         adoPrimaryRS.Open sql, db, adOpenStatic, adLockOptimistic
         adoPrimaryRS.Fields("Amount").Value = adoPrimaryRS.Fields("Amount").Value + backPrice
         adoPrimaryRS.Update
         adoPrimaryRS.Close
    End If

RS.MoveNext
Next

End If
RS.Close

OnError:
   If BadStatusMessage <> "" Then
      StatusBar.Panels(1).Text = "ERROR:短信发送错误 "
      Label5.Caption = BadStatusMessage
       Z = App.Path & "\web\errorlog.txt"
       Open Z For Append As #2
       Print #2, "短信发送错误:" & Now() & BadStatusMessage
        Close #2
       BadStatusMessage = ""
       Resume Next
    
    End If

End Sub

' _________________________________________________________________________________
'|
'|
'|                                   短信接收进程
'|
'|
'|_________________________________________________________________________________


Private Sub SMS_in()
Dim resultmsg As String
On Error GoTo OnError
    
 '联通通道短信接收======================================================================================
    
    '短信接受，在流水表中提取最后一次发送号码并把邮件地址作为邮件发送地址，过程不涉及帐务
    
    Dim sNo As String, sCon As String, sMsgCenterNo As String
    Dim dSendTime As Date, lTimeZone As Integer
    '一次接受20条短信
    For i = 1 To 10
        If alasunsms1.ReadMsgByIndex(1, sNo, sCon, sMsgCenterNo, dSendTime, lTimeZone) = 0 Then
        Label26.Caption = Val(Label26.Caption) + 1
           'sNo        来源号码
           'dSendTime  发送时间
           'sCon       短信内容
         '从流水表中找出最近时间的邮件地址
         sql = "select * from Turnover where ToMB like '" & sNo & "' order by turnover_id desc "
         adoPrimaryRS.Open sql, db, adOpenStatic, adLockOptimistic
         If Not adoPrimaryRS.RecordCount = 0 Then
         Label27.Caption = Val(Label27.Caption) + 1
         '写入邮件发送队列
         
                sql = "select * from Mailout"
                RS.Open sql, db, adOpenStatic, adLockOptimistic
                RS.AddNew
                RS.Fields("mailto").Value = adoPrimaryRS.Fields("Account_id").Value         '目标地址，取自邮件队列的发信地址
                RS.Fields("mailfrom").Value = sNo & "@jptocn.net"   '发信地址
                RS.Fields("subject").Value = "From " & sNo & "@jptocn.net"          '主题
                RS.Fields("mailtext").Value = sCon
                RS.Fields("actlabel").Value = "0"
                RS.Fields("addtime").Value = str(Now())
                RS.Update
                RS.Close
           
           End If
          '没有此次流水，不予处理
        Else
          
        
        End If
    Next
    
'电信通道短信接收======================================================================================
    
  resultmsg = Inet1.OpenURL("http://211.136.104.4:9080/query/deliver.jsp?eid=00541&pswd=P37652&urlencoding=off&comment=off")
  
If Len(resultmsg) > 10 Then
resultmsg = Mid(resultmsg, InStr(1, resultmsg, Chr(10)) + 1) '去除前面的100
Do While Len(resultmsg) > 2



Acces = Mid(resultmsg, 1, (InStr(1, resultmsg, ",") - 1))
     resultmsg = Mid(resultmsg, (InStr(1, resultmsg, ",") + 1))
tomb = Mid(resultmsg, 1, (InStr(1, resultmsg, ",") - 1))
     resultmsg = Mid(resultmsg, (InStr(1, resultmsg, ",") + 1))
sdate = Mid(resultmsg, 1, (InStr(1, resultmsg, ",") - 1))
     resultmsg = Mid(resultmsg, (InStr(1, resultmsg, ",") + 1))
msmsg = Mid(resultmsg, 1, (InStr(1, resultmsg, Chr(10)) - 1))
     resultmsg = Mid(resultmsg, (InStr(1, resultmsg, Chr(10)) + 1))
           
Debug.Print Acces
Debug.Print tomb
Debug.Print sdate
Debug.Print msmsg
'写入邮件发送数据库
         sql = "select * from Turnover where ToMB like '" & tomb & "' order by turnover_id desc "
         adoPrimaryRS.Open sql, db, adOpenStatic, adLockOptimistic
         If Not adoPrimaryRS.RecordCount = 0 Then
         
           If adoPrimaryRS.RecordCount > 1 Then
            Do While Not adoPrimaryRS.EOF
               If Right(adoPrimaryRS.Fields("turnover_id").Value, 3) = Acces Then
                sql = "select * from Mailout"
                RS.Open sql, db, adOpenStatic, adLockOptimistic
                RS.AddNew
                RS.Fields("mailto").Value = adoPrimaryRS.Fields("Account_id").Value         '目标地址，取自邮件队列的发信地址
                RS.Fields("mailfrom").Value = tomb & "@jptocn.net"   '发信地址
                RS.Fields("subject").Value = "From " & tomb & "@jptocn.net"          '主题
                RS.Fields("mailtext").Value = msmsg
                RS.Fields("actlabel").Value = "0"
                RS.Fields("addtime").Value = str(Now())
                RS.Update
                RS.Close
           
           
           
           
                   Exit Do
               End If
             adoPrimaryRS.MoveNext
            Loop
           
           Else
         '写入邮件发送队列
         
                sql = "select * from Mailout"
                RS.Open sql, db, adOpenStatic, adLockOptimistic
                RS.AddNew
                RS.Fields("mailto").Value = adoPrimaryRS.Fields("Account_id").Value         '目标地址，取自邮件队列的发信地址
                RS.Fields("mailfrom").Value = sNo & "@jptocn.net"   '发信地址
                RS.Fields("subject").Value = "From " & sNo & "@jptocn.net"          '主题
                RS.Fields("mailtext").Value = sCon
                RS.Fields("actlabel").Value = "0"
                RS.Fields("addtime").Value = str(Now())
                RS.Update
                RS.Close
           End If
           End If
          '没有此次流水，不予处理
         adoPrimaryRS.Close
           
Loop
           
           

           
End If

   
    
    
OnError:
   If BadStatusMessage <> "" Then
      StatusBar.Panels(1).Text = "ERROR:短信接收错误 "
      Label5.Caption = BadStatusMessage
       Z = App.Path & "\web\errorlog.txt"
       Open Z For Append As #2
       Print #2, "短信接收错误:" & Now() & BadStatusMessage
        Close #2
       BadStatusMessage = ""
    Resume Next
    End If
    
    
End Sub





' _________________________________________________________________________________
'|
'|
'|                              邮件发送进程--ok2005-11-24
'|
'|
'|_________________________________________________________________________________
'
Private Sub Mail_sent()
On Error GoTo OnError

sql = "select * from Mailout where actlabel like '0'"
RS.Open sql, db, adOpenStatic, adLockOptimistic


If RS.RecordCount > 0 Then


StatusBar.Panels(1).Text = "Sending Mail ... "
Smtp1.Abort
DSN = dsnNever
Smtp1.Login Smtpserver, 25, Smtpname, Smtppassword
Smtp1.Timeout = 10000
Smtp1.DSN DSN

For i = 1 To RS.RecordCount
  Label25.Caption = Val(Label25.Caption) + 1

  Smtp1.Capabilities.Clear
  Smtp1.Capabilities.Add "8BITMIME"
    With Smtp1.Message
        .Content = ""
        .From = Trim(RS.Fields("mailfrom").Value)
        .To.Clear
        .To.Add Trim(RS.Fields("mailto").Value)
        .Subject = Trim(RS.Fields("subject").Value)
        .AddText GB2ShiftJIS(Trim(RS.Fields("mailtext").Value)) + vbCrLf
       
     End With

  Smtp1.Send
  RS.Fields("actlabel").Value = "1"
  RS.Update
  RS.MoveNext
Next

Smtp1.Logout
   
End If
RS.Close

OnError:
   If BadStatusMessage <> "" Then
      StatusBar.Panels(1).Text = "ERROR:邮件发送错误 "
      Label5.Caption = BadStatusMessage
       Z = App.Path & "\web\errorlog.txt"
       Open Z For Append As #2
       Print #2, "邮件发送错误:" & Now() & BadStatusMessage
        Close #2
       BadStatusMessage = ""
       Resume Next
    End If




End Sub
Private Sub Smtp1_Progress(ByVal Method As DartMailCtl.SmtpMethodConstants, ByVal Status As DartMailCtl.SmtpStatusConstants, ByVal Reply As String, ByVal Count As Long, ByVal Size As Long)
    Debug.Print "***********************************"
    Debug.Print "On Progress: "
    Debug.Print "Reply = " & Reply
    Debug.Print "Count = " & Count
    Debug.Print "Size = " & Size
    Debug.Print
    
    If Method = smtpSend Then
💿 文件大小 945 K
👤 上传用户 hlwang523
📂 所属分类邮电通讯系统
🏷️ 相关标签

#短信 #网关
⌨️ 快捷键说明

复制代码 Ctrl + C
搜索代码 Ctrl + F
全屏模式 F11
切换主题 Ctrl + Shift + D
显示快捷键 ?
增大字号 Ctrl + =
减小字号 Ctrl + -