frmmain.frm

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

      Begin VB.Menu mnuRollBackMonthEnd 
         Caption         =   "退回月结"
      End
      Begin VB.Menu mnuTiaoHu 
         Caption         =   "调户"
      End
      Begin VB.Menu mnuEditPrice 
         Caption         =   "修改结存"
      End
      Begin VB.Menu mnuSumHouseMoney 
         Caption         =   "库房合计"
      End
      Begin VB.Menu mnuMixiAccount 
         Caption         =   "商品明细分类帐"
      End
   End
   Begin VB.Menu mnuWindow 
      Caption         =   "窗口(&W)"
      WindowList      =   -1  'True
      Begin VB.Menu mnuWindowCascade 
         Caption         =   "层叠(&C)"
      End
      Begin VB.Menu mnuWindowTileHorizontal 
         Caption         =   "横向平铺(&H)"
      End
      Begin VB.Menu mnuWindowTileVertical 
         Caption         =   "纵向平铺(&V)"
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助(&H)"
      Begin VB.Menu mnuHelpContents 
         Caption         =   "目录(&C)"
      End
      Begin VB.Menu mnuHelpSearchForHelpOn 
         Caption         =   "索引(&I)..."
      End
      Begin VB.Menu mnuHelpBar0 
         Caption         =   "-"
      End
      Begin VB.Menu mnuHelpAbout 
         Caption         =   "关于(&A) "
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function htmlhelp Lib "hhctrl.ocx" Alias "HtmlHelpA" (ByVal hwndcaller As Long, ByVal pszfile As String, ByVal ucommand As Long, ByVal dwdata As Long) As Long
Private Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hwnd&, ByVal HelpFile$, ByVal wCommand%, dwdata As Any)

'/////////////////////////////////////////////////////
'//单据处理
Dim frmStockUpInvoice As frmStockUp     '购进单
Dim frmInformalInvoice As frmStockUp    '估进单
Dim frmStockUpReturn As frmStockUp      '进货退还单
'//
Dim frmWaresIn As frmIn                 '验收入库单
Dim frmWaresSurrogate As frmIn          '代管入库单
Dim frmWaresWastage As frmIn            '盘点单
Dim frmWaresBack As frmIn               '商品退还单
'//
Dim frmWaresSellBill As frmWaresSell    '销售单
Dim frmWaresSelfUse As frmWaresSell     '领用单
Dim frmWaresRedSell As frmWaresSell     '销售退货单

Dim frmWaresOut As frmOut               '出库单
Dim frmwaresOutRed  As frmOut           '退库单
Dim frmWaresOutOther As frmOut          '代管出库单

'//////////////////////////////////////////////////////
'//查询统计
Dim fStockUpCost As frmStockUpCost      '商品采购成本分析
Dim fUnderway As frmStockUpCost         '在途商品分析
'//
Dim frmStockListing As frmStockWares    '库存商品清单
Dim frmLackWares As frmStockWares       '库房短缺商品分析
Dim frmOverstock As frmStockWares       '库房超储商品分析
'//
Dim frmProfitAnalyze As frmAnalyze      '商品毛利分析
Dim frmNotPickUp As frmAnalyze          '成交待发商品
Dim frmIncomeAnalyze As frmAnalyze      '商品收入汇总分析

'//////////////////////////////////////////////////////
'//模块权限变量
Dim m_bEdit As Boolean                  '编辑权
Dim m_bAuditer As Boolean               '审核权
Dim m_bKeeper As Boolean                '记帐权

'//////////////////////////////////////////////////////
'//设置功能表
Private Sub SetFunction()
    Dim mnuObj As Object, nAffected As Integer
    
    For Each mnuObj In Me.Controls
        If TypeOf mnuObj Is Menu Then
            If InStr(1, mnuObj.Name, "mnuWindow") + InStr(1, mnuObj.Name, "mnuHelp") = 0 Then
                On Error Resume Next
                m_gDBCnn.Execute "Insert Into Function (FMenuName, FMenuDescribe) Values ('" & mnuObj.Name & "','" & mnuObj.Caption & "')", nAffected
                On Error GoTo 0
                If nAffected = 0 Then
                    m_gDBCnn.Execute "Update Function Set FMenuDescribe = '" & mnuObj.Caption & "' Where FMenuName = '" & mnuObj.Name & "'"
                End If
            End If
        End If
    Next
End Sub

'//////////////////////////////////////////////////////
'//
Private Sub InitToolBarAttribute()
    Dim mnuObj As Object, i As Integer
    Dim sMnuName As String
    
    With imlToolbarIcons
        For i = 1 To .ListImages.Count
            .ListImages(i).Key = UCase(.ListImages(i).Key)
        Next
    End With
    
    With tbToolBar
        .Buttons.Clear
        For Each mnuObj In Me.Controls
            If TypeOf mnuObj Is Menu Then
                If InStr(1, mnuObj.Name, "mnuWindow") + InStr(1, mnuObj.Name, "mnuHelp") = 0 Then
                    sMnuName = UCase(mnuObj.Name)
                    If FindIsToolButton(sMnuName) Then
                        .Buttons.Add , sMnuName
                        .Buttons(sMnuName).ToolTipText = mnuObj.Caption
                        .Buttons(sMnuName).Style = tbrDefault
                        .Buttons(sMnuName).Image = sMnuName
                    ElseIf .Buttons.Count > 0 Then
                        If .Buttons(.Buttons.Count).Style <> tbrSeparator Then
                            .Buttons.Add , sMnuName
                            .Buttons(sMnuName).Style = tbrSeparator
                        End If
                    End If
                End If
            End If
        Next
        If .Buttons.Count > 0 Then
            If .Buttons(.Buttons.Count).Style = tbrSeparator Then
                .Buttons.Remove (.Buttons.Count)
            End If
        End If
    End With
End Sub

Private Function FindIsToolButton(sKey As String) As Boolean
    Dim i As Integer
    FindIsToolButton = True
    With imlToolbarIcons
        For i = 1 To .ListImages.Count
            If .ListImages(i).Key = sKey Then
                Exit Function
            End If
        Next
    End With
    FindIsToolButton = False
End Function

'//////////////////////////////////////////////////////
'//设置操作权限
Public Sub SetOperatorRights()
    Dim sSqlStr As String, sField As String
    Dim FunctionRs As ADODB.Recordset
    Dim PowerRs As ADODB.Recordset
    Dim mnuObj As Object, sKey As String
    
    sField = GetDepartFunctionField()
    sSqlStr = "Select FMenuName From Function Where Not " & sField
    Set FunctionRs = New ADODB.Recordset
    FunctionRs.Open sSqlStr, m_gDBCnn
    
    sSqlStr = "SELECT FMenuName FROM Function Where " & sField & " And FMenuAttrib <> 0 " & _
        " And FMenuName Not In (Select FMenuName From OperatorPower " & _
        " Where FDepartCode = '" & m_gsDepartCode & "' And FOperatorName = '" & m_gsOperator & "')"
    Set PowerRs = New ADODB.Recordset
    PowerRs.Open sSqlStr, m_gDBCnn
    
    On Error Resume Next
    '对父菜单上的最后一个保持可视的子菜单，试图设置 Visible 属性为 False 时会出错！
    '工具条不含“窗口”及“帮助”菜单，若设置其 Visible 及 Enabled 属性时会出错！
    For Each mnuObj In Me.Controls
        If TypeOf mnuObj Is Menu Then
            sKey = UCase(mnuObj.Name)
            FunctionRs.Filter = "FMenuName = '" & mnuObj.Name & "'"
            mnuObj.Visible = (FunctionRs.EOF And FunctionRs.BOF)
            tbToolBar.Buttons(sKey).Visible = (FunctionRs.EOF And FunctionRs.BOF)
            
            If m_gnLevel = GENERAL_OPERATOR Then
                PowerRs.Filter = "FMenuName = '" & mnuObj.Name & "'"
                If mnuObj Is mnuRights Or mnuObj Is mnuChangeManager Then
                    mnuObj.Enabled = False
                    tbToolBar.Buttons(sKey).Enabled = False
                Else
                    mnuObj.Enabled = (PowerRs.EOF And PowerRs.BOF)
                    tbToolBar.Buttons(sKey).Enabled = (PowerRs.EOF And PowerRs.BOF)
                End If
            Else
                mnuObj.Enabled = True
                tbToolBar.Buttons(sKey).Enabled = True
            End If
        End If
    Next
    Set FunctionRs = Nothing
    Set PowerRs = Nothing
End Sub

'//////////////////////////////////////////////////////
'//
Private Sub GetOperatorPower(sMenuName As String, ByRef bEdit As Boolean, Optional ByRef bAuditer As Boolean, Optional ByRef bKeeper As Boolean)
    If m_gnLevel = SUPPER_MANAGER Or m_gnLevel = DEPART_MANAGER Then
        bEdit = True
        bAuditer = True
        bKeeper = True
        Exit Sub
    End If

    Dim PowerRs As ADODB.Recordset
    Set PowerRs = New ADODB.Recordset
    PowerRs.Open "Select * From OperatorPower Where FDepartCode = '" & m_gsDepartCode & "' And FOperatorName = '" & m_gsOperator & "' And FMenuName = '" & sMenuName & "' Order by FPowerAttrib", m_gDBCnn
    With PowerRs
        If .EOF And .BOF Then
            bEdit = False
            bAuditer = False
            bKeeper = False
        Else
            .Filter = "FPowerAttrib = 1"
            bEdit = Not (.EOF And .BOF)
            .Filter = "FPowerAttrib = 2"
            bAuditer = Not (.EOF And .BOF)
            .Filter = "FPowerAttrib = 3"
            bKeeper = Not (.EOF And .BOF)
        End If
    End With
    Set PowerRs = Nothing
End Sub

'//////////////////////////////////////////////////////
'//
Private Sub MDIForm_Load()
    Dim i As Integer
'///////////////////////////////////
'//    SetFunction      '设置功能表
'///////////////////////////////////
    InitToolBarAttribute
    
    With sbStatusBar
        .Panels.Add , "OPERATOR", "操作员：" & m_gsOperator, sbrText
        .Panels.Add , "LOGINDATE", "登录日期：" & Format(m_gLoginDate, "Long Date"), sbrText
        .Panels.Add , "CURRENTTIME", "当前时间：" & Format(Time, "Long Time"), sbrText
        
        For i = .Panels("OPERATOR").Index To .Panels("CURRENTTIME").Index
            .Panels(i).Alignment = sbrCenter
            .Panels(i).AutoSize = sbrContents
            .Panels(i).MinWidth = 1440
        Next
    End With
    
    CurrentTimer.Interval = 1000
    CurrentTimer.Enabled = True
    SetOperatorRights
End Sub

Private Sub CurrentTimer_Timer()
    sbStatusBar.Panels("CURRENTTIME").Text = "当前时间：" & Format(Time, "Long Time")
End Sub

'//////////////////////////////////////////////////////
'//系统设置
Private Sub mnuCharge_Click()
    GetOperatorPower "mnuCharge", m_bEdit
    frmCharge.OperatorPower = m_bEdit
    frmCharge.Show vbModal
End Sub

Private Sub mnuCustomer_Click()
    GetOperatorPower "mnuCustomer", m_bEdit
    frmCustomer.OperatorPower = m_bEdit
    frmCustomer.Show
    frmCustomer.SetFocus
End Sub

Private Sub mnuSetWarehouse_Click()
    GetOperatorPower "mnuSetWarehouse", m_bEdit
    frmSetWarehouse.OperatorPower = m_bEdit
    frmSetWarehouse.Show vbModal
End Sub

Private Sub mnuSetDepart_Click()
    GetOperatorPower "mnuSetDepart", m_bEdit
    frmSetDepart.OperatorPower = m_bEdit
    frmSetDepart.Show vbModal
End Sub

Private Sub mnuSupplier_Click()
    GetOperatorPower "mnuSupplier", m_bEdit
    frmSupplier.OperatorPower = m_bEdit
    frmSupplier.Show
    frmSupplier.SetFocus
End Sub

Private Sub mnuWaresList_Click()
    GetOperatorPower "mnuWaresList", m_bEdit
    frmWaresList.OperatorPower = m_bEdit
    frmWaresList.Show
    frmWaresList.SetFocus
End Sub

Private Sub mnuInitBalance_Click()
    GetOperatorPower "mnuInitBalance", m_bEdit
    frmInitBalance.OperatorPower = m_bEdit
    frmInitBalance.Show
    frmInitBalance.SetFocus
End Sub

Private Sub mnuInitStockDetail_Click()
    GetOperatorPower "mnuInitStockDetail", m_bEdit
    frmInitStockDetail.OperatorPower = m_bEdit
    frmInitStockDetail.Show
    frmInitStockDetail.SetFocus
End Sub

'////////////////////////////////////////
'//
Private Sub mnuRights_Click()
    frmRights.Show vbModal
End Sub

Private Sub mnuOperatorLogin_Click()
    Dim i As Integer
    
    frmLogin.SetMeCaption = "更换操作员"
    frmLogin.Show vbModal
    If frmLogin.OK Then
        i = 0
        Do While Forms.Count > 2
            If Forms(i) Is m_gMainForm Or Forms(i) Is frmLogin Then
                i = i + 1
            Else
                Unload Forms(i)
            End If
        Loop
        sbStatusBar.Panels("OPERATOR").Text = "操作员：" & m_gsOperator
        sbStatusBar.Panels("LOGINDATE").Text = "登录日期：" & Format(m_gLoginDate, "Long Date")
        SetOperatorRights
    End If
    Unload frmLogin
End Sub

Private Sub mnuChangeManager_Click()
    FrmChangeManager.Show vbModal
    If FrmChangeManager.m_bOk Then
        sbStatusBar.Panels("OPERATOR").Text = "操作员：" & m_gsOperator
    End If
    Unload FrmChangeManager
End Sub

Private Sub mnuChangePassword_Click()
    FrmChangePassword.Show vbModal
End Sub

Private Sub mnuExit_Click()
    End
End Sub

'////////////////////////////////////////
'//
Private Sub mnuStockUpCharge_Click()
    frmStockUpCharge.Show
    frmStockUpCharge.SetFocus
End Sub

Private Sub mnuStockUpCost_Click()
    If GetForm(fStockUpCost) Is Nothing Then
        Set fStockUpCost = New frmStockUpCost
        fStockUpCost.FormAttribute = 0