frmreturn.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 frmReturn 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "退料单"
   ClientHeight    =   7125
   ClientLeft      =   510
   ClientTop       =   1125
   ClientWidth     =   11190
   ControlBox      =   0   'False
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MDIChild        =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   7125
   ScaleWidth      =   11190
   ShowInTaskbar   =   0   'False
   Begin VB.PictureBox picButtons 
      Align           =   2  'Align Bottom
      BorderStyle     =   0  'None
      Height          =   915
      Left            =   0
      ScaleHeight     =   915
      ScaleWidth      =   11190
      TabIndex        =   6
      Top             =   6210
      Width           =   11190
      Begin VB.CommandButton cmdLast 
         Height          =   300
         Left            =   8025
         Picture         =   "frmReturn.frx":0000
         Style           =   1  'Graphical
         TabIndex        =   18
         Top             =   480
         UseMaskColor    =   -1  'True
         Width           =   345
      End
      Begin VB.CommandButton cmdNext 
         Height          =   300
         Left            =   7680
         Picture         =   "frmReturn.frx":0342
         Style           =   1  'Graphical
         TabIndex        =   17
         Top             =   480
         UseMaskColor    =   -1  'True
         Width           =   345
      End
      Begin VB.CommandButton cmdPrevious 
         Height          =   300
         Left            =   3810
         Picture         =   "frmReturn.frx":0684
         Style           =   1  'Graphical
         TabIndex        =   16
         Top             =   480
         UseMaskColor    =   -1  'True
         Width           =   345
      End
      Begin VB.CommandButton cmdFirst 
         Height          =   300
         Left            =   3465
         Picture         =   "frmReturn.frx":09C6
         Style           =   1  'Graphical
         TabIndex        =   15
         Top             =   480
         UseMaskColor    =   -1  'True
         Width           =   345
      End
      Begin VB.CommandButton cmdRefresh 
         Caption         =   "刷新(&R)"
         Height          =   300
         Left            =   6525
         TabIndex        =   14
         Top             =   0
         Width           =   1095
      End
      Begin VB.CommandButton cmdClose 
         Caption         =   "关闭(&C)"
         Height          =   300
         Left            =   7680
         TabIndex        =   13
         Top             =   0
         Width           =   1095
      End
      Begin VB.CommandButton cmdAdd 
         Caption         =   "添加(&A)"
         Height          =   300
         Left            =   3060
         TabIndex        =   12
         Top             =   0
         Width           =   1095
      End
      Begin VB.CommandButton cmdEdit 
         Caption         =   "编辑(&E)"
         Height          =   300
         Left            =   4215
         TabIndex        =   11
         Top             =   0
         Width           =   1095
      End
      Begin VB.CommandButton cmdUpdate 
         Caption         =   "更新(&U)"
         Height          =   300
         Left            =   3060
         TabIndex        =   10
         Top             =   0
         Visible         =   0   'False
         Width           =   1095
      End
      Begin VB.CommandButton cmdCancel 
         Caption         =   "取消(&C)"
         Height          =   300
         Left            =   4215
         TabIndex        =   9
         Top             =   0
         Visible         =   0   'False
         Width           =   1095
      End
      Begin VB.CommandButton cmdDelete 
         Caption         =   "删除(&D)"
         Height          =   300
         Left            =   5370
         TabIndex        =   8
         Top             =   0
         Width           =   1095
      End
      Begin VB.CommandButton cmdDel 
         Caption         =   "删行(&D)"
         Height          =   300
         Left            =   5370
         TabIndex        =   7
         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            =   4245
         TabIndex        =   19
         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          =   615
      Left            =   120
      TabIndex        =   1
      Top             =   0
      Width           =   10935
      Begin VB.TextBox txtFields 
         DataField       =   "contract_no"
         Height          =   270
         Index           =   0
         Left            =   960
         TabIndex        =   3
         Top             =   240
         Width           =   1755
      End
      Begin MSComCtl2.DTPicker vcDate 
         Height          =   300
         Left            =   4080
         TabIndex        =   2
         Top             =   240
         Width           =   1695
         _ExtentX        =   2990
         _ExtentY        =   529
         _Version        =   393216
         Format          =   61603841
         CurrentDate     =   37495
      End
      Begin VB.Label lblFieldLabel 
         Alignment       =   1  'Right Justify
         AutoSize        =   -1  'True
         Caption         =   "退料单日期:"
         ForeColor       =   &H00800000&
         Height          =   180
         Index           =   3
         Left            =   3060
         TabIndex        =   5
         Top             =   285
         Width           =   990
      End
      Begin VB.Label lblFieldLabel 
         Alignment       =   1  'Right Justify
         AutoSize        =   -1  'True
         Caption         =   "退料单号:"
         DataField       =   " "
         ForeColor       =   &H00800000&
         Height          =   180
         Index           =   0
         Left            =   120
         TabIndex        =   4
         Top             =   300
         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             =   1440
      Visible         =   0   'False
      Width           =   1065
   End
   Begin MSFlexGridLib.MSFlexGrid Msfg 
      Height          =   5415
      Left            =   120
      TabIndex        =   20
      Top             =   720
      Width           =   10905
      _ExtentX        =   19235
      _ExtentY        =   9551
      _Version        =   393216
      Rows            =   100
      Cols            =   8
      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 = "frmReturn"
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 = "R" + mm
                        
                        yymm = yy + mm
                           
                        Set rsTemp = New Recordset
                        rsTemp.Open "select max(return_no) as mdinno from returnput where return_no like 'R" + yymm + "%' ", db, adOpenStatic, adLockOptimistic
                        
                        
                        If IsNull(rsTemp!mdinno) = True Then
                            Mstr = "R" & yymm & "00001"
                        Else
                             
                            Dim a As String
                            a = Right(Trim((rsTemp!mdinno)), 5)
                            a = Right(str(Int(a) + 100001), 5)
                            
                            Mstr = "R" + 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,return_qty,material_unit,material_price,remark  from returnput where return_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 returnput where return_no='" & so & "'", db, adOpenStatic, adLockOptimistic

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

  rs.Open "select * from returnput where return_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,return_qty from returnput where return_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 returnput where return_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,return_qty,material_unit,material_price,remark  from returnput where return_no='" & txtfields(0) & "'"

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

    adoSecondRS.MoveFirst
    If adoSecondRS.BOF And adoSecondRS.EOF Then