frminput.frm

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

VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Object = "{5E9E78A0-531B-11CF-91F6-C2863C385E30}#1.0#0"; "MSFLXGRD.OCX"
Begin VB.Form frmInput 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "进料单"
   ClientHeight    =   7005
   ClientLeft      =   285
   ClientTop       =   1065
   ClientWidth     =   11250
   ControlBox      =   0   'False
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MDIChild        =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   7005
   ScaleWidth      =   11250
   ShowInTaskbar   =   0   'False
   Begin VB.PictureBox picButtons 
      Align           =   2  'Align Bottom
      BorderStyle     =   0  'None
      Height          =   915
      Left            =   0
      ScaleHeight     =   915
      ScaleWidth      =   11250
      TabIndex        =   5
      Top             =   6090
      Width           =   11250
      Begin VB.CommandButton cmdAdd 
         Caption         =   "添加(&A)"
         Height          =   300
         Left            =   1680
         TabIndex        =   15
         Top             =   0
         Width           =   1095
      End
      Begin VB.CommandButton cmdUpdate 
         Caption         =   "更新(&U)"
         Height          =   300
         Left            =   2820
         TabIndex        =   12
         Top             =   0
         Visible         =   0   'False
         Width           =   1095
      End
      Begin VB.CommandButton cmdLast 
         Height          =   300
         Left            =   7785
         Picture         =   "frmInput.frx":0000
         Style           =   1  'Graphical
         TabIndex        =   11
         Top             =   480
         UseMaskColor    =   -1  'True
         Width           =   345
      End
      Begin VB.CommandButton cmdNext 
         Height          =   300
         Left            =   7440
         Picture         =   "frmInput.frx":0342
         Style           =   1  'Graphical
         TabIndex        =   10
         Top             =   480
         UseMaskColor    =   -1  'True
         Width           =   345
      End
      Begin VB.CommandButton cmdPrevious 
         Height          =   300
         Left            =   3570
         Picture         =   "frmInput.frx":0684
         Style           =   1  'Graphical
         TabIndex        =   9
         Top             =   480
         UseMaskColor    =   -1  'True
         Width           =   345
      End
      Begin VB.CommandButton cmdFirst 
         Height          =   300
         Left            =   3225
         Picture         =   "frmInput.frx":09C6
         Style           =   1  'Graphical
         TabIndex        =   8
         Top             =   480
         UseMaskColor    =   -1  'True
         Width           =   345
      End
      Begin VB.CommandButton cmdRefresh 
         Caption         =   "刷新(&R)"
         Height          =   300
         Left            =   6285
         TabIndex        =   7
         Top             =   0
         Width           =   1095
      End
      Begin VB.CommandButton cmdClose 
         Caption         =   "关闭(&C)"
         Height          =   300
         Left            =   7440
         TabIndex        =   6
         Top             =   0
         Width           =   1095
      End
      Begin VB.CommandButton cmdEdit 
         Caption         =   "编辑(&E)"
         Height          =   300
         Left            =   3975
         TabIndex        =   16
         Top             =   0
         Width           =   1095
      End
      Begin VB.CommandButton cmdDelete 
         Caption         =   "删除(&D)"
         Height          =   300
         Left            =   5130
         TabIndex        =   17
         Top             =   0
         Width           =   1095
      End
      Begin VB.CommandButton cmdCancel 
         Caption         =   "取消(&C)"
         Height          =   300
         Left            =   3975
         TabIndex        =   13
         Top             =   0
         Visible         =   0   'False
         Width           =   1095
      End
      Begin VB.CommandButton cmdDel 
         Caption         =   "删行(&D)"
         Height          =   300
         Left            =   5160
         TabIndex        =   14
         Top             =   0
         Visible         =   0   'False
         Width           =   1095
      End
      Begin VB.Label lblStatus 
         Alignment       =   2  'Center
         BackColor       =   &H00FFFFFF&
         BorderStyle     =   1  'Fixed Single
         Caption         =   " "
         Height          =   300
         Left            =   4005
         TabIndex        =   18
         Top             =   480
         Width           =   3345
      End
   End
   Begin VB.Frame fraIncome 
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   14.25
         Charset         =   134
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FF0000&
      Height          =   975
      Left            =   120
      TabIndex        =   1
      Top             =   0
      Width           =   11055
      Begin VB.TextBox txtFields 
         DataField       =   "contract_no"
         Height          =   270
         Index           =   2
         Left            =   6420
         TabIndex        =   21
         Top             =   400
         Width           =   4515
      End
      Begin MSComCtl2.DTPicker vcDate 
         Height          =   300
         Left            =   3960
         TabIndex        =   20
         Top             =   400
         Width           =   1455
         _ExtentX        =   2566
         _ExtentY        =   529
         _Version        =   393216
         Format          =   61997057
         CurrentDate     =   37495
      End
      Begin VB.TextBox txtFields 
         DataField       =   "contract_no"
         Height          =   270
         Index           =   0
         Left            =   960
         TabIndex        =   2
         Top             =   400
         Width           =   1755
      End
      Begin VB.Label lblFieldLabel 
         Alignment       =   1  'Right Justify
         AutoSize        =   -1  'True
         Caption         =   "备注说明:"
         DataField       =   " "
         ForeColor       =   &H00800000&
         Height          =   180
         Index           =   1
         Left            =   5580
         TabIndex        =   22
         Top             =   400
         Width           =   810
      End
      Begin VB.Label lblFieldLabel 
         Alignment       =   1  'Right Justify
         AutoSize        =   -1  'True
         Caption         =   "进料日期:"
         ForeColor       =   &H00800000&
         Height          =   180
         Index           =   3
         Left            =   3000
         TabIndex        =   4
         Top             =   400
         Width           =   810
      End
      Begin VB.Label lblFieldLabel 
         Alignment       =   1  'Right Justify
         AutoSize        =   -1  'True
         Caption         =   "进料单号:"
         DataField       =   " "
         ForeColor       =   &H00800000&
         Height          =   180
         Index           =   0
         Left            =   120
         TabIndex        =   3
         Top             =   400
         Width           =   810
      End
   End
   Begin VB.TextBox txtMsfg 
      BackColor       =   &H80000018&
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   285
      Left            =   1320
      TabIndex        =   0
      Top             =   1800
      Visible         =   0   'False
      Width           =   1065
   End
   Begin MSFlexGridLib.MSFlexGrid Msfg 
      Height          =   4815
      Left            =   120
      TabIndex        =   19
      Top             =   1080
      Width           =   11025
      _ExtentX        =   19447
      _ExtentY        =   8493
      _Version        =   393216
      Rows            =   100
      Cols            =   6
      FixedCols       =   0
      BackColor       =   -2147483624
      AllowUserResizing=   3
      FormatString    =   "物料编码|>物料类型|>物料名称|>物料数量|>计量单位|>物料价格"
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "宋体"
         Size            =   9.75
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
End
Attribute VB_Name = "frmInput"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit
Dim WithEvents adoPrimaryRS As Recordset
Attribute adoPrimaryRS.VB_VarHelpID = -1
Dim WithEvents adoSecondRS As Recordset
Attribute adoSecondRS.VB_VarHelpID = -1
Dim WithEvents rs As Recordset
Attribute rs.VB_VarHelpID = -1
Dim WithEvents rsTemp As Recordset
Attribute rsTemp.VB_VarHelpID = -1
Dim mbChangedByCode As Boolean
Dim mvBookMark As Variant
Dim mbEditFlag As Boolean
Dim mbAddNewFlag As Boolean
Dim mbDataChanged As Boolean
Dim mbGridFlag As Boolean
Dim strCnn As String
Dim ssql As String
Dim i, j, tmpSum As Variant
Dim msg As String
Dim so As String
Dim exchange As Variant
Dim ArrayList() As String

Private Sub adoPrimaryRS_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
    On Error Resume Next
    lblStatus.Caption = " 当前记录： " & CStr(adoPrimaryRS.AbsolutePosition) & "/" & CStr(adoPrimaryRS.RecordCount)
End Sub

Private Sub cmdAdd_Click()
'On Error GoTo AddErr
On Error Resume Next
    With adoPrimaryRS
    If Not (.BOF And .EOF) Then
        mvBookMark = .Bookmark
    End If
    End With

            For i = 0 To adoPrimaryRS.Fields.Count - 1
                Select Case i
                   Case 0
                        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(i) = Mstr
                        rsTemp.Close
                        Set rsTemp = Nothing
                   Case 1
                    vcDate.value = Date
                   Case 2
                    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 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
      
      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 sum(output_qty) from input where input_no='" & so & "'", db, adOpenStatic, adLockOptimistic

    If rs.RecordCount = 0 Then
      MsgBox "不存在这个进料单号！", vbExclamation, "进料单"
      rs.Close
      Exit Sub
    End If
    
    If rs.Fields(0) > 0 Then
      MsgBox "这个进料单号已经出料！", vbExclamation, "进料单"
      rs.Close
      Exit Sub
    End If
    rs.Close

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

  If rs.RecordCount <> 0 Then
    msg = MsgBox("确定要删除吗？", vbYesNo + vbQuestion, "进料单")
    If msg = vbYes Then

        db.Execute "delete from input where input_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