pubmodule.bas

便利店管理系统 VB+ACCESS 附上数据库和源码

Attribute VB_Name = "pubModule"
Option Explicit
'公共部分
Public iniFile As String '配置文件
Public shopName, shopAddress, shopTel, shopIntro As String
Public dbPSW As String  '= "!@#$%^&*()"

Public curLang As String '当前语言
Public curSystemUser As SystemUser
'frm0001/2使用
Public cuPayMoney As PayMoney '当前销售金额
Public curProvider As New cProvider
Public curCustomer As New cCustomer
Public curStorage As New cStorage
Public curImExPort As New cImExPort


'常用的三种颜色
Public Const colBLUE = &HFFFFC0
Public Const colGREEN = &HC0FFC0
Public Const colYELLOW = &HC0FFFF


'emial和主页链接
Public Declare Function ShellExecute Lib "Shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
'读ini
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, lpKeyName As Any, ByVal lpDefault As String, ByVal lpRetunedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
'写ini
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lplFileName As String) As Long
'求字符串实际位长度
Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
'MD5加密字串
Public Declare Function MDString Lib "md5.dll" (ByVal lpChars As String, ByVal lpCharsLen As Integer) As String
'取硬盘序列号
Public Declare Function HDSerialNumRead Lib "HDSerialNumRead.dll" () As String

Public Function GetFromINI(AppName As String, KeyName As String, FileName As String) As String
   Dim RetStr As String
   RetStr = String(255, Chr(0))
   GetFromINI = Left(RetStr, GetPrivateProfileString(AppName, ByVal KeyName, "", RetStr, Len(RetStr), FileName))
End Function

Public Function SetUpINI(AppName As String, KeyName As String, KeyValue As String, FileName As String) As Long
   SetUpINI = WritePrivateProfileString(AppName, KeyName, KeyValue, FileName)
End Function

Public Function TestText(testString As String) As Boolean
    If Len(testString & "") > 0 Then
        TestText = True
    Else
        TestText = False
    End If
End Function

Public Sub openDataBase()
On Error GoTo errHandler
    myDE.conData.Open
    myDE.rsrsAppMenu.Open
    myDE.rsrsResourceCE.Open
    myDE.rsrsSystemUser.Open
    myDE.rsrsImPortRP.Open
    myDE.rsrsExPortRP.Open
    myDE.rsrsOtherStorageChangeRP.Open
    myDE.rsrsStorage.Open
Exit Sub
errHandler:
    MsgBox "openDataBase, Err Number:" & Err.Number & "; Source:" & Err.Source & "; Description:" & Err.Description
End Sub

Public Sub closeDataBase()
On Error GoTo errHandler
    myDE.rsrsStorage.Close
    myDE.rsrsOtherStorageChangeRP.Close
    myDE.rsrsExPortRP.Close
    myDE.rsrsImPortRP.Close
    myDE.rsrsSystemUser.Close
    myDE.rsrsResourceCE.Close
    myDE.rsrsAppMenu.Close
    myDE.conData.Close
    
    'DBEngine.RepairDatabase App.Path & "\data.mdb"
    
    'DBEngine.CompactDatabase App.Path & "\data.mdb", App.Path & "\data888.mdb", , , "pwd=" & dbPSW
Exit Sub
errHandler:
    MsgBox "closeDataBase, Err Number:" & Err.Number & "; Source:" & Err.Source & "; Description:" & Err.Description
End Sub

Private Function CheckCopyRight() As Integer
'检查是否正版
    Dim hdSerialNum, accreditNum As String
    Dim sTemp1, sTemp2 As String
    hdSerialNum = HDSerialNumRead()
    sTemp1 = MDString("wtc", 6) 'MDString(hdSerialNum, lstrlen(hdSerialNum))
    Debug.Print hdSerialNum & "|" & lstrlen(hdSerialNum) & "|" & sTemp1
End Function

Public Sub Main() '系统启动函数
On Error GoTo errDelWith
    Call CheckCopyRight
    
    '数据库密码
    dbPSW = Chr$(94) & Chr$(1) & Chr$(7) & Chr$(5) & Chr$(4) & Chr$(3) & Chr$(6) & Chr$(2) & Chr$(95)
    
    frmMain.Show 0
    
    Call openDataBase
    
    iniFile = App.Path & "\baseinfo.ini"
    shopName = GetFromINI("baseinfo", "name", iniFile)
    shopAddress = GetFromINI("baseinfo", "address", iniFile)
    shopTel = GetFromINI("baseinfo", "tel", iniFile)
    shopIntro = GetFromINI("baseinfo", "intro", iniFile)
    curLang = GetFromINI("baseinfo", "language", iniFile)
    'Debug.Print StrConv(shopAddress, vbFromUnicode) & "|"
    'Debug.Print Asc(Mid(shopAddress, 3, 1))
    
    Load MDIFormMain
    'MDIFormMain.Hide
    
    Unload frmMain
    'MDIFormMain.Show
    frmLogin.Show 0
    frmLogin.ZOrder 0

errExit:
    Exit Sub
errDelWith:
    MsgBox "Main, Err Number:" & Err.Number & "; Source:" & Err.Source & "; Description:" & Err.Description
    Call ShutDownSystem(True)
    Resume errExit
End Sub

Public Sub ShutDownSystem(ByVal flagDB As Boolean)  '系统关闭函数
On Error GoTo errDelWith
    If flagDB Then
        Call closeDataBase
    End If
    
errExit:
    End
    Exit Sub
errDelWith:
    MsgBox "ShutDownSystem, Err Number:" & Err.Number & "; Source:" & Err.Source & "; Description:" & Err.Description
    Resume errExit
End Sub

Public Sub msgTakeEffect()
'提示系统设置下次效
    MsgBox getResource("resMsgF0000001"), vbInformation + vbOKOnly
End Sub

Public Function ImExPortAddNew(iImExPort As cImExPort) As Boolean
Dim sql As String
On Error GoTo errDelWith
    With iImExPort
    sql = "INSERT INTO ImExPort ( pcID, Bill, sID, Price, Amount, opDate, kind, flag, Operator, Remark ) " & _
          "VALUES(" & _
          "'" & .pcID & "'," & _
          "'" & .ieBill & "'," & _
          "'" & .sID & "'," & _
          "'" & .iePrice & "'," & _
          "'" & .ieAmount & "'," & _
          "'" & .ieOpDate & "'," & _
          "'" & .iekind & "'," & _
          "'" & .ieFlag & "'," & _
          "'" & .ieOperator & "'," & _
          "'" & .ieRemark & "'" & _
          ")"
    End With
    
    Debug.Print sql
    
    myDE.conData.Execute sql
    
    ImExPortAddNew = True
errExit:
    Exit Function
errDelWith:
    MsgBox Err.Description, vbCritical + vbOKOnly
    ImExPortAddNew = False
    Resume errExit
End Function

Public Function ImExPortUpdate(iImExPort As cImExPort, Optional sCondition As String = "1=1") As Boolean
Dim sql As String
On Error GoTo errDelWith
    With iImExPort
    sql = "UPDATE ImExPort SET " & _
        " pcID  ='" & .pcID & "'," & _
        " Bill  ='" & .ieBill & "'," & _
        " sID  = '" & .sID & "'," & _
        " Price  = '" & .iePrice & "'," & _
        " Amount  =  '" & .ieAmount & "'," & _
        " opDate  =  '" & .ieOpDate & "'," & _
        " kind   = '" & .iekind & "'," & _
        " flag  = '" & .ieFlag & "'," & _
        " Operator   = '" & .ieOperator & "'," & _
        " Remark  = '" & .ieRemark & "'" & _
        " WHERE ID=" & .ieID & " AND " & sCondition
    End With
    myDE.conData.Execute sql
    
    ImExPortUpdate = True
errExit:
    Exit Function
errDelWith:
    MsgBox Err.Description, vbCritical + vbOKOnly
    ImExPortUpdate = False
    Resume errExit
End Function

Public Function RunSql(sSql As String) As Boolean
Dim sql As String
On Error GoTo errDelWith
    Debug.Print sSql
    myDE.conData.Execute sSql
    
    RunSql = True
errExit:
    Exit Function
errDelWith:
    MsgBox Err.Description, vbCritical + vbOKOnly
    RunSql = False
    Resume errExit
End Function

Public Function getResource(resourceID As String) As String
'取资源文件
    myDE.rsrsResourceCE.MoveFirst
    myDE.rsrsResourceCE.Find "ResourceID='" & resourceID & "'"
    If myDE.rsrsResourceCE.EOF Then
        getResource = ""
    Else
        getResource = Trim(myDE.rsrsResourceCE.Fields("Resource" & curLang).Value & "")
    End If
End Function

Public Function getFormCaptionResource(menuCode As String) As String
'取资源文件
    myDE.rsrsAppMenu.MoveFirst
    myDE.rsrsAppMenu.Find "MenuCode='" & menuCode & "'"
    If myDE.rsrsAppMenu.EOF Then
        getFormCaptionResource = ""
    Else
        getFormCaptionResource = Trim(myDE.rsrsAppMenu.Fields("MenuCaption" & curLang & "n").Value & "")
    End If
End Function