main.bas

有线电视收费软件 数据库密码winter

Attribute VB_Name = "Module"
Option Explicit
'*********************
'系统主程序
'*********************
Public Sub Main()
    Dim sName As String
    
    '打开本地数据库
    sName = App.Path & "\catv.mdb"
    sCon = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sName & ";Jet OLEDB:Database Password=winter99;"
    CN.Open sCon
    
    
    frmSplash.Show
    
    '进行系统登录
    frmLogin.Show vbModal
    
    LoginSucceeded = True
    If LoginSucceeded Then  '登录成功
        frmMDI.Show
    Else                    '登录失败
        CN.Close
        End
    End If
End Sub
'*************************************
'获取ini文件中关于登录SQL服务器的信息
'*************************************
Private Sub GetInfo()
    Dim FileName As String
    Dim lResult As Long
    
    gsServer = Space(20)
    gsUser = Space(20)
    gsPassword = Space(20)
    '读取登录信息
    FileName = App.Path & "\sysinfo.ini"
    lResult = GetPrivateProfileString("system", "server", gsServer, gsServer, Len(gsServer) + 1, FileName)
    lResult = GetPrivateProfileString("system", "user", gsUser, gsUser, Len(gsUser) + 1, FileName)
    lResult = GetPrivateProfileString("system", "password", gsPassword, gsPassword, Len(gsPassword) + 1, FileName)
    gsServer = Trim(gsServer)
    gsServer = Left(gsServer, Len(gsServer) - 1)
    gsServer = Decode(gsServer, Space(20))
    gsUser = Trim(gsUser)
    gsUser = Left(gsUser, Len(gsUser) - 1)
    gsUser = Decode(gsUser, Space(20))
    gsPassword = Trim(gsPassword)
    gsPassword = Left(gsPassword, Len(gsPassword) - 1)
    gsPassword = Decode(gsPassword, Space(20))
End Sub
'检查网络连接状态
Function NetConnecting() As Boolean

    On Error GoTo Connect_Error
    
    Call GetInfo
    sCon1 = "UID=" & Trim(gsUser) & ";PWD=" & Trim(gsPassword) & ";DATABASE=CATV;" _
         & "SERVER=" & Trim(gsServer) & ";DRIVER={SQL SERVER};DSN=''"
    CN.CursorLocation = adUseServer
    
    CN.Open sCon1
    NetConnecting = True

Connect_Exit:
    
    Exit Function
Connect_Error:
    Dim adErr As Error
    Dim sErr As String
    For Each adErr In CN.Errors
        sErr = sErr & "Number:" & adErr.Number & vbCrLf
        sErr = sErr & "Description:" & adErr.Description & vbCrLf
        sErr = sErr & "Source:" & adErr.Source & vbCrLf
        
    Next
    NetConnecting = False
    MsgBox "网络不能正确连接！！！请记录以下信息报告给系统管理员。"
    MsgBox sErr
    GoTo Connect_Exit
End Function

'加密字符串
Public Function Encode(ByVal Not_Encrypted_Txt As String, Key_Word As String) As String

    Dim Current_Letter As String
    Dim Encrypted_Phase1 As Long
    Dim Encrypted_Phase2 As Long
    Dim Encrypted_Word As String
    Dim iNot_Encrypted_txt As Integer
    Dim iCount As Integer
    
    iNot_Encrypted_txt = Len(Not_Encrypted_Txt)
    For iCount = 1 To iNot_Encrypted_txt
      Current_Letter = Mid$(Not_Encrypted_Txt, iCount, 1)
      Encrypted_Phase1 = Asc(Current_Letter)
      Encrypted_Phase2 = Encrypted_Phase1 + iCount
      Encrypted_Word = Encrypted_Word + Chr$(Encrypted_Phase2)
    Next iCount
    
    Encode = Encrypted_Word

End Function
'解密字符串
Public Function Decode(ByVal Encrypted_Txt As String, Key_Word As String) As String
    Dim Current_Letter As String
    Dim Encrypted_Phase1 As Long
    Dim Encrypted_Phase2 As Long
    Dim Encrypted_Word As String
    
    Dim iNot_Encrypted_txt As Integer
    Dim iCount As Integer
    
    For iCount = 1 To Len(Encrypted_Txt)
      Current_Letter = Mid$(Encrypted_Txt, iCount, 1)
      Encrypted_Phase1 = Asc(Current_Letter)
      Encrypted_Phase2 = Encrypted_Phase1 - iCount
      Encrypted_Word = Encrypted_Word + Chr$(Encrypted_Phase2)
    Next iCount
    
    Decode = Encrypted_Word

End Function

'在状态栏中显示提示信息
Public Sub ShowStatus(sMess As String)
    frmMDI!sbStatus.Panels(1).Text = sMess
End Sub
'转换地址信息
Public Function shwID(sID As String) As String
    Dim shwMSG As String
    If Format(sID) = "" Then Exit Function
    shwMSG = "" & Val(Left(sID, 2)) & "地区 "
    shwMSG = shwMSG & Val(Mid(sID, 3, 4)) & "栋 "
    shwMSG = shwMSG & Val(Mid(sID, 7, 4)) & "单元号 "
    shwMSG = shwMSG & Val(Mid(sID, 11, 2)) & "楼 "
    Select Case Mid(sID, 13, 1)
           Case "0": shwMSG = shwMSG & "东" & "面 "
           Case "1": shwMSG = shwMSG & "南" & "面 "
           Case "2": shwMSG = shwMSG & "西" & "面 "
           Case "3": shwMSG = shwMSG & "北" & "面 "
    End Select
    shwID = shwMSG

End Function
'
Public Sub FillOperator(cmb As ComboBox)
    Dim adoRs As New ADODB.Recordset
    Dim sSQL As String
      
    If Trim(sPopedom) <> "A" Then
        cmb.Text = sOperator
        cmb.Locked = True
        Exit Sub
    End If
    '打开操作权限表
    sSQL = "SELECT 姓名 FROM 操作权限表"
    adoRs.Open sSQL, CN, adOpenStatic, adLockReadOnly
    cmb.Clear
    Do While Not adoRs.EOF
      cmb.AddItem adoRs![姓名]
      adoRs.MoveNext
    Loop
    cmb.AddItem "-全部-"
    cmb.Text = "-全部-"
    adoRs.Close
End Sub
'根据用户编号，计算该用户的欠费金额
Public Function UserOwe(sNO As String) As Currency
    Dim rsOwe As New ADODB.Recordset
    Dim sSQL As String
    
    '打开用户欠费表
    sSQL = "SELECT SUM(fee) AS Total FROM t_owe" _
         & " WHERE uID='" & sNO & "'"
    rsOwe.Open sSQL, CN, adOpenStatic, adLockPessimistic
    If rsOwe.BOF And rsOwe.EOF Then
        '欠费表中无记录，欠费为零
        UserOwe = 0
    Else
        UserOwe = Val(Format(rsOwe![Total]))
    End If
    
End Function

'函数:
'tlbToolbarStyle :
'1 为 Office97 风格
'2 为 IE4 风格

Public Sub ToolbarStyle(tlb As Toolbar, tlbToolbarStyle As Long)

    Dim lngStyle As Long
    Dim lngResult As Long
    Dim lngHWND As Long
         
    ' Find child window and get style bits
    lngHWND = FindWindowEx(tlb.hwnd, 0&, "ToolbarWindow32", vbNullString)
    lngStyle = SendMessage(lngHWND, TB_GETSTYLE, 0&, 0&)
    
    ' Use a case statement to get the effect
    Select Case tlbToolbarStyle
    Case 1:
    
    ' Creates an Office 97 like toolbar
    lngStyle = lngStyle Or TBSTYLE_FLAT
    
    Case 2:
    
    ' Creates an Explorer 4.0 like toolbar,
    ' with text to the right of the picture. You must provide text
    ' in order to get the effect.
    
    lngStyle = lngStyle Or TBSTYLE_FLAT Or TBSTYLE_LIST
    
    Case Else
    
    lngStyle = lngStyle Or TBSTYLE_FLAT
    
    End Select
    
    ' Use the API call to change the toolbar
    lngResult = SendMessage(lngHWND, TB_SETSTYLE, 0, lngStyle)
    
    ' Show the effects
    tlb.Refresh

End Sub



Public Sub PrintGrid(Title As String, Grid As MSHFlexGrid)
Dim Orgx As Integer
Dim Orgy As Integer
Dim i As Integer, j As Integer
Dim wGrid As Long
Dim LnStrX As Long
Dim LnStrY As Long
Dim printText As String
Dim ii As Integer

Orgx = 800 'Twips
Orgy = 800
wGrid = 0

On Error GoTo ErrHandle

Printer.ScaleMode = vbTwips
Printer.Font.Size = Grid.Font.Size
For i = 0 To Grid.Cols - 1
    If Grid.ColWidth(i) = -1 Then
        wGrid = wGrid + 1000
    Else
        wGrid = wGrid + Grid.ColWidth(i)
    End If
Next i
If wGrid > Printer.Width Then
If MsgBox("纸页横向超标！是否调整后再打印？", vbYesNo) = vbYes Then Exit Sub
End If

With Printer
.Font = "宋体"
.Font.Size = 14
.FontBold = True
.CurrentX = Orgx + wGrid / 2 - Printer.TextWidth(Title) / 2
.CurrentY = Orgy + 567
Printer.Print Title
.Font = "宋体"
.Font.Size = 11
.FontBold = False
.CurrentX = Orgx + 567
.CurrentY = .CurrentY + 100
.CurrentX = Orgx + wGrid - Printer.TextWidth("2000年12月31日") - 500
Printer.Print "日期：" + Format(Date, "long date")
End With

LnStrX = Orgx
LnStrY = Printer.CurrentY

For i = 0 To Grid.Rows - 1

If LnStrY > Printer.Height - 1000 Then
    Printer.NewPage
    LnStrX = Orgx
    LnStrY = Orgy
End If
For j = 0 To Grid.Cols - 1
    If Grid.ColWidth(j) = -1 Then
        Printer.Line (LnStrX, LnStrY)-Step(1000, Grid.RowHeight(i)), , B
        Printer.CurrentX = LnStrX + 30
        Printer.CurrentY = LnStrY + 30
        printText = Grid.TextMatrix(i, j)
        
        ii = InStr(1, printText, ".")
        If Val(printText) > 0 And ii > 0 Then printText = Left(printText, ii - 1)
    
        While Printer.TextWidth(printText) > 1000
        printText = Left(printText, Len(printText) - 1)
        Wend
        Printer.Print printText
        LnStrX = LnStrX + 1000
    ElseIf Grid.ColWidth(j) > 180 Then
    
        Printer.Line (LnStrX, LnStrY)-Step(Grid.ColWidth(j), Grid.RowHeight(i)), , B
        Printer.CurrentX = LnStrX + 30
        Printer.CurrentY = LnStrY + 30
        printText = Grid.TextMatrix(i, j)
    
        ii = InStr(1, printText, ".")
        If Val(printText) > 0 And ii > 0 Then printText = Left(printText, ii - 1)
    
        While Printer.TextWidth(printText) > Grid.ColWidth(j)
        printText = Left(printText, Len(printText) - 1)
        Wend
        Printer.Print printText
        LnStrX = LnStrX + Grid.ColWidth(j)
        
    End If
Next j
LnStrX = Orgx
LnStrY = LnStrY + Grid.RowHeight(i)
Next i


Printer.EndDoc
MsgBox "打印信息已被发送给打印机！", vbInformation, "打印"

Exit Sub
ErrHandle:
MsgBox "产生系统打印错误！", vbCritical

End Sub

Public Sub PrintTable(sTemplate As String, n As Integer, ByRef Items() As tItem)
    Dim wrd As Word.Application
    Dim i As Integer
    Dim j As Integer
    Dim breakLoop As Boolean
    Dim pTime As Date
    
    On Error GoTo ErrorTrap
        
    Set wrd = CreateObject("Word.Application")
    wrd.Visible = False
        
    wrd.Documents.Add App.Path & "\" & sTemplate, False, wdNewBlankDocument, True
    '设定标题
    wrd.Documents(1).Paragraphs(1).Format.Alignment = wdAlignParagraphCenter
    With wrd.Documents(1).Paragraphs(1).Range
        .Text = Items(0).item
    End With
   
    'wrd.Documents(1).Tables(1).Cell(1, 1).Range = Format(Date, "YYYY年MM月DD日")
    For i = 1 To n - 1
        wrd.Documents(1).Tables(1).Cell(Items(i).row, Items(i).col).Range = GetValue(Items(i).item)
    Next i
    wrd.Documents(1).PrintOut False
    pTime = Time
    breakLoop = False
    While wrd.BackgroundPrintingStatus <> 0 And Not breakLoop
        DoEvents
        If Minute(Time - pTime) > 1 Then
            If MsgBox("时间超过 1 分钟，是否结束打印", vbYesNo, "打印提示") = vbYes Then
                breakLoop = True
            Else
                pTime = Time
            End If
        End If
    Wend
    wrd.Documents(1).Close False
    
    wrd.Quit False
    
    '释放对象变量。
    Set wrd = Nothing

    Exit Sub
ErrorTrap:
    Dim iTries As Integer
   '因 Microsoft Word 不能启动而产生的错误的陷阱。
   Select Case Err.Number
      Case 429
        ShellExecute 0, "", "winword.exe", "", "", 0

        Resume
      Case 440               ' Automation 错误
         iTries = iTries + 1
         '做1次重新启动 Word 的尝试。
         If iTries < 1 Then
            Set wrd = New Word.Application
            Resume
         Else
            Err.Raise Number:=vbObjectError + 28765, _
            Description:="Couldn't restart Word"
         End If
      Case Else
         MsgBox Err.Number & Err.Description
'         Err.Raise Number:=Err.Number
   End Select

End Sub

Public Function GetValue(sVal As String) As String
    If Val(sVal) <> 0 Then
        GetValue = Format(Val(sVal), "0")
    Else
        GetValue = Format(sVal, "0")
    End If
End Function