form7.frm

根据MS Proxy的日志文件进行计费的程序

    Screen.MousePointer = vbDefault
    Exit Sub

SortErr:
    Screen.MousePointer = vbDefault
    MsgBox "Error:" & Err & " " & Err.Description, vbOKOnly + vbExclamation, "错误"
End Sub


Private Sub Command1_Click()
Dim FileNumber As Integer
Dim mailhoststr, mailstr As String
Dim db As Database
Dim EmailDataRs As Recordset

mailstr = ""

    FileNumber = FreeFile
    Open "temp.txt" For Output As FileNumber
    Print #FileNumber, Text1.Text
    Close #FileNumber

    mailhoststr = GetSetting("wsm", "system", "MailHost")

    mailstr = "postmail -S" & Chr(34) & "Fee Form" & Chr(34) & _
                " [e-mail] -F" & Chr(34) & "Fang" & Chr(34) & _
                " -H " & mailhoststr
    'postmail -S"Fee Form" [e-mail] -F"Fang" -Hmail.sjtu.edu.cn [e-mail] < temp.txt
    Debug.Print mailstr

    Data1.Recordset.MoveFirst
    Set db = OpenDatabase("d:\wsm\wsm.mdb")
    Set EmailDataRs = db.OpenRecordset("emails", dbOpenSnapshot)
    Do While Not Data1.Recordset.EOF
        EmailDataRs.FindFirst "name = '" & Data1.Recordset.Fields("name") & "'"
        Shell mailstr & " " & EmailDataRs.Fields("email") & " <temp.txt", vbHide
        Data1.Recordset.MoveNext
    Loop
End Sub

Private Sub Form_Load()
    Dim bParmQry As Integer
    Dim qdfTmp As QueryDef
    
    On Error GoTo LoadErr

    'To Do
    'gsDatabase is a global string that needs
    'to be set by the startup sub for the app
    'Data1.DatabaseName = gsDatabase
    'gsRecordSource is a global string that needs
    'to be set by the sub routine that loads this form
    'Data1.RecordSource = gsRecordsource
    'Data1.RecordsetType = 1     'dynaset
    Data1.Options = 0
    Data1.Refresh

    If Len(Data1.RecordSource) > 50 Then
        Me.Caption = "SQL Statement"
    Else
        Me.Caption = Data1.RecordSource
    End If
    
    Label2.Caption = GetSetting("wsm", "System", "T1")

    Exit Sub

    
LoadErr:
    MsgBox "Error:" & Err & " " & Err.Description, vbOKOnly + vbExclamation, "错误"
    Unload Me
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    If Me.WindowState <> 1 Then
        grdDataGrid.Height = Me.Height - (425 + picButtons.Height)
    End If
End Sub

Private Sub grdDataGrid_BeforeDelete(Cancel As Integer)
    If MsgBox("Delete Current Row?", vbYesNo + vbQuestion, "请选择") <> vbYes Then
        Cancel = True
    End If
End Sub

Private Sub grdDataGrid_BeforeUpdate(Cancel As Integer)
    If MsgBox("Commit changes?", vbYesNo + vbQuestion, "请选择") <> vbYes Then
        Cancel = True
    End If
End Sub

Private Sub grdDataGrid_HeadClick(ByVal ColIndex As Integer)
    'let's sort on this column
    If Data1.RecordsetType = vbRSTypeTable Then Exit Sub
    
    'check for the use of the ctrl key for descending sort
    If mbCtrlKey Then
        msSortCol = "[" & Data1.Recordset(ColIndex).Name & "] desc"
        mbCtrlKey = 0 'reset it
    Else
        msSortCol = "[" & Data1.Recordset(ColIndex).Name & "]"
    End If
    cmdSort_Click
    msSortCol = vbNullString 'reset it
    
End Sub

Private Sub grdDataGrid_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
    mbCtrlKey = Shift
End Sub

Private Sub Send_Click()
Dim Group1, Name1, mailstr As String
Dim Number1 As Integer
Dim FreeSent1, FreeRecvd1, FreeConnect1, _
        CheapSent1, CheapRecvd1, CheapConnect1, _
        ExpensiveSent1, ExpensiveRecvd1, ExpensiveConnect1, _
        TotalSent1, TotalRecvd1, TotalConnect1, TotalFee1 _
        As Integer
Dim FreeSent2, FreeRecvd2, FreeConnect2, _
        CheapSent2, CheapRecvd2, CheapConnect2, _
        ExpensiveSent2, ExpensiveRecvd2, ExpensiveConnect2, _
        TotalSent2, TotalRecvd2, TotalConnect2, TotalFee2 _
        As Integer

Dim SpaceLine, NewLine As String

TotalSent1 = 0
TotalRecvd1 = 0
TotalConnect1 = 0

NewLine = Chr(13) & Chr(10)

'SpaceLine = GetDP(GetSetting("wsm", "system", "spaceline"))

Text1.Text = GetDP(GetSetting("wsm", "system", "title"))
If InStr(1, SpaceLine, "%", vbTextCompare) <> 0 Then
    Text1.Text = GetDP(Text1.Text)
End If

Text1.Text = Text1.Text & Chr(13) & Chr(10) & _
    "序号  组名  姓名  免费发送  免费接收  免费连接  廉价发送  " & _
    "廉价接收  廉价连接  计费发送  计费接收  计费连接  总发送  总接收  总连接  总费用  备注"

Data1.Recordset.MoveFirst
Do While Not Data1.Recordset.EOF
    Number1 = Number1 + 1
    Group1 = LCase(Data1.Recordset.Fields("groupname"))
    Name1 = LCase(Data1.Recordset.Fields("name"))
    FreeSent1 = Data1.Recordset.Fields("freesent")
    FreeRecvd1 = Data1.Recordset.Fields("freerecvd")
    FreeConnect1 = Data1.Recordset.Fields("freeconnect")
    CheapSent1 = Data1.Recordset.Fields("cheapsent")
    CheapRecvd1 = Data1.Recordset.Fields("cheaprecvd")
    CheapConnect1 = Data1.Recordset.Fields("cheapconnect")
    ExpensiveSent1 = Data1.Recordset.Fields("expensivesent")
    ExpensiveRecvd1 = Data1.Recordset.Fields("expensiverecvd")
    ExpensiveConnect1 = Data1.Recordset.Fields("expensiveconnect")
    TotalSent1 = Data1.Recordset.Fields("totalsent")
    TotalRecvd1 = Data1.Recordset.Fields("totalrecvd")
    TotalConnect1 = Data1.Recordset.Fields("totalconnect")
    TotalFee1 = Data1.Recordset.Fields("totalfee")
    
FreeSent2 = FreeSent2 + FreeSent1
FreeRecvd2 = FreeRecvd2 + FreeRecvd1
FreeConnect2 = FreeConnect2 + FreeConnect1
CheapSent2 = CheapSent2 + CheapSent1
CheapRecvd2 = CheapRecvd2 + CheapRecvd1
CheapConnect2 = CheapConnect2 + CheapConnect1
ExpensiveSent2 = ExpensiveSent2 + ExpensiveSent1
ExpensiveRecvd2 = ExpensiveRecvd2 + ExpensiveRecvd1
ExpensiveConnect2 = ExpensiveConnect2 + ExpensiveConnect1
TotalSent2 = TotalSent2 + TotalSent1
TotalRecvd2 = TotalRecvd2 + TotalRecvd1
TotalConnect2 = TotalConnect2 + TotalConnect1
TotalFee2 = TotalFee2 + TotalFee1
    
    Text1.Text = Text1.Text & NewLine & CStr(Number1) & Space(5) & Group1 & _
            Space(2) & Name1 & Space(5) & _
            CStr(FreeSent1) & Space(6) & CStr(FreeRecvd1) & Space(5) & _
            CStr(FreeConnect1) & Space(5) & _
            CStr(CheapSent1) & Space(6) & CStr(CheapRecvd1) & Space(5) & _
            CStr(CheapConnect1) & Space(5) & _
            CStr(ExpensiveSent1) & Space(5) & CStr(ExpensiveRecvd1) & _
            Space(5) & CStr(ExpensiveConnect1) & Space(5) & _
            CStr(TotalSent1) & Space(5) & CStr(TotalRecvd1) & Space(3) & _
            CStr(TotalConnect1) & Space(3) & TotalFee1 & Space(3) & "**"
    Data1.Recordset.MoveNext
Loop
Text1.Text = Text1.Text & NewLine & CStr(Number1 + 1) & Space(5) & "Total" & _
            Space(2) & "Total" & Space(5) & _
            CStr(FreeSent2) & Space(6) & CStr(FreeRecvd2) & Space(5) & _
            CStr(FreeConnect2) & Space(5) & _
            CStr(CheapSent2) & Space(6) & CStr(CheapRecvd2) & Space(5) & _
            CStr(CheapConnect2) & Space(5) & _
            CStr(ExpensiveSent2) & Space(5) & CStr(ExpensiveRecvd2) & _
            Space(5) & CStr(ExpensiveConnect2) & Space(5) & _
            CStr(TotalSent2) & Space(5) & CStr(TotalRecvd2) & Space(3) & _
            CStr(TotalConnect2) & Space(3) & TotalFee2 & Space(3) & "**"
Command1.Enabled = True
End Sub

Private Function GetDP(Value As String) As String
Dim temp1 As String
Dim aa, bb As Integer
Dim ee As String

aa = bb = 0
temp1 = ""

Do
aa = CInt(InStr(bb + 1, Value, "%", vbTextCompare))
If aa = 0 Then
    GetDP = GetDP & Right(Value, Len(Value) - bb)
    Exit Function '没le
Else
    bb = InStr(aa + 1, Value, "%", vbTextCompare)
    ee = Mid(Value, aa + 1, bb - aa - 1)
    Select Case LCase(ee)
    Case "sdate"
        temp1 = GetSetting(appname:="wsm", Section:="startup", _
                Key:="date", Default:="没找着")
        'temp1 = temp1 & " " & GetSetting("wsm", "startup", "time","没找着")
    Case "edate"
        temp1 = GetSetting(appname:="wsm", Section:="end", _
                Key:="date", Default:="没找着")
        'temp1 = temp1 & " " & GetSetting("wsm", "end", "time","没找着")
    
    Case Else
        temp1 = GetSetting("wsm", "system", ee, "没找着")
        If temp1 = "\t" Then temp1 = Space(4)
        If temp1 = "\n" Then temp1 = Chr(13)
    End Select
End If
GetDP = GetDP & temp1
Loop While aa <> 0
End Function