moddb.bas

网上销售源代码

Attribute VB_Name = "ModDB"
Option Explicit

Public 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
Public 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 SQLDB As ADODB.Connection    'SQLDatabase

Public Enum enmWhichTable
    StorageTypeTable = 1
    StorageAreatypeTable = 2
End Enum

'数据库中用到的常量
'起始错误号
Private Const StartErrNum = vbObjectError + 512 + 500
Public Const gAddErr = StartErrNum + 1
Public Const gEditErr = StartErrNum + 2
Public Const gDelErr = StartErrNum + 3
Public Const gQryErr = StartErrNum + 4
Public Const gCheckErr = StartErrNum + 5
Public Const gStopErr = StartErrNum + 6
Public Const gInputErr = StartErrNum + 7
Public Const gInitErr = StartErrNum + 8
Public Const gLoginErr = StartErrNum + 9
Public Const gAlertErr = StartErrNum + 10
Public Const gAuditErr = StartErrNum + 11
Public Const gCarryErr = StartErrNum + 12
' 此处定义用户自定义的错误，一定要使用错误号。
' 大于 512，要避免冲突使用 OLE 错误号。
Public Const MyObjectError1 = 1000
Public Const MyObjectError2 = 1010
Public Const MyObjectErrorN = 1234
Public Const MyUnhandledError = 9999

Public PubUserID As String  '用户名称
Public PubPass   As String  '用户密码
Public PubShop   As String  '哪个店柜

Function GetNextClassDebugID() As Long
    '类 ID 生成器
    Static lClassDebugID As Long
    lClassDebugID = lClassDebugID + 1
    GetNextClassDebugID = lClassDebugID
End Function

Public Sub RaiseError(ErrorNumber As Long, Source As String, Description As String, pOriginalErr As String)
      Dim strErrorText As String

      '提交错误返回到客户
      pOriginalErr = Err.Description
      Err.Raise vbObjectError + ErrorNumber, Source, Description
      
End Sub

Public Sub StatDB()
    Dim strUser As String
    Dim strPassword As String
    Dim strDatabase As String
    Dim strServer As String
    Dim strFile As String
    Dim Ret As Long
    
On Error GoTo ErrHandler
    strFile = App.Path & "\ini\Logistics.ini"
    strUser = String(100, " ")
    strPassword = String(100, " ")
    strDatabase = String(100, " ")
    strServer = String(100, " ")
    
    If Dir(strFile) <> "" Then
       Ret = GetPrivateProfileString("database", "user", "", strUser, 20, strFile)
       Ret = GetPrivateProfileString("database", "password", "", strPassword, 20, strFile)
       Ret = GetPrivateProfileString("base", "data", "", strDatabase, 20, strFile)
       Ret = GetPrivateProfileString("base", "server", "", strServer, 20, strFile)
    End If
    
    strUser = Trim(unLockString(Replace(Trim(strUser), Chr(0), ""))) '清除空格,并去掉末尾的字符
    strPassword = Trim(unLockString(Replace(Trim(strPassword), Chr(0), "")))
    strServer = Replace(Trim(strServer), Chr(0), "")
    strDatabase = Replace(Trim(strDatabase), Chr(0), "")
    If strUser = "" Then
       strUser = "sa"
       strPassword = ""
    End If
    
    If Len(Trim(strDatabase)) = 0 Then
        strDatabase = "OnlineRetail"
    End If
    
    If Len(Trim(strServer)) = 0 Then
        strServer = "127.0.0.1"
    End If
    
    Set SQLDB = New ADODB.Connection
    
    SQLDB.CursorLocation = adUseClient
        SQLDB.ConnectionString = "driver={SQL Server};" & _
      "server=" & strServer & ";uid=" & strUser & ";pwd=" & strPassword & ";database=" & strDatabase & ""
'  SQLDB.ConnectionString = "driver={SQL Server};" & _
'      "server=127.0.0.1;uid=sa;pwd=;database=OnlineRetail"

    SQLDB.ConnectionTimeout = 30
    SQLDB.Open
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbInformation, "提示"
'    Err.Raise gInitErr, , "初始化出错！" & Err.Description
End Sub

Public Function IfNull(ByVal p_string As Variant)
    IfNull = IIf(IsNull(p_string), "", p_string)
End Function

'公用函数
Public Function ConvertStr(p_var As Variant) As String
    ConvertStr = IIf(IsNull(p_var), "", p_var)
End Function

Public Function ConvertDtm(p_var As Variant) As Date
    ConvertDtm = IIf(IsNull(p_var), "00:00", p_var)
End Function

Public Function ConvertNum(p_var As Variant) As Integer
    ConvertNum = IIf(IsNull(p_var), 0, p_var)
End Function

'获取插入注册表的sql语句
'pLogContent为"xx业务增加(或修改 删除)编号为xxx的单据"
'pLogType为日志类型,基本信息为2 业务单据为3
'pEmployeeID为操作人员
'在每个类中添加EmployeeID属性,EmployeeID在进行增删改操作时有应用程序传过来
'pEmployeeID有每各类中的EmployeeID属性传过来
Function GetLogSql(pLogContent As String, pLogType As String, pEmployeeID As String)
   
   GetLogSql = "Insert into sysLog(LogNo,LogContent,Operator,OperateTime,LogTypeID) values( dbo.Fn_CreateLogNo (),'" & _
   pLogContent & "','" & pEmployeeID & "',getdate(),'" & pLogType & "')"

End Function

Function unLockString(str As String) As String
    Dim strBack As String
    Dim intCount As Integer
    Dim i As Integer
    strBack = ""
    For i = 1 To Len(str)
        If (i Mod 2) = 0 Then
            intCount = Asc(Mid(str, i, 1)) - i
            strBack = strBack & Chr(intCount)
        Else
            intCount = Asc(Mid(str, i, 1)) + i
            strBack = strBack & Chr(intCount)
        End If
    Next
    unLockString = strBack
End Function

Public Function CreateNextNo(p_strTable As String, p_StrID As String) As String
    On Error GoTo ErrHandler
        Dim AdoCmd As New ADODB.Command
        Dim pa As ADODB.Parameter, pa1 As ADODB.Parameter, pa2 As ADODB.Parameter, pa3 As ADODB.Parameter
        AdoCmd.ActiveConnection = SQLDB
    
        
        Set pa1 = AdoCmd.CreateParameter("p_TableName", adVarChar, adParamInput, 20, p_strTable)
        AdoCmd.Parameters.Append pa1
        Set pa2 = AdoCmd.CreateParameter("p_TableID", adVarChar, adParamInput, 20, p_StrID)
        AdoCmd.Parameters.Append pa2
        Set pa = AdoCmd.CreateParameter("p_return", adVarChar, adParamOutput, 20)
        AdoCmd.Parameters.Append pa
        AdoCmd.CommandType = adCmdStoredProc
        AdoCmd.CommandText = "sp_BusiNo"
        AdoCmd.Execute
        
        CreateNextNo = Trim(pa.Value)
        
        Exit Function
ErrHandler:
        Err.Raise gQryErr, , "生成单号处错!" & vbCrLf & Err.Description
End Function

'将SQL语句中的空字符串转换为Null,避免外键冲突
Public Function SpaceToNull(pStrSQL As String) As String
     
    SpaceToNull = Replace(pStrSQL, "''", "null")
    
End Function

'根据表的字段名取得对应的中文显示名称
'参数FieldName是以","分隔的字符串
Public Function gGetColName(ByVal FieldName As String, ByVal TableName As String) As String
    Dim strFieldName() As String
    Dim rstTable As Recordset
    Dim i As Integer
    
    If Trim(FieldName) = "*" Then
        Set rstTable = SQLDB.Execute("SELECT TOP 1 * FROM " & TableName)
        ReDim strFieldName(rstTable.Fields.Count - 1)
        For i = 0 To rstTable.Fields.Count - 1
            strFieldName(i) = rstTable.Fields(i).Name
        Next
    Else
        strFieldName = Split(FieldName, ",")
    End If
    gGetColName = Join(strFieldName, ",")     '测试用----------------------
    '----------------------------------------------------------
End Function

'取一个表的所有记录, 带分页的, 一般按时间先后排序
Public Function gGetTableRst(ByVal FieldName As String, _
                            ByVal TableName As String, _
                            ByVal PageSize As Integer, _
                            ByVal CurPage As Integer, _
                            Optional ByVal OrderBy As String) As Recordset
                            
    Dim strSQL As String
    Dim rstTable As New Recordset
    
    strSQL = "SELECT " & FieldName & " FROM " & TableName
    If Trim(OrderBy) <> "" Then
        strSQL = strSQL & " ORDER BY " & OrderBy
    End If
    rstTable.CursorLocation = adUseClient
    rstTable.Open strSQL, SQLDB, adOpenStatic, adLockReadOnly
    rstTable.PageSize = PageSize
    rstTable.AbsolutePage = CurPage
    
    Set gGetTableRst = rstTable
    
End Function

Public Function RegID() As Integer
Dim SQL As String
Dim ARS As New ADODB.Recordset

SQL = "Select Type from a"
Set ARS = SQLDB.Execute(SQL)
    If Not ARS.EOF Then
        RegID = ARS("Type")
    Else
        RegID = 0
    End If
End Function