frmoutput.frm

此为我2001年为东莞建发楦头开发的企业管理软件他们使用至今,望斑竹指教! 其他会员最好不要随意下载,需经斑竹同意或我本人同意,谢谢!

        End Select
      Next
           
      SetButtons True
     
      mbDataChanged = False
      
  mbGridFlag = True
  
  If mbGridFlag = True Then

    Dim k, l As Integer

    Dim source1 As String
    source1 = "select input_no,material_no,material_type,material_name,output_qty,material_unit,material_price,remark  from output where output_no='" & txtfields(0) & "'"

    Set adoSecondRS = New Recordset
    adoSecondRS.Open source1, db, adOpenStatic, adLockOptimistic

    adoSecondRS.MoveFirst
    If adoSecondRS.BOF And adoSecondRS.EOF Then
        Msfg.Rows = 100
        MsfgInit
        adoSecondRS.Close
        Exit Sub
    End If

    k = 1
    Do Until adoSecondRS.EOF
        Msfg.Row = k
        For l = 1 To 8
            Msfg.Col = l - 1
            If l > 2 Then Msfg.Text = Format(adoSecondRS.Fields(l - 1), "###0.00") Else Msfg.Text = adoSecondRS.Fields(l - 1)
        Next
        adoSecondRS.MoveNext
        k = k + 1
    Loop
    adoSecondRS.Close
  End If

  mbDataChanged = False

  Exit Sub

GoLastError:
  MsgBox err.Description

End Sub

Private Sub cmdNext_Click()
  'On Error GoTo GoNextError
  On Error Resume Next
    MsfgInit
    adoPrimaryRS.MoveNext
    
    cmdFirst.Enabled = True
    cmdPrevious.Enabled = True
    
    If adoPrimaryRS.EOF = True And adoPrimaryRS.RecordCount > 0 Then
        
        Beep
        adoPrimaryRS.MoveLast
        
        cmdNext.Enabled = False
        cmdLast.Enabled = False
    End If
    
      For i = 0 To adoPrimaryRS.Fields.Count - 1
       Select Case i
         Case 1
            vcDate.value = adoPrimaryRS.Fields(i)
         Case Else
            txtfields(i) = adoPrimaryRS.Fields(i)
        End Select
      Next
           
      SetButtons True
     
      mbDataChanged = False
      
  mbGridFlag = True
  
  If mbGridFlag = True Then

    Dim k, l As Integer

    Dim source1 As String
    source1 = "select input_no,material_no,material_type,material_name,output_qty,material_unit,material_price,remark  from output where output_no='" & txtfields(0) & "'"

    Set adoSecondRS = New Recordset
    adoSecondRS.Open source1, db, adOpenStatic, adLockOptimistic

    adoSecondRS.MoveFirst
    If adoSecondRS.BOF And adoSecondRS.EOF Then
        Msfg.Rows = 100
        MsfgInit
        adoSecondRS.Close
        Exit Sub
    End If

    k = 1
    Do Until adoSecondRS.EOF
        Msfg.Row = k
        For l = 1 To 8
            Msfg.Col = l - 1
            If l > 2 Then Msfg.Text = Format(adoSecondRS.Fields(l - 1), "###0.00") Else Msfg.Text = adoSecondRS.Fields(l - 1)
        Next
        adoSecondRS.MoveNext
        k = k + 1
    Loop
    adoSecondRS.Close
  End If


        
    mbDataChanged = False

    Exit Sub
GoNextError:
  MsgBox err.Description

End Sub

Private Sub cmdPrevious_Click()
  'On Error GoTo GoPrevError
    On Error Resume Next
    MsfgInit
    adoPrimaryRS.MovePrevious
        
    cmdNext.Enabled = True
    cmdLast.Enabled = True
    If adoPrimaryRS.BOF = True And adoPrimaryRS.RecordCount > 0 Then
        
        Beep
        adoPrimaryRS.MoveFirst
        
        cmdPrevious.Enabled = False
        cmdFirst.Enabled = False
    End If
    
      For i = 0 To adoPrimaryRS.Fields.Count - 1
       Select Case i
         Case 1
            vcDate.value = adoPrimaryRS.Fields(i)
         Case Else
            txtfields(i) = adoPrimaryRS.Fields(i)
        End Select
      Next
           
      SetButtons True
     
      mbDataChanged = False
      
  mbGridFlag = True
  
  If mbGridFlag = True Then

    Dim k, l As Integer

    Dim source1 As String
    source1 = "select input_no,material_no,material_type,material_name,output_qty,material_unit,material_price,remark  from output where output_no='" & txtfields(0) & "'"

    Set adoSecondRS = New Recordset
    adoSecondRS.Open source1, db, adOpenStatic, adLockOptimistic

    adoSecondRS.MoveFirst
    If adoSecondRS.BOF And adoSecondRS.EOF Then
        Msfg.Rows = 100
        MsfgInit
        adoSecondRS.Close
        Exit Sub
    End If

    k = 1
    Do Until adoSecondRS.EOF
        Msfg.Row = k
        For l = 1 To 8
            Msfg.Col = l - 1
            If l > 2 Then Msfg.Text = Format(adoSecondRS.Fields(l - 1), "###0.00") Else Msfg.Text = adoSecondRS.Fields(l - 1)
        Next
        adoSecondRS.MoveNext
        k = k + 1
    Loop
    adoSecondRS.Close
  End If

    mbDataChanged = False

    Exit Sub
GoPrevError:
  MsgBox err.Description
End Sub

Private Sub cmdRefresh_Click()
  '只有多用户应用程序需要
  'On Error GoTo RefreshErr
  On Error Resume Next
  MsfgInit
  adoPrimaryRS.Requery
  
  cmdFirst.Enabled = True
  cmdPrevious.Enabled = True
  cmdNext.Enabled = True
  cmdLast.Enabled = True
  
      For i = 0 To adoPrimaryRS.Fields.Count - 1
       Select Case i
         Case 1
            vcDate.value = adoPrimaryRS.Fields(i)
         Case Else
            txtfields(i) = adoPrimaryRS.Fields(i)
        End Select
      Next
           
      SetButtons True
     
      mbDataChanged = False
      
  mbGridFlag = True
  
  If mbGridFlag = True Then

    Dim k, l As Integer

    Dim source1 As String
    source1 = "select input_no,material_no,material_type,material_name,output_qty,material_unit,material_price,remark  from output where output_no='" & txtfields(0) & "'"

    Set adoSecondRS = New Recordset
    adoSecondRS.Open source1, db, adOpenStatic, adLockOptimistic

    adoSecondRS.MoveFirst
    If adoSecondRS.BOF And adoSecondRS.EOF Then
        Msfg.Rows = 100
        MsfgInit
        adoSecondRS.Close
        Exit Sub
    End If

    k = 1
    Do Until adoSecondRS.EOF
        Msfg.Row = k
        For l = 1 To 8
            Msfg.Col = l - 1
            If l > 2 Then Msfg.Text = Format(adoSecondRS.Fields(l - 1), "###0.00") Else Msfg.Text = adoSecondRS.Fields(l - 1)
        Next
        adoSecondRS.MoveNext
        k = k + 1
    Loop
    adoSecondRS.Close
  End If

  Exit Sub
RefreshErr:
  MsgBox err.Description

End Sub

Private Sub cmdUpdate_Click()
  'On Error GoTo UpdateErr
  On Error Resume Next
  Dim ir As Integer

  If mbAddNewFlag Then
  
    Msfg_LeaveCell
    If Verdict = False Then Exit Sub
    With Msfg
        'ReDim ArrayList(.Tag)
        'For ir = 1 To .Tag
        '   If Verify_List(ir, .TextMatrix(ir, 0)) = False Then Exit Sub
        'Next
  
          '领用量
        For ir = 1 To .Tag
            Set rs = New Recordset
            rs.Open "select input_qty-output_qty from input where input_no='" & .TextMatrix(ir, 0) & "' and material_no='" & .TextMatrix(ir, 1) & "'", db, adOpenStatic, adLockOptimistic
            
            If rs.RecordCount = 1 Then
                If rs.Fields(0) < Val(.TextMatrix(ir, 4)) Then MsgBox .TextMatrix(ir, 3) & "领用数量大于库存数量！", 48, "录入提示": Exit Sub
            End If
            
            rs.Close
            Set rs = Nothing
            
        Next
        
        If MsgBox("本操作将影响到领料单明细及数量,你确信以上数据正确吗?", 48 + 1, "领料单") = vbCancel Then Exit Sub
        '在此校验单号是否已经被其它用户使用
        Set rs = New Recordset
        rs.Open "select * from output where output_no='" & txtfields(0) & "'", db, adOpenStatic, adLockOptimistic
        
        If rs.RecordCount > 0 Then '如果已经使用则重新分配一个单号
                Dim aa As String
                Dim Mstr As String
                Dim yy As String
                Dim mm As String
                Dim yymm As String
                      
                yy = Year(Date)
                yy = Right(yy, 2)
                
                mm = Month(Format(Date, "yyyy-MM-dd"))
                If Len(mm) = 1 Then mm = "0" + mm
                
                yymm = yy + mm
                   
                Set rsTemp = New Recordset
                rsTemp.Open "select max(output_no) as mdinno from output where output_no like 'O" + yymm + "%' ", db, adOpenStatic, adLockOptimistic
                
                
                If IsNull(rsTemp!mdinno) = True Then
                    Mstr = "O" & yymm & "00001"
                Else
                     
                    Dim a As String
                    a = Right(Trim((rsTemp!mdinno)), 5)
                    a = Right(str(Int(a) + 100001), 5)
                    
                    Mstr = "O" + yymm + a
                End If
                txtfields(0) = Mstr
                rsTemp.Close
                Set rsTemp = Nothing
        End If
        
        rs.Close
        Set rs = Nothing
        
        
        
        '插入记录
        For ir = 1 To .Tag
            db.Execute "Insert into output(output_no,output_date,department,employee,audit,warehouse,input_no,material_no,material_type,material_name,output_qty,material_unit,material_price,remark) Values('" & txtfields(0) & "','" & vcDate.value & "','" & txtfields(2) & "','" & txtfields(3) & "','" & txtfields(4) & "','" & txtfields(5) & "','" & .TextMatrix(ir, 0) & "','" & .TextMatrix(ir, 1) & "','" & .TextMatrix(ir, 2) & "','" & .TextMatrix(ir, 3) & "','" & .TextMatrix(ir, 4) & "','" & .TextMatrix(ir, 5) & "','" & .TextMatrix(ir, 6) & "','" & .TextMatrix(ir, 7) & "')"
            db.Execute "update input set output_qty=output_qty+" & .TextMatrix(ir, 4) & " where input_no='" & .TextMatrix(ir, 0) & "'"
        Next
    End With
    MsgBox "领料单成功录入"

    Set adoPrimaryRS = New Recordset
    adoPrimaryRS.Open "select distinct output_no,output_date,department,employee,audit,warehouse from output", db, adOpenStatic, adLockOptimistic
    adoPrimaryRS.MoveLast
  Else
    'Dim ir As Integer
    Msfg_LeaveCell
    If Verdict = False Then Exit Sub
    With Msfg
        'ReDim ArrayList(.Tag)
        'For ir = 1 To .Tag
        '   If Verify_List(ir, .TextMatrix(ir, 0)) = False Then Exit Sub
        'Next
          '领用量
        For ir = 1 To .Tag
            Set rs = New Recordset
            rs.Open "select input.input_qty-input.output_qty+output.output_qty from input left join output on input.input_no=output.input_no where input.input_no='" & .TextMatrix(ir, 0) & "' and input.material_no='" & .TextMatrix(ir, 1) & "' and output.output_no='" & so & "'", db, adOpenStatic, adLockOptimistic
            
'            rs.Open "select input_qty-output_qty from input where input_no='" & .TextMatrix(ir, 0) & "' and material_no='" & .TextMatrix(ir, 1) & "'", db, adOpenStatic, adLockOptimistic
            
            If rs.RecordCount = 1 Then
                If rs.Fields(0) < Val(.TextMatrix(ir, 4)) Then MsgBox .TextMatrix(ir, 3) & "领用数量大于库存数量！", 48, "录入提示": Exit Sub
            End If
            
            rs.Close
            Set rs = Nothing
            
        Next
        
        If MsgBox("本操作将影响到领料单明细及金额,你确信以上数据正确吗?", 48 + 1, "领料单") = vbCancel Then Exit Sub
        
        '更新库存
        Set rsTemp = New Recordset
        rsTemp.Open "select input_no,material_no,output_qty from output where output_no='" & so & "'", db, adOpenStatic, adLockOptimistic
        
        If Not rsTemp.BOF Then rsTemp.MoveFirst
        Do Until rsTemp.EOF
            db.Execute "update input set output_qty=output_qty-" & Val(rsTemp.Fields(2)) & " where input_no='" & rsTemp.Fields(0) & "' and material_no='" & rsTemp.Fields(1) & "'"
            rsTemp.MoveNext
        Loop
        rsTemp.Close
        Set rsTemp = Nothing

            
            
        db.Execute "delete from output where output_no='" & so & "'"

        For ir = 1 To .Tag
            db.Execute "Insert into output(output_no,output_date,department,employee,audit,warehouse,input_no,material_no,material_type,material_name,output_qty,material_unit,material_price,remark) Values('" & txtfields(0) & "','" & vcDate.value & "','" & txtfields(2) & "','" & txtfields(3) & "','" & txtfields(4) & "','" & txtfields(5) & "','" & .TextMatrix(ir, 0) & "','" & .TextMatrix(ir, 1) & "','" & .TextMatrix(ir, 2) & "','" & .TextMatrix(ir, 3) & "','" & .TextMatrix(ir, 4) & "','" & .TextMatrix(ir, 5) & "','" & .TextMatrix(ir, 6) & "','" & .TextMatrix(ir, 7) & "')"
            db.Execute "update input set output_qty=output_qty+" & .TextMatrix(ir, 4) & " where input_no='" & .TextMatrix(ir, 0) & "'"
        Next
        
    End With
    MsgBox "修改资料成功录入或修改"
       
    rs.Close
    Set rs = Nothing
       
    Set adoPrimaryRS = New Recordset
    adoPrimaryRS.Open "select distinct output_no,output_date,department,employee,audit,warehouse from output", db, adOpenStatic, adLockOptimistic
      
    If mvBookMark > 0 Then
       adoPrimaryRS.Bookmark = mvBookMark
    Else
       adoPrimaryRS.MoveLast
    End If