mainmodule.bas

针对农资系统的商品进销存管理系统软件

Attribute VB_Name = "MainModule"
Option Explicit
Public Const SYSTEM_SECTION = "SystemInfo"

'///////////////////////////////////////////
'//StockUp表中FType定义:
Public Const STOCKUP_INVOICE = 0        '购进单
Public Const INFORMAL_INVOICE = 1       '估进单
Public Const RETURN_INVOICE = 2         '进货退还单

'///////////////////////////////////////////
'//WaresIn表中FType定义:
Public Const INIT_INVOICE = 0           '期初库存
Public Const IN_INVOICE = 1             '验收入库单
Public Const SURROGATE_INVOICE = 2      '代管入库单
Public Const WASTAGE_INVOICE = 3        '盘点单
Public Const BACK_INVOICE = 4           '商品退还单

'///////////////////////////////////////////
'//Warehouse表中FHouseAttrib定义:
Public Const INNER_HOUSE = 0            '内库
Public Const OUTER_HOUSE = 1            '外库

'///////////////////////////////////////////
'//Sell表中FType定义:
Public Const SELL_INVOICE = 0           '销售单
Public Const SELFUSE_INVOICE = 1        '领用单
Public Const REDSELL_INVOICE = 2        '销售退货单

'///////////////////////////////////////////
'//WaresOut表中FType定义:
Public Const OUT_SELL = 0               '出库单
Public Const OUT_OTHER = 1              '代管出库单
Public Const OUT_RED = 2                '退库单

'///////////////////////////////////////////
'//Depart表中FDepartAttrib定义:
Public Const COMPANY_DEPART = 0         '总公司
Public Const STOCKUP_SELL_DEPART = 1    '采购兼销售
Public Const STOCKUP_DEPART = 2         '采购
Public Const SELL_DEPART = 3            '销售
Public Const HOUSE_DEPART = 4           '库房

'///////////////////////////////////////////
'//WaresList表中FPriceMode定义:
Public Const FIFO_MODE = 0              '先进先出
Public Const WEIGHT_AVER_MODE = 1       '加权平均
Public Const MOVE_AVER_MODE = 2         '移动平均
Public Const LIFO_MODE = 3              '后进先出

'///////////////////////////////////////////
'//库存明细帐Ledger表中FFlag定义:
Public Const PREV_YEAR_CLOSE As Integer = 0     '上年结转
Public Const PREV_MONTH_CLOSE As Integer = 1    '上月结转

Public Const IN_HOUSE_DETAIL As Integer = 2     '入库明细
Public Const IN_WASTAGE_DETAIL As Integer = 3   '盘点溢损明细
Public Const IN_BACK_DETAIL As Integer = 4      '入库退还
Public Const OUT_HOUSE_DETAIL As Integer = 5    '出库明细
Public Const OUT_RETURN_DETAIL As Integer = 6   '出库退货

Public Const THIS_DAY_SUM As Integer = 13       '本日合计
Public Const THIS_MONTH_SUM As Integer = 14     '本月合计
Public Const THIS_SEASON_TOTAL As Integer = 15  '本季累计
Public Const THIS_YEAR_TOTAL As Integer = 16    '本年累计
Public Const THIS_SEASON_SUM As Integer = 17    '本季合计
Public Const THIS_YEAR_SUM As Integer = 18      '本年合计
Public Const CLOSE_NEXT_YEAR As Integer = 19    '结转下年

'///////////////////////////////////////////
'//选择商品
Public Const SELECT_DETAIL As Integer = 0       '选择商品明细
Public Const SELECT_TYPE As Integer = 1         '选择商品类别
Public Const SELECT_DETAIL_TYPE As Integer = 2  '选择商品明细或类别

'///////////////////////////////////////////
'//当前操作员级别定义:
Public Const SUPPER_MANAGER As Integer = 0      '系统主管
Public Const DEPART_MANAGER As Integer = 1      '部门主管
Public Const GENERAL_OPERATOR As Integer = 2    '普通操作员

'///////////////////////////////////////////
'//
Global m_gSeriesNum As Integer                  '商品代码总级数
Global m_gSeriesLen() As Integer                '商品代码级长数组
Global CHARGE_CODE As String                    '经营费用一级代码

'///////////////////////////////////////////
'//
Global m_gMainForm As frmMain
Global m_gsConnection As String
Global m_gDBCnn As ADODB.Connection
Global m_gsDBName As String
Global m_gsIniFile As String

Global m_sUnitName As String
Global m_gLoginDate As Date
Global m_gnYear As Integer
Global m_gbyMonth As Byte

Global m_gsDepartCode As String             '当前操作员所属部门
Global m_gnDepartAttrib As Integer          '当前操作员部门属性
Global m_gsOperator As String               '当前操作员姓名
Global m_gsPassword As String               '当前操作员口令
Global m_gnLevel As Integer                 '当前操作员级别

Global m_gnMoneyDecimal As Integer          '金额保留小数位数
Global m_gnPriceDecimal As Integer          '单价保留小数位数
Global m_gnQuantityDecimal As Integer       '数量保留小数位数

Global ShowRate As Single
Global m_gbSellMoney As Boolean             '贷方是否写销售金额

Sub Main()
    frmSplash.Show
    frmSplash.Refresh
    
    m_gsDBName = App.Path & "\Warehouse.mdb"
    m_gsConnection = "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source= " & m_gsDBName
    m_gsIniFile = App.Path & "\" & App.EXEName & ".INI"
    
    Set m_gDBCnn = New ADODB.Connection
    m_gDBCnn.ConnectionString = m_gsConnection
    m_gDBCnn.CursorLocation = adUseClient
    m_gDBCnn.Open
    Dim SystemRs As ADODB.Recordset
    Set SystemRs = New ADODB.Recordset
    With SystemRs
        .Open "Select * From System", m_gDBCnn
        If .EOF And .BOF Then
           DlgInit.Show vbModal
           If Not DlgInit.m_bOK Then
              End
           End If
           Unload DlgInit
       End If
    End With
    frmLogin.SetMeCaption = "系统登录"
    frmLogin.Show vbModal, frmSplash
    If Not frmLogin.OK Then
        End
    End If
    Unload frmLogin
    
    Dim bFirst As String
    bFirst = GetPrivateSetting(SYSTEM_SECTION, "FirstRun", "")
    If UCase(bFirst) <> UCase("False") Then
        SavePrivateSetting SYSTEM_SECTION, "FirstRun", "FALSE"
        frmSeriesDef.Show vbModal
    End If
    '初始商品代码级数和级长
    InitSeries
    
    Set m_gMainForm = New frmMain
    Load m_gMainForm
    m_gMainForm.Show
    
    ShowRate = 1#
    m_gbSellMoney = GetPrivateSetting(SYSTEM_SECTION, "SellMoney", "False")
    Unload frmSplash
End Sub
    
Private Sub InitSeries()
    Dim rst As ADODB.Recordset
    Dim i As Integer
    
    Set rst = New ADODB.Recordset
    rst.Open "select FseriesNum, FSeriesLength From Seriesdef", m_gDBCnn, adOpenStatic, adLockReadOnly
    
    If Not (rst.EOF And rst.BOF) Then
        rst.MoveLast
        m_gSeriesNum = rst.RecordCount
        rst.MoveFirst
        ReDim m_gSeriesLen(m_gSeriesNum)
        i = 0
        
        Do While Not rst.EOF
            m_gSeriesLen(i) = rst![FSeriesLength]
            i = i + 1
            rst.MoveNext
        Loop
        CHARGE_CODE = String(m_gSeriesLen(0), "A")
    Else
        MsgBox "级数表有误,请与维护人员联系", vbOKOnly + vbExclamation, "提示:"
    End If
    rst.Close
    
    m_gnMoneyDecimal = GetPrivateSetting(SYSTEM_SECTION, "MoneyDecimal", 2)
    m_gnPriceDecimal = GetPrivateSetting(SYSTEM_SECTION, "PriceDecimal", 2)
    m_gnQuantityDecimal = GetPrivateSetting(SYSTEM_SECTION, "QuantityDecimal", 2)
End Sub
'/////////////////////////////////////////////////
'//
Public Function GetDepartFunctionField() As String
    Dim sField As String
    
    Select Case m_gnDepartAttrib
        Case COMPANY_DEPART
            sField = "FCompanyItem"
        Case STOCKUP_SELL_DEPART
            sField = "FStockupSellItem"
        Case STOCKUP_DEPART
            sField = "FStockupItem"
        Case SELL_DEPART
            sField = "FSellItem"
        Case HOUSE_DEPART
            sField = "FHouseItem"
        Case Else       '超级主管登录(部门代码='', 部门属性=-1)
            sField = "FSupperItem"
    End Select
    GetDepartFunctionField = sField
End Function

Public Function GetLastVisibleCol(Grd As DataGrid) As Integer
    Dim i As Integer
    With Grd
        For i = .Columns.Count - 1 To 0 Step -1
            If .Columns(i).Visible And .Columns(i).Width >= 61 And Not .Columns(i).Locked Then
                GetLastVisibleCol = i
                Exit Function
            End If
        Next
    End With
    GetLastVisibleCol = -1
End Function

Public Function RsIsEmpty(sSqlStr As String) As Boolean
    Dim TempRs As ADODB.Recordset
    Set TempRs = New ADODB.Recordset
    TempRs.Open sSqlStr, m_gDBCnn
    
    With TempRs
        If .EOF And .BOF Then
            RsIsEmpty = True
        Else
            RsIsEmpty = False
        End If
    End With
    Set TempRs = Nothing
End Function

'////////////////////////////////////////////////////////////////////
'//FindRs为与DataGrid绑定记录集的复制, 且尚未对当前记录执行Update!
Public Function FieldIsRepeat(FindRs As ADODB.Recordset, sFindStr As String) As Boolean
    With FindRs
        If .RecordCount = 1 Then
            FieldIsRepeat = False
        Else
            ' 新创建副本的当前记录将设置为首记录。
            .Find sFindStr
            If .EOF Then
                FieldIsRepeat = False
            Else
                FieldIsRepeat = True
            End If
        End If
    End With
    Set FindRs = Nothing
End Function

'//////////////////////////////////////////////////////////
'//SQL格式: Select Max(KeyField) From TableName Where ...
'//若返回空串, 则表示数据宽度已超出有效范围
Public Function GetNewInvoiceNo(sSqlStr As String, nKeyIndex As Integer) As String
    Dim TempRs As ADODB.Recordset
    Dim sNo As String, nLen As Integer
    
    Set TempRs = New ADODB.Recordset
    TempRs.Open sSqlStr, m_gDBCnn
    
    With TempRs
        If IsNull(.Fields(nKeyIndex).Value) Then
            sNo = "1"
        Else
            sNo = Trim(Str(Val(.Fields(nKeyIndex).Value) + 1))
        End If
        
        'nLen = .Fields(nKeyIndex).DefinedSize - Len(sNo)
        nLen = 10 - Len(sNo)
        If nLen < 0 Then
            GetNewInvoiceNo = ""
        Else
            GetNewInvoiceNo = String(nLen, "0") & sNo
        End If
    End With
    Set TempRs = Nothing
End Function

'//////////////////////////////////////////////////////////
'//SQL格式: Select Max(KeyField) From TableName Where ...
Public Function GetNewIndex(sSqlStr As String, nKeyIndex As Integer) As Long
    Dim TempRs As ADODB.Recordset
    Dim nIndex As Long
    
    Set TempRs = New ADODB.Recordset
    TempRs.Open sSqlStr, m_gDBCnn
    
    With TempRs
        If IsNull(.Fields(nKeyIndex).Value) Then
            nIndex = 0
        Else
            nIndex = .Fields(nKeyIndex).Value + 1
        End If
        
        GetNewIndex = nIndex
    End With
    Set TempRs = Nothing
End Function

Public Function GetSelectWaresCode(sFilter As String, Optional ByRef bSelectWares As Boolean, Optional nType As Integer = SELECT_DETAIL) As String
    bSelectWares = True
    Dim f As frmSelectWares
    Set f = New frmSelectWares
    f.SqlFilter(sFilter) = nType
    f.Show vbModal
    GetSelectWaresCode = f.SelectWaresCode
    Unload f
    bSelectWares = False
End Function

'////////////////////////////////////////////
'//金额、单价、数量格式串
Private Function GetNumericFromat(nDecimal As Integer) As String
    GetNumericFromat = "#########0" & IIf(nDecimal = 0, "", "." & String(nDecimal, "0"))
End Function

Public Function MoneyFormat() As String
    MoneyFormat = GetNumericFromat(m_gnMoneyDecimal)
End Function

Public Function PriceFormat() As String
    PriceFormat = GetNumericFromat(m_gnPriceDecimal)
End Function

Public Function QuantityFormat() As String
    QuantityFormat = GetNumericFromat(m_gnQuantityDecimal)
End Function

'/////////////////////////////////////////////////
'//
Public Sub FindRecord(ByRef AdoRs As ADODB.Recordset, sNo As String)
    Dim nRet As Integer