frminput.frm

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

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
        If MsgBox("本操作将影响到进料单明细及数量,你确信以上数据正确吗?", 48 + 1, "进料单") = vbCancel Then Exit Sub
        
        '在此校验单号是否已经被其它用户使用
        Set rs = New Recordset
        rs.Open "select * from input where input_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(input_no) as mdinno from input where input_no like 'I" + yymm + "%' ", db, adOpenStatic, adLockOptimistic
                
                
                If IsNull(rsTemp!mdinno) = True Then
                    Mstr = "I" & yymm & "00001"
                Else
                     
                    Dim a As String
                    a = Right(Trim((rsTemp!mdinno)), 5)
                    a = Right(str(Int(a) + 100001), 5)
                    
                    Mstr = "I" + 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 input(input_no,input_date,remark,material_no,material_type,material_name,input_qty,material_unit,material_price) Values('" & txtfields(0) & "','" & vcDate.value & "','" & txtfields(2) & "','" & .TextMatrix(ir, 0) & "','" & .TextMatrix(ir, 1) & "','" & .TextMatrix(ir, 2) & "','" & .TextMatrix(ir, 3) & "','" & .TextMatrix(ir, 4) & "','" & .TextMatrix(ir, 5) & "')"
        Next
    End With
    MsgBox "进料单成功录入"

    Set adoPrimaryRS = New Recordset
    adoPrimaryRS.Open "select distinct input_no,input_date,remark from input", 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
        
        If MsgBox("本操作将影响到配方明细及金额,你确信以上数据正确吗?", 48 + 1, "进料单") = vbCancel Then Exit Sub
            

            
        db.Execute "delete from input where input_no='" & so & "'"

        For ir = 1 To .Tag
            db.Execute "Insert into input(input_no,input_date,remark,material_no,material_type,material_name,input_qty,material_unit,material_price) Values('" & txtfields(0) & "','" & vcDate.value & "','" & txtfields(2) & "','" & .TextMatrix(ir, 0) & "','" & .TextMatrix(ir, 1) & "','" & .TextMatrix(ir, 2) & "','" & .TextMatrix(ir, 3) & "','" & .TextMatrix(ir, 4) & "','" & .TextMatrix(ir, 5) & "')"
        Next
        
    End With
    MsgBox "修改资料成功录入或修改"
       
    rs.Close
    Set rs = Nothing
       
    Set adoPrimaryRS = New Recordset
    adoPrimaryRS.Open "select distinct input_no,input_date,remark from input", db, adOpenStatic, adLockOptimistic
      
    If mvBookMark > 0 Then
       adoPrimaryRS.Bookmark = mvBookMark
    Else
       adoPrimaryRS.MoveLast
    End If
          
  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 material_no,material_type,material_name,input_qty,material_unit,material_price from input where input_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 6
            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

 
      mbEditFlag = False
      mbAddNewFlag = False
      SetButtons True
      mbDataChanged = False
      Me.Caption = "进料单"

  Exit Sub
UpdateErr:
  MsgBox err.Description
End Sub

Private Sub Form_Load()
    On Error Resume Next
    
      Me.Icon = frmain.Icon
    
      MsfgInit

      Set adoPrimaryRS = New Recordset
      adoPrimaryRS.Open "select distinct input_no,input_date,remark from input", db, adOpenStatic, adLockOptimistic
      
      If Not adoPrimaryRS.BOF Then 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 material_no,material_type,material_name,input_qty,material_unit,material_price  from input where input_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 6
            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


      
End Sub

Private Sub Form_Resize()
On Error Resume Next
    Top = 0
    Left = 50
End Sub
Private Sub SetButtons(bVal As Boolean)
    fraIncome.Enabled = Not bVal
    cmdAdd.Visible = bVal
    cmdEdit.Visible = bVal
    cmdUpdate.Visible = Not bVal
    cmdcancel.Visible = Not bVal
    cmdDelete.Visible = bVal
    cmdDel.Visible = Not bVal
    cmdClose.Visible = bVal
    cmdRefresh.Visible = bVal
    cmdNext.Enabled = bVal
    cmdFirst.Enabled = bVal
    cmdLast.Enabled = bVal
    cmdPrevious.Enabled = bVal
    txtfields(0).Enabled = bVal
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Screen.MousePointer = vbDefault
    adoPrimaryRS.Close
    Set adoPrimaryRS = Nothing
End Sub

Private Sub Msfg_DblClick()
If mbAddNewFlag = True Or mbEditFlag = True Then
    Dim ir, ic As Integer
    ir = Msfg.Row - 1
    For ic = 1 To Msfg.Cols - 1
       If Msfg.TextMatrix(ir, ic) = "" Then
            MsgBox "上一行还有些数据未填写", 48, "录入提示"
            Msfg.SetFocus
            Exit Sub
       End If
    Next
    With Msfg
        If .Col = 0 And .TextMatrix(.Row - 1, 0) <> "" Then
           frmInputList.Tag = "Input"
           frmInputList.Show 1
        End If
    End With
End If
End Sub

Private Sub Msfg_KeyPress(KeyAscii As Integer)
If mbAddNewFlag = True Or mbEditFlag = True Then
    With Msfg
    If .Col <> 0 Then
      If .TextMatrix(.Row - 1, 0) <> "" Then
         Call MsfgKeyPress(KeyAscii, 115, 1050, Msfg, txtMsfg, True)
      End If
    End If
    End With
End If
End Sub

Private Sub Msfg_LeaveCell()
If mbAddNewFlag = True Or mbEditFlag = True Then
    If txtMsfg.Visible = False Then Exit Sub
    Msfg = txtMsfg.Text
    txtMsfg.Visible = False
End If
End Sub

Private Sub txtFields_Change(Index As Integer)
Select Case Index
    Case 0
    If (Len(txtfields(Index).Text)) = 15 Then
    SendKeys "{TAB}"
    End If
    If (Len(txtfields(Index).Text)) > 15 Then
    txtfields(Index).SetFocus
    SendKeys "+{END}"
    End If
End Select

End Sub

Private Sub txtfields_KeyPress(Index As Integer, KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
SendKeys "{TAB}"
End If
If KeyAscii = vbKeyEscape Then
 mbAddNewFlag = False
 mbEditFlag = False
 Call cmdcancel_Click
End If
End Sub

Private Sub txtFields_LostFocus(Index As Integer)
If mbAddNewFlag = True Or mbEditFlag = True Then
Select Case Index
    Case 0
    If (Len(txtfields(Index).Text)) = 0 Then
      Beep
      txtfields(Index).SetFocus
      MsgBox "不能为空,按ESC键退出!", vbExclamation, "进料单"
    End If
End Select
End If
End Sub


Private Sub MsfgInit()
Dim ir As Integer
With Msfg
.Clear
.FormatString = "物料编码|>物料类型|>物料名称|>物料数量|>计量单位|>物料价格"
For ir = 0 To .Cols - 1
    Select Case ir
        Case 2
        .ColAlignment(ir) = 1
        .ColWidth(ir) = 1500
        Case Else
        'If ir > 0 Then
        .ColAlignment(ir) = 1
        .ColWidth(ir) = 1000
        'End If
    End Select
Next
End With
End Sub

Private Sub txtMsfg_KeyDown(KeyCode As Integer, Shift As Integer)
If mbAddNewFlag = True Or mbEditFlag = True Then
    If KeyCode = 13 Then Call TextMsfg(Msfg, 0)
End If
End Sub



Function Verdict() As Boolean
Dim ir As Integer
Verdict = True
If txtfields(0) = "" Then
   MsgBox "进料单号不对或为空", 48, "录入提示"
   Verdict = False
   Exit Function
End If
For ir = 1 To Msfg.Rows '判断明细的值
    If Msfg.TextMatrix(ir, 0) = "" Then Exit For
    If IsNumeric(Msfg.TextMatrix(ir, 3)) = False Then
        MsgBox "物料数量必须为数字型文本", 48, "明细错误"
        Verdict = False
        Exit Function
    End If
Next
If ir < 2 Then
   MsgBox "配方明细不能为空,请检查", 48, "录入提示"
   Verdict = False
   Exit Function
End If
Msfg.Tag = ir - 1
End Function
Sub EditKeyCode(MSFlexGrid As Control, Edt As Control, KeyCode As Integer, Shift As Integer)
Select Case KeyCode
    Case 27
        Edt.Visible = False
        MSFlexGrid.SetFocus
    Case 13
        MSFlexGrid.SetFocus
    Case 38
        MSFlexGrid.SetFocus
        DoEvents
        If MSFlexGrid.Row > MSFlexGrid.FixedRows Then
            MSFlexGrid.Row = MSFlexGrid.Row - 1
        End If
    Case 40
        MSFlexGrid.SetFocus
        DoEvents
        If MSFlexGrid.Row < MSFlexGrid.FixedRows - 1 Then
            MSFlexGrid.Row = MSFlexGrid.Row + 1
        End If
        
End Select
End Sub
Function Fgi(r As Integer, c As Integer) As Integer
Fgi = c + Msfg.Cols * r
End Function

Sub MSFlexGridEdit(MSFlexGrid As Control, Edt As Control, KeyAscii As Integer)
'使用已输入的字符

Select Case KeyAscii

    Case 0 To 32
        Edt = MSFlexGrid
        Edt.SelStart = 1000
        
    Case Else
        Edt = Chr(KeyAscii)
        Edt.SelStart = 1
        
End Select

Edt.Move MSFlexGrid.CellLeft, MSFlexGrid.CellTop, MSFlexGrid.CellWidth, MSFlexGrid.CellHeight
Edt.Visible = True
'Edt.SetFocus
End Sub

Public Sub TextMsfg(mMsfg As MSFlexGrid, Mark As Integer)
'当在文本框中按回车键时,输入焦点自动跳到下一个单元格
   If mMsfg.Col < mMsfg.Cols - 1 Then
       mMsfg.Col = mMsfg.Col + 1
   Else
      If Mark = 0 Then
        mMsfg.Col = 0
      Else
        mMsfg.Col = 1
      End If
      If mMsfg.Row < mMsfg.Rows - 1 Then
         mMsfg.Row = mMsfg.Row + 1
      Else
         mMsfg.Rows = mMsfg.Rows + 1
         mMsfg.Row = mMsfg.Row + 1
         mMsfg.TextMatrix(mMsfg.Row, 0) = mMsfg.Rows - 1
      End If
   End If
   mMsfg.SetFocus
End Sub

Public Sub MsfgKeyPress(nKey As Integer, nLeft As Integer, nTop As Integer, mMsfg As MSFlexGrid, mText As TextBox, BCheck As Boolean)
'本函数在 MSFlexGrid 控件中按键时,产生动作的处理
Dim ir, ic As Integer
If BCheck = True Then 'BCheck 是检查数据中是否可为 NULL
    ir = mMsfg.Row - 1
        For ic = 1 To mMsfg.Cols - 1
           If mMsfg.TextMatrix(ir, ic) = "" Then
                MsgBox "上一行还有些数据未填写", 48, "录入提示"
                Msfg.SetFocus
                Exit Sub
           End If
        Next
End If
Select Case nKey
       Case 0 To 32
            mText = Trim(mMsfg)
            mText.SelStart = 1000
       Case Else
            mText = Chr(nKey)
            mText.SelStart = 1
End Select
mText.Move mMsfg.CellLeft + nLeft, mMsfg.CellTop + nTop, mMsfg.CellWidth, mMsfg.CellHeight
mText.Visible = True
mText.SetFocus
End Sub

Public Function Verify_List(nRow As Integer, ss As String) As Boolean
Dim ir As Integer
Verify_List = True
For ir = 1 To nRow - 1
    If ss = ArrayList(ir) Then
       MsgBox "第 " & ir & " 行明细与第 " & nRow & " 行重复,请检查!", 48, "资料录入提示"
       Verify_List = False
       Exit Function
    End If
Next
ArrayList(nRow) = ss
End Function