📄 mainform.frm
字号:
If Status = smtpSending Then
Dim n As Double
n = (CDbl(Count) / CDbl(Size)) * 100
If n > 100 Then n = 100
' Progress.Value = Int(n)
ElseIf Status = smtpOk Then
'Progress.Value = 0
End If
End If
If Status = smtpBad And BadStatusMessage = "" Then
BadStatusMessage = Reply
End If
End Sub
' _________________________________________________________________________________
'|
'|
'| 帐务交换进程ok2005-11-24
'|
'|
'|_________________________________________________________________________________
'
Private Sub Account_In()
On Error GoTo OnError
Dim FtpPath As String
Dim TXTname As String
Dim Txtstr As String
Dim SmartPit As String
Dim Account As String
Dim Amount As String
Dim Adddate As String
Dim Retxt As String
Retxt = ""
FtpPath = Trim(ReadString("commom set", "ftppath", 40))
DataBackup = Trim(ReadString("commom set", "DataBackup", 40))
Dim fso As New FileSystemObject, fil As File
'寻找ftp目录下面的以jpcn开头的文本文件，根据帐号进行充值
Filelist.Path = FtpPath
Filelist.Refresh
Filelist.Pattern = "recharge*.txt"
If Filelist.ListCount <> 0 Then
For i = 1 To Filelist.ListCount
TXTname = Filelist.List(i - 1)
TXTname = FtpPath & "\" & TXTname
Open TXTname For Input As #1
Do While Not EOF(1)
'这里有可能需要加入行判断函数，根据日本方面提供的文件格式有关
Line Input #1, Txtstr '取文件的每一行
SmartPit = Mid(Txtstr, 1, (InStr(1, Txtstr, ",") - 1))
Txtstr = Mid(Txtstr, (InStr(1, Txtstr, ",") + 1))
Account = Mid(Txtstr, 1, (InStr(1, Txtstr, ",") - 1))
Txtstr = Mid(Txtstr, (InStr(1, Txtstr, ",") + 1))
Amount = Mid(Txtstr, 1, (InStr(1, Txtstr, ",") - 1))
Adddate = Mid(Txtstr, (InStr(1, Txtstr, ",") + 1))
sql = "select * from Account where Account_id like '" & Account & "' order by id desc "
adoPrimaryRS.Open sql, db, adOpenStatic, adLockOptimistic
If adoPrimaryRS.RecordCount > 0 Then
'如果账户存在，则进行充值
adoPrimaryRS.Fields("Amount").Value = adoPrimaryRS.Fields("Amount").Value + Val(Amount)
adoPrimaryRS.Fields("logins").Value = adoPrimaryRS.Fields("logins").Value + 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 = "sms@jptocn.net" '发信地址
RS.Fields("subject").Value = ""
RS.Fields("mailtext").Value = "你的帐户已经充值，请发送CZ到sms@jptocn.net查询你的帐户金额"
RS.Fields("actlabel").Value = "0"
RS.Fields("addtime").Value = str(Now())
RS.Update
RS.Close
adoPrimaryRS.Update
adoPrimaryRS.Close
'充值结束，将结果写入返回文件"result"+"yyyymmddhhmmss"的文本文件
Z = FtpPath & "\" & "result" & Mid(Filelist.List(i - 1), 9)
Open Z For Append As #2
Print #2, "0," & SmartPit & "," & Account & "," & Amount & "," & Adddate
Close #2
Else
'账户不存在，返回结果文件"result"+"yyyymmddhhmmss"的文本文件
Z = FtpPath & "\" & "result" & Mid(Filelist.List(i - 1), 9)
Open Z For Append As #2
Print #2, "0," & SmartPit & "," & Account & "," & Amount & "," & Adddate & ";"
Close #2
adoPrimaryRS.Close
End If
Loop
Close #1
'不管充值结果如何，都要把用来充值的文件转移到其他目录下面
Set fil = fso.GetFile(FtpPath & "\" & Filelist.List(i - 1))
fil.Move (DataBackup & "\" & Filelist.List(i - 1))
Next
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
' _________________________________________________________________________________
'|
'|
'| 开户进程及用户信息处理
'|
'|设计：周大伟
'|_________________________________________________________________________________
'
'根据MAIL进行开户,在ftp目录下面建立以cnjp开头的文本文件
Private Sub User_line()
'申请开通邮箱：sms@jptocn.net
On Error GoTo OnError
Dim Retxt As String
Retxt = ""
Dim FtpPath As String
Dim TXTname As String
Dim Txtstr As String
FtpPath = Trim(ReadString("commom set", "ftppath", 40))
Dim Ucodes As String
Dim Upassw As String
Pop1.Messages.Clear
Pop1.Timeout = 10000
Pop1.Login Euserserver, Eusername, Euserpass
If Pop1.Count = 0 Then '如果邮件服务器上没有邮件，则退出进程，等待下一次触发
Pop1.Logout
Else '如果邮件服务器上有邮件，则收取邮件并写入邮件队列
Pop1.Get
StatusBar.Panels(1).Text = "待收邮件:" & Pop1.Count
Dim Msg As Message
Dim n As Long
Dim lvi As ListItem
For n = 1 To Pop1.Messages.Count
Set Msg = Pop1.Messages.Item(n)
'开户。首先判断该email地址在帐户表内是否存在，邮件内容是否为13位数字，然后判断SmartPit是否存在
sql = "select * from Account where Account_id like '" & Trim(FromAddress(Msg.From)) & "' order by id desc "
adoPrimaryRS.Open sql, db, adOpenStatic, adLockOptimistic
If adoPrimaryRS.RecordCount > 0 Then
Text5.Text = Trim(Msg.Text)
Text5.Text = Trim(Text5.Text)
Text5.Text = quan2ban(Text5.Text)
Text5.Text = Trim(Text5.Text)
Debug.Print Text5.Text
If Left(Text5.Text, 2) = "cz" Or Left(Text5.Text, 2) = "CZ" Or Left(Text5.Text, 2) = "ＣＺ" Or Left(Text5.Text, 2) = "ｃｚ" Then
'查询余额
sql = "select * from Mailout"
RS.Open sql, db, adOpenStatic, adLockOptimistic
RS.AddNew
RS.Fields("mailto").Value = Trim(FromAddress(Msg.From)) '目标地址
RS.Fields("mailfrom").Value = "sms@jptocn.net" '发信地址
RS.Fields("subject").Value = ""
RS.Fields("mailtext").Value = "你的帐户余额为：" & adoPrimaryRS.Fields("Amount").Value '信件内容
RS.Fields("actlabel").Value = "0"
RS.Fields("addtime").Value = str(Now())
RS.Update
RS.Close
'其他数字和文本不予判断，直接回馈邮件重复信息给用户。
Else
sql = "select * from Mailout"
RS.Open sql, db, adOpenStatic, adLockOptimistic
RS.AddNew
RS.Fields("mailto").Value = Trim(FromAddress(Msg.From)) '目标地址
RS.Fields("mailfrom").Value = "sms@jptocn.net" '发信地址
RS.Fields("subject").Value = ""
RS.Fields("mailtext").Value = "亲爱的用户，你的E-mail地址无效，请致电090-1234-5678，我们会热诚为你服务。" '信件内容
RS.Fields("actlabel").Value = "0"
RS.Fields("addtime").Value = str(Now())
RS.Update
RS.Close
End If
adoPrimaryRS.Close
Else
adoPrimaryRS.Close
'帐户不存在，判断是否为SmartPit
Label28.Caption = Val(Label28.Caption) + 1
Text5.Text = Trim(Msg.Text)
Text5.Text = Trim(Text5.Text)
Text5.Text = quan2ban(Text5.Text)
Text5.Text = str$(Val(Text5.Text))
Text5.Text = Trim(Text5.Text)
If Len(Text5.Text) > 12 And Len(Text5.Text) < 14 Then
'判断是13位号码，察看号码是否重复，重复则返回邮件，否则进行开户
sql = "select * from Account where SmartPit like '" & Text5.Text & "' order by id desc "
adoPrimaryRS.Open sql, db, adOpenStatic, adLockOptimistic
If adoPrimaryRS.RecordCount > 0 Then
'SmartPit重复，返回通知邮件
adoPrimaryRS.Close
sql = "select * from Mailout"
RS.Open sql, db, adOpenStatic, adLockOptimistic
RS.AddNew
RS.Fields("mailto").Value = Trim(FromAddress(Msg.From)) '目标地址
RS.Fields("mailfrom").Value = "sms@jptocn.net" '发信地址
RS.Fields("subject").Value = ""
RS.Fields("mailtext").Value = "亲爱的用户，你的SmartPit充值卡号码有重复，请致电090-1234-5678，我们会热诚为你服务"
RS.Fields("actlabel").Value = "0"
RS.Fields("addtime").Value = str(Now())
RS.Update
RS.Close
Else
adoPrimaryRS.Close
'进行开户处理
Upassw = str(Rnd(98) * 10000) '产生随机密码
sql = "select * from Account"
adoPrimaryRS.Open sql, db, adOpenStatic, adLockOptimistic
adoPrimaryRS.AddNew
adoPrimaryRS.Fields("Account_id").Value = Trim(FromAddress(Msg.From))
adoPrimaryRS.Fields("s_date").Value = str(Now())
adoPrimaryRS.Fields("SmartPit").Value = Text5.Text
adoPrimaryRS.Fields("password").Value = Upassw
adoPrimaryRS.Update
adoPrimaryRS.Close
'开户成功，发送欢迎邮件
Label29.Caption = Val(Label29.Caption) + 1
sql = "select * from Mailout"
RS.Open sql, db, adOpenStatic, adLockOptimistic
RS.AddNew
RS.Fields("mailto").Value = Trim(FromAddress(Msg.From)) '目标地址
RS.Fields("mailfrom").Value = "sms@jptocn.net" '发信地址
RS.Fields("subject").Value = ""
RS.Fields("mailtext").Value = "亲爱的用户，感谢你使用中文短信服务，你的申请已被接受，正在处理中，请稍候。您的帐户密码为：" & Upassw & ",欢迎访问我们的网站，了解更多服务内容。手机网站：http://3gmsn.com电脑网站：http://3gmsn.com/sms/TEL：1234-5678E -mail: info@ jptocn.net"
RS.Fields("actlabel").Value = "0"
RS.Fields("addtime").Value = str(Now())
RS.Update
RS.Close
'========创建文本文件给日本================
Z = FtpPath & "\" & "cnjp" & Year(Now()) & Month(Now()) & Day(Now) & Hour(Now()) & Minute(Now()) & Second(Now()) & ".txt"
Open Z For Append As #2
Print #2, Text5.Text & "," & Trim(FromAddress(Msg.From)) & "," & Year(Now()) & Month(Now()) & Day(Now) & Hour(Now()) & Minute(Now()) & Second(Now()) & ";"
Close #2
End If
Else
sql = "select * from Mailout"
RS.Open sql, db, adOpenStatic, adLockOptimistic
RS.AddNew
RS.Fields("mailto").Value = Trim(FromAddress(Msg.From)) '目标地址
RS.Fields("mailfrom").Value = "sms@jptocn.net" '发信地址
RS.Fields("subject").Value = ""
RS.Fields("mailtext").Value = "亲爱的用户，你的SmartPit充值卡号码有误，您的申请没有被接受。请查对后重新进行申请"
RS.Fields("actlabel").Value = "0"
RS.Fields("addtime").Value = str(Now())
RS.Update
RS.Close
End If
End If
Pop1.Delete (n)
Next
Pop1.Logout
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
Private Sub zhuanma_Click()
Frame2.Visible = True
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -