modmain.bas

ktv场所的包房开房、迎宾、预定管理系统。

Attribute VB_Name = "ModMain"
Option Explicit
Public Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Declare Function lstrlenA Lib "kernel32" (ByVal psString As Any) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDest As Any, lpSource As Any, ByVal nCount As Long)
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Public strCurUser As String '当前用户

Public regedita As Boolean '是否注册
Public intNumWindows As Integer
Public strConnect As String
Public strusername As String
Public struserinfoname As String
Public struserinfoaddress As String
Public struserinfotell As String
Public aaa As Integer
Public struserinfodemo As String
Public report As Boolean
Public frmno As Integer
Public prover As Boolean '是否有库存
Public zycolor As Long
Public zypath As String
Public kcolor As Long
Public kpath As String
Public ydcolor As Long
Public ydpath As String
Public zlcolor As Long
Public zlpath As String
Public yesnochk As Boolean '是否需要审核
Public dscjxc As String
Public cnn As ADODB.Connection
Public protype As String
Public cxScreen As Long
Sub Main()

    Dim mrc As New ADODB.Recordset
    Dim strsql As String
    Dim msgtext As String
    Dim mrc1 As ADODB.Recordset
    Dim disksn As String
    Dim sn_len, sn_num, i, total_a1, total_a, j, total_a2 As Integer
    Dim a As String
    Dim snstring, g_username, cccc As String
    Dim inisourcepath As String
    cxScreen = GetSystemMetrics(0)
    inisourcepath = app.Path & "\dscck.ini"
    dscjxc = readini("parameters", "servername", inisourcepath)
    If dscjxc = "" Then
        dscjxc = app.Path & "\data"
    End If
    
   Set cnn = New ADODB.Connection
   strConnect = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & dscjxc & "\qdjxc.mdb;Jet OLEDB:Database Password=fjzyq1980"
   cnn.Open strConnect
   
    prover = True
    strsql = "select * from userinfo "
    Set mrc1 = ExecuteSQL(strsql, msgtext)

    disksn = "qdsoft2004LH"
    sn_len = Len(disksn)
    If sn_len > 10 Then sn_len = 10
    snstring = Mid(disksn, 1, 1)
    sn_num = Asc(snstring)
    For i = 1 To sn_len
        sn_num = sn_num + Asc(Mid(disksn, i, 1)) * 157
    Next i
    g_username = "" & mrc1.Fields("username")

    i = LenB(Trim$(StrConv(mrc1.Fields("username"), vbUnicode)))
    i = Len(mrc1.Fields("username"))
    total_a = 0
    For j = 1 To i
        total_a1 = 0
        total_a2 = 0
        a = Hex(Asc(Mid(mrc1.Fields("username"), j, 1)))
        If Len(a) > 2 Then
            cccc = Mid(a, 1, 2)
            total_a1 = "&H" & cccc
            cccc = Mid(a, 3, 2)
            total_a2 = "&H" & cccc
            a = 0
        Else
            cccc = a
            total_a1 = "&H" & cccc
        End If
        total_a = total_a + total_a2 + total_a1
    Next j
    sn_num = sn_num + total_a
    regedita = False

    If Not mrc1.EOF Then
        mrc1.MoveFirst
    End If
    Do Until mrc1.EOF
        If Val(mrc1.Fields("userid")) = sn_num Then
            regedita = True
            Exit Do
        Else
            mrc1.MoveNext
        End If
    Loop
    If regedita = False Then
        frm_regedit.lab_sn = disksn
        frm_regedit.Show 1
    End If
    Set mrc = New ADODB.Recordset
    frmLogin.Show vbModal
    If Not frmLogin.LoginSucceeded Then
        End
    End If
    Unload frmLogin
    Load frmMain
    
    aaa = 20
    frmMain.Show
    'FrmSysDate.Show vbModal
   
End Sub

Public Sub SetFormStu(mFrmChi As Form, mFrmFat As Form)
    mFrmChi.Top = (mFrmFat.height - mFrmChi.height) / 2 - 980
    mFrmChi.Left = (mFrmFat.width - mFrmChi.width) / 2
End Sub

Public Function OpenWindow(intTmp As Integer)
    OpenWindow = intTmp + 1
End Function

Public Function Closewindow(intTmp As Integer)
    Closewindow = intTmp - 1
End Function


Public Sub EnterToTab(Keyasc As Integer)
    If Keyasc = 13 Then
        SendKeys "{TAB}"
    End If
End Sub
Public Function ExecuteSQL(ByVal sql As String, MsgString As String) As ADODB.Recordset

   
   Dim sTokens() As String
   
 ' On Error GoTo ExecuteSQL_Error

   sTokens = Split(sql)

   If InStr("INSERT,DELETE,UPDATE", UCase$(sTokens(0))) Then
      cnn.Execute sql
      MsgString = 1
   Else
        Dim rst As New ADODB.Recordset
        rst.Open Trim$(sql), cnn, adOpenKeyset, adLockOptimistic
        MsgString = 1
        Set ExecuteSQL = rst
   End If

   
End Function

Public Function readini(appname, KeyName As String, FileName As String) As String
    Dim inireturn As String
    inireturn = String(255, Chr(0))
    readini = Left(inireturn, GetPrivateProfileString(appname, ByVal KeyName, "", inireturn, Len(inireturn), FileName))
End Function
Public Function writeini(sappname, skeyname As String, snewstring As String, sFilename As String)
       Dim Flag As Integer
       Flag = WritePrivateProfileString(sappname, skeyname, snewstring, sFilename)
       writeini = Flag
End Function

Public Sub menuenable(aaaflag As Boolean)
    frmMain.Toolbar1.Buttons(1).Enabled = aaaflag
    frmMain.Toolbar1.Buttons(2).Enabled = aaaflag
    frmMain.Toolbar1.Buttons(3).Enabled = aaaflag
    frmMain.Toolbar1.Buttons(4).Enabled = aaaflag
    frmMain.Toolbar1.Buttons(5).Enabled = aaaflag
End Sub

Public Sub PrintRs(ByRef TabHead() As String, ByRef ColWidths() As Long, ByVal num As Long, ByVal rs As ADODB.Recordset)
    Dim app As New Excel.Application
    Dim book As New Excel.Workbook
    Dim sheet As New Excel.Worksheet
    Set book = app.Workbooks.Add
    Set sheet = book.Worksheets.Add
    app.Visible = True
    Dim count As Long

    app.cells.CopyFromRecordset rs
    
    sheet.rows("1:1").Select
    app.Selection.Insert
    For count = 1 To num
        sheet.cells(1, count) = TabHead(count)
    Next

    app.Range("A1").Select
            
    Set app = Nothing
    Set book = Nothing
    Set sheet = Nothing
End Sub

Public Function CalWidth(mstr As String, fontsize As Single) As Single
'*得到宽度

    CalWidth = LenB(StrConv(mstr, vbFromUnicode)) * fontsize * 10
    
End Function

Public Function CalHeight(fontsize As Single) As Single
'*得到高度

    CalHeight = fontsize * aaa
    
End Function
Public Function GetIni(FileName As String, _
                       section As String, _
                       key As String) _
    As String
    
    Dim l       As Long
    Dim str     As String * 1000
    Dim tStr    As String

    l = GetPrivateProfileString(section, key, "", str, 1000, FileName)

    tStr = Replace(str, Chr(32), "")
    tStr = Replace(str, Chr(0), "")
    tStr = Trim$(tStr)
    GetIni = tStr
    
End Function

'*****************************************************
'*名称：SetIni
'*功能：写INI文件
'*传入参数：
'*      filename    --文件名
'*      section     --项目名
'*      key         --键名
'*      value       --要写入的键值
'*返回参数：
'*      返回写值结果（是否成功）
'****************************************************
Public Function SetIni(FileName As String, _
                       section As String, _
                       key As String, _
                       Value As String) _
    As Boolean
    
    Dim l       As Long

    l = WritePrivateProfileString(section, key, Value, FileName)
    SetIni = IIf(l = 0, False, True)
    
End Function

Public Function fmtTxtData(txt As TextBox, _
                           decimalnumber As Integer, _
                           Max As Double, _
                           Min As Double) _
    As Boolean
    
    On Error GoTo err_proc
    Dim i As Double
    
    If Not IsNumeric(txt.text) Then
        GoTo err_proc
    End If
    
    i = CDbl(txt.text)
    
    If i > Max Or i < Min Then
        GoTo err_proc
    End If
    
    Dim mText   As New clsText
    
    With mText
        .stringX = txt.text
        .fieldtype = tyNumeric
        .decimalnumber = decimalnumber
        txt.text = .GetStr
    End With
    
    If txt.tag <> txt.text Then
        fmtTxtData = True
    Else
        fmtTxtData = False
    End If
    
    txt.tag = txt.text
    
    Exit Function
    
err_proc:
    On Error Resume Next
    txt.text = txt.tag
End Function

Public Sub InitText(txt As TextBox, decimalnumber As Integer)
    
    On Error Resume Next

    Dim mText   As clsText
    Set mText = New clsText
    With mText
        .stringX = txt.text
        .fieldtype = tyNumeric
        .showzero = True
        .decimalnumber = decimalnumber
        txt.text = .GetStr
    End With
    txt.tag = txt.text
    
    Set mText = Nothing
End Sub