frmoutput.frm

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

          
  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

 
      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 output_no,output_date,department,employee,audit,warehouse from output", 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 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


      
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 - 2
       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
           frmOutputList.Tag = "Output"
           frmOutputList.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, 1325, 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 0, 3, 7
        .ColAlignment(ir) = 1
        .ColWidth(ir) = 2000
        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, 4)) = False Then
        MsgBox "物料数量必须为数字型文本", 48, "明细错误"
        Verdict = False
        Exit Function
    If IsNumeric(Msfg.TextMatrix(ir, 6)) = False Then
        MsgBox "物料价格必须为数字型文本", 48, "明细错误"
        Verdict = False
        Exit Function
    End If
    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 - 2
           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