+

VB开发的ERP系统

Private Sub CxbbGrid_BeforeMoveColumn(ByVal Col As Long, Position As Long)           '网格列发生移动时自动交换网格索引信息
    Call FnBln_RefreshArray(Col, Position, GridStr(), GridInf())
End Sub

Private Sub GsToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)                '网格格式调整(Fixed)
  
    Select Case Button.Key
        Case "bcgs"                                          '保存表格格式
            Call Bcwggs(CxbbGrid, GridCode, GridStr())
        Case "hfmrgs"                                        '恢复默认格式
            Call Hfmrgs(CxbbGrid, GridCode, GridStr())
        Case "szxsxm"                                        '设置显示项目
            Call Szxsxm(CxbbGrid, GridCode)
    End Select

End Sub

Private Sub SzToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)
    
    Select Case Button.Key
        Case "ymsz"                                          '页面设置
            Dyymctbl.Show 1
        Case "yl"                                            '预 览
            Call bbyl(True)
        Case "dy"                                            '打 印
            Call bbyl(False)
        Case "cx"                                            '查 询
            Xs_Mcx_MoneyWareList.Show 1
        Case "Bill"                                          '单 据
            Call CxbbGrid_DblClick
        Case "xz"                                            '新 增
            Call Sub_AddBill
        Case "sc"                                            '删 除
            Call Sub_DeleteBill
        Case "hx"                                            '核 销
            If Not Fun_HX Then Exit Sub
            Xs_M_Return.Show
        Case "bz"                                            '帮 助
            Call F1bz
        Case "fh"                                            '退 出
           Unload Me
    End Select

End Sub

Private Sub Timer1_Timer()                                 '在窗体激活后调入查询程序
    
    Timer1.Enabled = False
    Xt_Wait.Show
    Xt_Wait.Refresh
   
    '加快显示速度
    CxbbGrid.Redraw = False
 
    '生成查询结果
    Call Sub_Query(0)
   
    CxbbGrid.Redraw = True
    
    Xt_Wait.Hide

End Sub

Private Sub Sub_Query(Int_QueryType As Integer)                                     '生成查询结果(Define)
    
    '过程参数:Int_QueryType 0-"点确定按钮"查询  1-"刷新"查询

    Dim Rec_Query As New ADODB.Recordset        '查询结果动态集
    Dim Coljsq As Long                          '网格列计数器
    Dim Jsqte As Integer                        '临时动态计数器

    '以下为自定义部分[
 
    If Int_QueryType = 0 Then   '0-"点确定按钮"查询
        With Xs_Mcx_MoneyWareList
            '生成查询条件
            Str_QueryCondi = " where 1=1 "
            For Jsqte = 0 To .LrText.count - 1
                Select Case Jsqte
                    Case 0                  '查询日期范围(起始)
                        If Trim(.LrText(0).Text) <> "" Then
                            Str_QueryCondi = Str_QueryCondi & " And " & Trim(.Label1(Jsqte).Tag) & ">=' " & Trim(.LrText(0).Text) & "'"
                        End If
                    Case 1                  '查询日期范围(终止)
                        If Trim(.LrText(1).Text) <> "" Then
                            Str_QueryCondi = Str_QueryCondi & " And " & Trim(.Label1(0).Tag) & "<= ' " & Trim(.LrText(1).Text) & "'"
                        End If
                    Case Else
                        If Trim(.LrText(Jsqte).Text) <> "" Then
                            If .LrText(Jsqte).Tag <> "" Then
                                Str_QueryCondi = Str_QueryCondi & " and " & Trim(.Label1(Jsqte).Tag) & "='" & Trim(.LrText(Jsqte).Tag) & "'"
                            Else
                                Str_QueryCondi = Str_QueryCondi & " and " & Trim(.Label1(Jsqte).Tag) & "='" & Trim(.LrText(Jsqte).Text) & "'"
                            End If
                        End If
                End Select
            Next Jsqte
        End With
    Else
        '1-"刷新"查询
        If Str_QueryCondi = "" Then
            Str_QueryCondi = " where 1=2 "
        End If
    End If
     
    Sqlstr = "SELECT * FROM Xs_V_MoneyWare " & Str_QueryCondi & " order by MoneyWareID"
    Set Rec_Query = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    With Rec_Query
        CxbbGrid.Rows = CxbbGrid.FixedRows
        Jsqte = CxbbGrid.FixedRows
        Do While Not .EOF
            CxbbGrid.AddItem ""
            '[>>自定义填充内容
            CxbbGrid.TextMatrix(Jsqte, 0) = Format(.Fields("MoneyWareId"))                  '
            CxbbGrid.TextMatrix(Jsqte, Sydz("001", GridStr(), Szzls)) = Format(.Fields("MoneyWareCode"))                '核销CODE
            CxbbGrid.TextMatrix(Jsqte, Sydz("002", GridStr(), Szzls)) = Format(.Fields("VerifierDate"), "yyyy-mm-dd")   '核销日期
            CxbbGrid.TextMatrix(Jsqte, Sydz("003", GridStr(), Szzls)) = Trim(.Fields("Cusname") & "")                   '客户名称
            If Trim(.Fields("billtype")) Then
                If Not Trim(.Fields("HdType")) Then
                    CxbbGrid.TextMatrix(Jsqte, Sydz("004", GridStr(), Szzls)) = "发货单"
                Else
                    CxbbGrid.TextMatrix(Jsqte, Sydz("004", GridStr(), Szzls)) = "退货单"
                End If
            Else
                CxbbGrid.TextMatrix(Jsqte, Sydz("004", GridStr(), Szzls)) = "回款单"
            End If
            CxbbGrid.TextMatrix(Jsqte, Sydz("005", GridStr(), Szzls)) = Trim(.Fields("billcode") & "")                  '单据号
            CxbbGrid.TextMatrix(Jsqte, Sydz("006", GridStr(), Szzls)) = Trim(.Fields("MName") & "")                     '货物名称
            CxbbGrid.TextMatrix(Jsqte, Sydz("007", GridStr(), Szzls)) = Val(.Fields("CapitalUsedMoney") & "")           '核销金额
            CxbbGrid.TextMatrix(Jsqte, Sydz("008", GridStr(), Szzls)) = Trim(.Fields("Verifier") & "")                  '核销人
            
            '<<]
            '设置数据行高度(Fixed)
            CxbbGrid.RowHeight(Jsqte) = Sjhgd
     
            '动态集指针加1,同时将计数器加1(Fixed)
            .MoveNext
            Jsqte = Jsqte + 1
        Loop
    End With

    ']以上为用户自定义部分

End Sub

Private Sub CxbbGrid_DblClick()                                              '用户双击网格调入相应单据
    
    Dim RecTemp As New ADODB.Recordset               '临时使用动态集

        Exit Sub
    '非数据行退出
    If CxbbGrid.Row < CxbbGrid.FixedRows Or Val(CxbbGrid.TextMatrix(CxbbGrid.Row, 0)) = 0 Then
    End If

    Sqlstr = "SELECT returnmoney From Xs_ReturnMoney Where MoneyWareID=" & Val(CxbbGrid.TextMatrix(CxbbGrid.Row, 0))
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    With RecTemp
        If .EOF Then
            Tsxx = "此回款已被其他用户删除!"
            Call Xtxxts(Tsxx, 0, 4)
            Exit Sub
        Else
            XT_BillID = CxbbGrid.TextMatrix(CxbbGrid.Row, 0)        '填充查询单据标识
            Xtcdcs = "2"                                            '设置单据处理为列表查询(修改)状态
            '调入单据处理窗体
            Xtcdcsfz = Str_QueryCondi
            Xs_M_ReturnMoney.Show 1
            
            If Xtfhcs = "1" Then
                Tsxx = "回款发生变化,是否刷新回款列表?"
                Yhanswer = Xtxxts(Tsxx, 2, 2)
                If Yhanswer = 1 Then
                    Xt_Wait.Show
                    Xt_Wait.Refresh
   
                    '加快显示速度
                    CxbbGrid.Redraw = False
 
                    '生成查询结果
                    Call Sub_Query(1)
   
                    CxbbGrid.Redraw = True
                    Xt_Wait.Hide
                End If
            End If
        End If
    End With

End Sub

Private Sub Sub_AddBill()                                              '新增单据
   
    '设置单据处理为填制单据状态
    Xtcdcs = "1"
    Xs_M_ReturnMoney.Show 1
       
    If Xtfhcs = "1" Then
        Tsxx = "回款发生变化,是否刷新回款列表?"
        Yhanswer = Xtxxts(Tsxx, 2, 2)
        If Yhanswer = 1 Then
            Xt_Wait.Show
            Xt_Wait.Refresh
   
            '加快显示速度
            CxbbGrid.Redraw = False
 
            '生成查询结果
            Call Sub_Query(1)
   
            CxbbGrid.Redraw = True
            Xt_Wait.Hide
        End If
    End If
   
End Sub

Private Sub Sub_DeleteBill()                                            '删除选中当前回款
    
    Dim YAnswer As Integer
    Dim Lng_BillID As Long           '单据标识
  
    '非数据行退出
    If CxbbGrid.Row < CxbbGrid.FixedRows Or Val(CxbbGrid.TextMatrix(CxbbGrid.Row, 0)) = 0 Then
        Exit Sub
    End If
    
    '1.判断当前回款是否允许删除
    If Not Fun_AllowDelete Then
        Exit Sub
    End If
  
    Tsxx = "请确认是否删除当前回款?"
    Yhanswer = Xtxxts(Tsxx, 2, 2)
  
    If Yhanswer = 1 Then
        '2.删除单据所有内容
        Lng_BillID = Val(CxbbGrid.TextMatrix(CxbbGrid.Row, 0))
        On Error GoTo Swcwcl
        Cw_DataEnvi.DataConnect.BeginTrans
        Cw_DataEnvi.DataConnect.Execute ("Delete Xs_ReturnMoney Where MoneyWareID = " & Lng_BillID)
        Cw_DataEnvi.DataConnect.CommitTrans
      
        '删除网格中单据数据
        Jsqte = CxbbGrid.FixedRows
        Do While Jsqte <= CxbbGrid.Rows - 1
            If Val(CxbbGrid.TextMatrix(Jsqte, 0)) = Lng_BillID Then
                CxbbGrid.RemoveItem (CxbbGrid.Row)
            Else
                Jsqte = Jsqte + 1
            End If
        Loop
    Else
        Exit Sub
    End If
    Exit Sub
Swcwcl:
    Cw_DataEnvi.DataConnect.RollbackTrans
    Tsxx = "删除回款过程中出现未知错误,程序自动恢复删除前状态!"
    Call Xtxxts(Tsxx, 0, 1)
    Exit Sub
  
End Sub

Private Function Fun_AllowDelete() As Boolean                                        '判断当前单据是否允许删除
  
    Dim RecTemp As New ADODB.Recordset     '临时使用动态集
    Dim Sqlstr As String                   '查询字符串
    Dim Lng_BillID As Long                 '单据ID
  
    Lng_BillID = Val(CxbbGrid.TextMatrix(CxbbGrid.Row, 0))
    Sqlstr = "Select Checker From Xs_ReturnMoney Where MoneyWareID=" & Lng_BillID
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    With RecTemp
        If Not .EOF Then
            If Trim(.Fields("Checker") & "") <> "" Then
                Tsxx = "该回款已审核确认,不能删除!"
                Call Xtxxts(Tsxx, 0, 4)
                Exit Function
            End If
            End If
    End With
    Fun_AllowDelete = True
  
End Function

Private Sub bbyl(bbylte As Boolean)                    '报表打印预览
    
    Dim Bbzbt$, Bbxbt() As String, bbxbtzzxs() As Integer, Bbxbtgs As Integer
    Dim Bbbwh() As String, Bbbwhzzxs() As Integer, Bbbwhgs As Integer
    Bbxbtgs = 1                                          '报 表 小 标 题 行 数
    Bbbwhgs = 0                                          '报 表 表 尾 行 数
    ReDim Bbxbt(1 To Bbxbtgs)
    ReDim bbxbtzzxs(1 To Bbxbtgs)
    If Bbbwhgs <> 0 Then
        ReDim Bbbwh(1 To Bbbwhgs)
        ReDim Bbbwhzzxs(1 To Bbbwhgs)
    End If
    Bbzbt = ReportTitle
    Bbxbt(1) = ""
    bbxbtzzxs(1) = 0                                     '报表行组织形式(0-居左 1-居中 2-居右)
    Call Scyxsjb(CxbbGrid)                               '生成报表数据
    Call Scdybb(Dyymctbl, Bbzbt, Bbxbt(), bbxbtzzxs(), Bbxbtgs, Bbbwh(), Bbbwhzzxs(), Bbbwhgs, bbylte)
    If Not bbylte Then
        Unload DY_Tybbyldy
    End If

End Sub

Private Function Fun_HX() As Boolean
Dim Sqlstr As String
Dim ResTemp As New ADODB.Recordset

    Fun_HX = False
    '非数据行退出
    If CxbbGrid.Row < CxbbGrid.FixedRows Or Val(CxbbGrid.TextMatrix(CxbbGrid.Row, 0)) = 0 Then
        Exit Function
    End If

    Sqlstr = "Select Checker From Xs_ReturnMoney Where MoneyWareID=" & Val(CxbbGrid.TextMatrix(CxbbGrid.Row, 0))
    Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
    With RecTemp
        If Not .EOF Then
            If Trim(.Fields("Checker") & "") = "" Then
                Tsxx = "该回款未审核确认,不能核销!"
                Call Xtxxts(Tsxx, 0, 4)
                Exit Function
            End If
        Else
            Tsxx = "当前数据可能被其他用户删除!"
            Call Xtxxts(Tsxx, 0, 4)
            Exit Function
        End If
    End With
    CustomCode = Trim(CxbbGrid.TextMatrix(CxbbGrid.Row, 1))     '客户编码
    Fun_HX = True
End Function