modbase.bas

通用书店管理系统

'          如果能查询到则为入库类型名称；否则为" "
'--------------------------------------------------------------------------------
Public Function GetInStorageName(ByVal strInStorageNo As String) As String
    Dim rst As New ADODB.Recordset
    On Error GoTo error_GetInStorageName
    GetInStorageName = ""
    If Trim(strInStorageNo) = "" Then Exit Function
    strSQL = "select ChrInStorageName from InStorageType where ChrInStorageNo ='" & Trim(strInStorageNo) & "'"
    Set rst = cN.Execute(strSQL)
    If rst.Recordcount <> 0 Then
       GetInStorageName = Trim(rst!ChrInStorageName)
    Else
       MsgBox "入库类型表中不存在该入库类型名称，确认输入是否有错", vbOKOnly, "错误"
    End If
    Exit Function
error_GetInStorageName:
   MsgBox err.Description
End Function

'--------------------------------------------------------------------------------
'功能：    根据“入库类型名称”得到相应的“入库类型编码”
'参数说明：
'          strInStorageName   入库类型名称
'返回值：  (string)
'          如果能查询到则为入库类型编码；否则为" "
'--------------------------------------------------------------------------------
Public Function GetInStorageNo(ByVal strInStorageName As String) As String
    Dim rst As New ADODB.Recordset
    On Error GoTo error_GetInStorageNo
    GetInStorageNo = ""
    If Trim(strInStorageName) = "" Then Exit Function
    strSQL = "select ChrInStorageNo from InStorageType where ChrInStorageName ='" & Trim(strInStorageName) & "'"
    Set rst = cN.Execute(strSQL)
    If rst.Recordcount <> 0 Then
       GetInStorageNo = Trim(rst!ChrInStorageNo)
    Else
       MsgBox "入库类型表中不存在该入库类型编码，确认输入是否有错", vbOKOnly, "错误"
    End If
    Exit Function
error_GetInStorageNo:
   MsgBox err.Description
End Function

'功能：    根据“出库类型编码”得到相应的“出库类型名称”
'参数说明：
'          strOutStorageNo   出库类型编码
'返回值：  (string)
'          如果能查询到则为出库类型名称；否则为" "
'--------------------------------------------------------------------------------
Public Function GetOutStorageName(ByVal strOutStorageNo As String) As String
    Dim rst As New ADODB.Recordset
    On Error GoTo error_GetOutStorageName
    GetOutStorageName = ""
    If Trim(strOutStorageNo) = "" Then Exit Function
    strSQL = "select ChrOutStorageName from OutStorageType where ChrOutStorageNo ='" & Trim(strOutStorageNo) & "'"
    Set rst = cN.Execute(strSQL)
    If rst.Recordcount <> 0 Then
       GetOutStorageName = Trim(rst!ChrOutStorageName)
    Else
       MsgBox "出库类型表中不存在该出库类型名称，确认输入是否有错", vbOKOnly, "错误"
    End If
    Exit Function
error_GetOutStorageName:
   MsgBox err.Description
End Function

'--------------------------------------------------------------------------------
'功能：    根据“出库类型名称”得到相应的“出库类型编码”
'参数说明：
'          strOutStorageName   出库类型名称
'返回值：  (string)
'          如果能查询到则为出库类型编码；否则为" "
'--------------------------------------------------------------------------------
Public Function GetOutStorageNo(ByVal strOutStorageName As String) As String
    Dim rst As New ADODB.Recordset
    On Error GoTo error_GetOutStorageNo
    GetOutStorageNo = ""
    If Trim(strOutStorageName) = "" Then Exit Function
    strSQL = "select ChrOutStorageNo from OutStorageType where ChrOutStorageName ='" & Trim(strOutStorageName) & "'"
    Set rst = cN.Execute(strSQL)
    If rst.Recordcount <> 0 Then
       GetOutStorageNo = Trim(rst!ChrOutStorageNo)
    Else
       MsgBox "出库类型表中不存在该出库类型编码，确认输入是否有错", vbOKOnly, "错误"
    End If
    Exit Function
error_GetOutStorageNo:
   MsgBox err.Description
End Function


'功能：    根据“有效期”得到相应的“月数”
'参数说明：
'          strYXQ   有效期
'返回值：  (integer)
'          如果能查询到则为月数；否则为0
'--------------------------------------------------------------------------------
Public Function GetAvailability(ByVal strYXQ As String) As Integer
    Dim rst As New ADODB.Recordset
    On Error GoTo error_GetAvailability
    GetAvailability = 0
    If Trim(strYXQ) = "" Then Exit Function
    strSQL = "select intMonth from MemberAvailability where chrYXQ ='" & strYXQ & "'"
    Set rst = cN.Execute(strSQL)
    If rst.Recordcount <> 0 Then
       GetAvailability = Trim(rst!intMonth)
    Else
       MsgBox "有效期表中不存在该有效期名称，确认输入是否有错", vbOKOnly, "错误"
    End If
    Exit Function
error_GetAvailability:
   MsgBox err.Description
End Function


'--------------------------------------------------------------------------------
'名称：g_CommonSelect

'目的：在后台传入查询SQL语句，在屏幕前台显示结果窗口，供用户浏览，并能返回选项（到后台）
'假设：后台传入的SQL语句合法，各表列头与表字段能一一匹配
'效果：在屏幕前台显示结果窗口，用户可在结果窗口进行分组、排序、查找等操作，以快速地确定返回值，并返回结果
'输入参数：
'           strHeader       表单列头，用“|”隔开，空格有效
'           strQrySQL       查询SQL语句
'           strReturnCols   指定返回列内容,用逗号“，”隔开
'           strDateField    日期字段，如果需要用户进行日期交互，则把日期条件字段赋给该变量
'           strStartDate    日期交互起始日期；结束日期=DateAdd(strInterval,dblAddNumber,strStartDate)
'           strInterval     日期间隔：
'                            yyyy       年
'                            q          季
'                            m          月
'                            y          一年的日数
'                            d          日
'                            w          一周的日数
'                            ww         周
'                            h          时
'                            n          分钟
'                            s          秒
'           dblAddNumber    要加上的时间间隔的数目。其数值可以为正数（得到未来的日期），也可以为负数（得到过去的日期）。
'默认值：
'       intReturnCols="0"      返回第一列内容；如果要返回所有列请输入"-1"
'       strDateField=""        不需要日期交互
'       strStartDate=Date       当前日期
'       strInterval="d"         以日为单位
'       dblAddNumber            7,表示一周
'输出参数：
'           arrReturn       当需返回多列或多行内容时，使用该参数，直接返回用户所选行列（即数组）
'函数返回值：
'           Variant         当且仅当返回某一行的指定列数据时使用，该变量即为返回值内容
'创建时间：2002.1.3；作者：Activeer

'**注意：带窗体,frmCommonSelectDateInput,frmCommonSelectResult,窗体颜色自配

'特例：
'   Set gconsys = New ADODB.Connection
'    With gconsys
'        .ConnectionString = "Provider=SQLOLEDB.1;Persist Security Info=False;User ID=sa;Initial Catalog=gh;Data Source=ghdbServer"
'        .CursorLocation = adUseClient
'        .Open
'    End With

'1.  查询物料，返回单一编码
'    Dim strItem
'
'    strItem = g_CommonSelect("    物料编码  |   物料名称 |  型号规格  |     厂家信息      ", _
'                   "Select top 100 chrItemID,chrItemName,chrSpec,chrDescription from tm_Item ")
'
'2.  查询工单，返回用户选项（支持多项），需用户日期交互，间隔为一个月
'    Dim arr
'    Call g_CommonSelect("   生产批号  |  型号规格  |   介质类型  |  端浆  |  内浆  |  设计日期   ", _
'               "Select chrBatchID,chrType,chrPowder,chrPortPlasm,chrInnerPlasm,datList From tp_carCraft ", _
'               "1,3,5", _
'               "datList", _
'               "2001-10-05", _
'               "m", _
'               -1, _
'               arr)
'--------------------------------------------------------------------------------

Public Function g_CommonSelect(strHeader As String, _
                strQrySQL As String, _
                Optional strReturnCols As String = "0", _
                Optional strDateField As String = "", _
                Optional strStartDate As String = "", _
                Optional strInterval As String = "d", _
                Optional dblAddNumber As Double = -7, _
                Optional ByRef arrReturn As Variant) As Variant
    
    On Error GoTo err
    If Trim(strHeader) = "" Then GoTo err
    If Trim(strStartDate) = "" Then strStartDate = Date
    
    If strDateField <> "" Then
        Dim dlg As New frmCommonSelectDateInput
        With dlg
            If dblAddNumber > 0 Then
                .dtpFields(0).Value = Format(strStartDate, "yyyy-MM-dd")
                .dtpFields(1).Value = DateAdd(strInterval, dblAddNumber, .dtpFields(0).Value)
            Else
                .dtpFields(1).Value = Format(strStartDate, "yyyy-MM-dd")
                .dtpFields(0).Value = DateAdd(strInterval, dblAddNumber, .dtpFields(1).Value)
            End If
            .Show vbModal
        End With
        
        If dlg.blnOK Then
            Dim intPos As Integer
            Dim strTemp As String
            strTemp = ""
            
            '如果有 order by 则截掉，待加入日期条件后在补上
            intPos = InStr(1, strQrySQL, " order ", vbTextCompare)
            If intPos > 0 Then
                strTemp = Mid(strQrySQL, intPos, Len(strQrySQL) - intPos + 1)  '存入order by部分
                strQrySQL = Mid(strQrySQL, 1, intPos - 1)
            End If
            
            '加入日期条件
            If InStr(1, strQrySQL, " where ", vbTextCompare) > 1 Then
                strQrySQL = strQrySQL & " and convert(char(10)," & strDateField & ",121) between '" & Format(dlg.DatBegin, "yyyy-mm-dd") & "' and '" & Format(dlg.datEnd, "yyyy-mm-dd") & "'"
            Else
                strQrySQL = strQrySQL & " where convert(char(10)," & strDateField & ",121) between '" & Format(dlg.DatBegin, "yyyy-mm-dd") & "' and '" & Format(dlg.datEnd, "yyyy-mm-dd") & "'"
            End If
            
            '如果有order by则补上
            strQrySQL = strQrySQL & strTemp
            
        Else
            Exit Function
        End If
    End If
      
    Dim frm As New frmCommonSelectResult
    With frm
        .strReturnCols = strReturnCols
        .strHeader = strHeader
        .strQrySQL = strQrySQL
        .Show vbModal
        
        If frm.blnOK Then
            arrReturn = .arrResult
            g_CommonSelect = .varQryResult
        End If
    End With
    
    Exit Function

err:
    MsgBox "调用通用选择失败！"
End Function

Public Function g_BookCommonSelect(strHeader As String, _
                strQrySQL As String, _
                Optional strReturnCols As String = "0", _
                Optional strDateField As String = "", _
                Optional strStartDate As String = "", _
                Optional strInterval As String = "d", _
                Optional dblAddNumber As Double = -7, _
                Optional ByRef arrReturn As Variant) As Variant
    
    On Error GoTo err
    If Trim(strHeader) = "" Then GoTo err
    If Trim(strStartDate) = "" Then strStartDate = Date
    
    If strDateField <> "" Then
        Dim dlg As New frmCommonSelectDateInput
        With dlg
            If dblAddNumber > 0 Then
                .dtpFields(0).Value = Format(strStartDate, "yyyy-MM-dd")
                .dtpFields(1).Value = DateAdd(strInterval, dblAddNumber, .dtpFields(0).Value)
            Else
                .dtpFields(1).Value = Format(strStartDate, "yyyy-MM-dd")
                .dtpFields(0).Value = DateAdd(strInterval, dblAddNumber, .dtpFields(1).Value)
            End If
            .Show vbModal
        End With
        
        If dlg.blnOK Then
            Dim intPos As Integer
            Dim strTemp As String
            strTemp = ""
            
            '如果有 order by 则截掉，待加入日期条件后在补上
            intPos = InStr(1, strQrySQL, " order ", vbTextCompare)
            If intPos > 0 Then
                strTemp = Mid(strQrySQL, intPos, Len(strQrySQL) - intPos + 1)  '存入order by部分
                strQrySQL = Mid(strQrySQL, 1, intPos - 1)
            End If
            
            '加入日期条件
            If InStr(1, strQrySQL, " where ", vbTextCompare) > 1 Then
                strQrySQL = strQrySQL & " and convert(char(10)," & strDateField & ",121) between '" & Format(dlg.DatBegin, "yyyy-mm-dd") & "' and '" & Format(dlg.datEnd, "yyyy-mm-dd") & "'"
            Else
                strQrySQL = strQrySQL & " where convert(char(10)," & strDateField & ",121) between '" & Format(dlg.DatBegin, "yyyy-mm-dd") & "' and '" & Format(dlg.datEnd, "yyyy-mm-dd") & "'"
            End If
            
            '如果有order by则补上
            strQrySQL = strQrySQL & strTemp
            
        Else
            Exit Function
        End If
    End If
      
    Dim frm As New frmBookCommonSelectResult
    With frm
        .strReturnCols = strReturnCols
        .strHeader = strHeader
        .strQrySQL = strQrySQL
        .Show vbModal
        
        If frm.blnOK Then
            arrReturn = .arrResult
            g_BookCommonSelect = .varQryResult
        End If
    End With
    
    Exit Function

err:
    MsgBox "调用通用选择失败！"
End Function

'--------------------------------------------------------------------------------
'功能：    获取入库单、出库单、销售单等的某天最大单号

'参数说明：
'         chrFields        代表单号的列名
'         strTable         表名
'         strDate          日期

'返回值：  (string)
'          返回某天的最大单号
'--------------------------------------------------------------------------------