frmoutput.frm

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

                        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(i) = Mstr
                        rsTemp.Close
                        Set rsTemp = Nothing
                
                   Case 1
                    vcDate.value = Date
                   Case Else
                    txtfields(i) = ""
                End Select
            Next

            MsfgInit

            lblStatus.Caption = " 添加记录"
            mbAddNewFlag = True
            SetButtons False
            vcDate.SetFocus

      Exit Sub
AddErr:
      MsgBox err.Description
End Sub

Private Sub cmdCancel_Click()
    On Error Resume Next
        
    Me.Caption = "领料单"
        
      SetButtons True
      mbEditFlag = False
      mbAddNewFlag = False
      adoPrimaryRS.CancelUpdate
      If mvBookMark > 0 Then
        adoPrimaryRS.Bookmark = mvBookMark
      Else
        adoPrimaryRS.MoveFirst
      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
      
      Me.Caption = "领料单"
      
End Sub

Private Sub cmdClose_Click()
      Beep
      msg = MsgBox("确定要关闭吗？", vbYesNo + vbQuestion, "领料单")
      If msg = vbYes Then
          Unload Me
      End If
End Sub

Private Sub cmdDel_Click()
If Msfg.Rows <= 2 Then Exit Sub
Msfg.RemoveItem Msfg.Row
End Sub

Private Sub cmdDelete_Click()
'    On Error GoTo DeleteErr
    On Error Resume Next
'
    Beep

    so = InputBox("请输入领料单号", "领料单", txtfields(0).Text)

    If Len(so) = 0 Then
     Exit Sub
    End If

    Set rs = New Recordset
    rs.Open "select * from output where output_no='" & so & "'", db, adOpenStatic, adLockOptimistic

    If rs.RecordCount = 0 Then
      MsgBox "不存在这个领料单号", vbExclamation, "领料单"
      rs.Close
      Exit Sub
    End If
    rs.Close

  rs.Open "select * from output where output_no='" & so & "'", db, adOpenStatic, adLockOptimistic

  If rs.RecordCount <> 0 Then
    msg = MsgBox("确定要删除吗？", vbYesNo + vbQuestion, "领料单")
    If msg = vbYes Then
    
        '更新库存
        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 & "'"
    
    End If
  End If

  rs.Close

  adoPrimaryRS.Requery
  If adoPrimaryRS.RecordCount <> 0 Then
      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
  End If

  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
DeleteErr:
      MsgBox err.Description
    
End Sub

Private Sub cmdEdit_Click()
  'On Error GoTo EditErr
  On Error Resume Next
  
   so = InputBox("请输入领料单号", "领料单", txtfields(0).Text)
   
  If Len(so) = 0 Then
   Exit Sub
  End If
      
   Set rs = New Recordset
   rs.Open "select output_no,output_date,department,employee,audit,warehouse from output where output_no='" & so & "'", db, adOpenStatic, adLockOptimistic
    
    If rs.RecordCount < 1 Then
        msg = MsgBox("此领料单不存在！", vbOKOnly + vbCritical, "领料单")
        rs.Close
        Set rs = Nothing
        Exit Sub
    End If
        
    rs.Close
    Set rs = Nothing
        
  Set rs = New Recordset
  rs.Open "select distinct output_no,output_date,department,employee,audit,warehouse from output where output_no='" & so & "'", db, adOpenStatic, adLockOptimistic
    
  If Not rs.BOF Then rs.MoveFirst
  
      For i = 0 To rs.Fields.Count - 1
       Select Case i
         Case 1
            vcDate.value = rs.Fields(i)
         Case Else
            txtfields(i) = rs.Fields(i)
        End Select
      Next
  
  rs.Close
  Set rs = Nothing
  
  With adoPrimaryRS
  If Not (.BOF And .EOF) Then
      mvBookMark = .Bookmark
  End If
  End With
    
  lblStatus.Caption = " 编辑记录"
  mbEditFlag = True
  SetButtons False
  txtfields(2).SetFocus
  
'显示记录
  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='" & so & "'"

    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


EditErr:
  MsgBox err.Description

End Sub

Private Sub cmdFirst_Click()
  '   On Error GoTo GoFirstError
  On Error Resume Next
    
     Beep
      
     cmdFirst.Enabled = False
     cmdPrevious.Enabled = False
     cmdNext.Enabled = True
     cmdLast.Enabled = True
     
     MsfgInit
     adoPrimaryRS.MoveFirst

    
      
      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
      
GoFirstError:
      MsgBox err.Description


End Sub

Private Sub cmdLast_Click()
  'On Error GoTo GoLastError
  On Error Resume Next

    Beep
    cmdFirst.Enabled = True
    cmdPrevious.Enabled = True
    cmdNext.Enabled = False
    cmdLast.Enabled = False
    
    MsfgInit
    adoPrimaryRS.MoveLast

  
      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)