frmbeforecolorsub.frm

企业ERP系统 采用VB+SQL2000实现。 有客户合约

VERSION 5.00
Object = "{4932CEF1-2CAA-11D2-A165-0060081C43D9}#2.0#0"; "Actbar2.OCX"
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Begin VB.Form frmBeforeColorSub 
   Caption         =   "顏色明細"
   ClientHeight    =   4305
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7530
   LinkTopic       =   "Form1"
   ScaleHeight     =   4305
   ScaleWidth      =   7530
   StartUpPosition =   3  'Windows Default
   Begin ActiveBar2LibraryCtl.ActiveBar2 ActiveBar21 
      Height          =   4305
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   7530
      _LayoutVersion  =   1
      _ExtentX        =   13282
      _ExtentY        =   7594
      _DataPath       =   ""
      Bands           =   "frmBeforeColorSub.frx":0000
      Begin VB.Frame Frame1 
         Height          =   3675
         Left            =   60
         TabIndex        =   1
         Top             =   540
         Width           =   7395
         Begin VB.ComboBox subColorName 
            Height          =   315
            Left            =   1320
            TabIndex        =   22
            Top             =   1080
            Width           =   1995
         End
         Begin VB.ComboBox subFactoryName 
            Height          =   300
            Left            =   1320
            TabIndex        =   21
            Top             =   2340
            Width           =   1995
         End
         Begin VB.CheckBox subColor 
            Caption         =   "Check1"
            Height          =   195
            Left            =   1320
            TabIndex        =   20
            Top             =   1500
            Width           =   255
         End
         Begin VB.TextBox subLabdipNo 
            BackColor       =   &H8000000F&
            Enabled         =   0   'False
            Height          =   315
            Left            =   1320
            MaxLength       =   20
            TabIndex        =   9
            Top             =   240
            Width           =   1995
         End
         Begin VB.TextBox subOrderNo 
            BackColor       =   &H8000000F&
            Enabled         =   0   'False
            Height          =   315
            Left            =   1320
            MaxLength       =   2
            TabIndex        =   8
            Top             =   660
            Width           =   1995
         End
         Begin VB.TextBox subUpdateDate 
            BackColor       =   &H8000000F&
            Enabled         =   0   'False
            Height          =   315
            Left            =   5100
            TabIndex        =   7
            Top             =   3180
            Width           =   1995
         End
         Begin VB.TextBox subReviews 
            Height          =   315
            Left            =   1320
            MaxLength       =   20
            TabIndex        =   6
            Top             =   1860
            Width           =   1995
         End
         Begin VB.TextBox subUpdateOperator 
            Height          =   315
            Left            =   5100
            MaxLength       =   20
            TabIndex        =   5
            Top             =   2760
            Width           =   1995
         End
         Begin VB.TextBox subId 
            Height          =   315
            Left            =   2400
            TabIndex        =   2
            Top             =   1440
            Visible         =   0   'False
            Width           =   915
         End
         Begin MSComCtl2.DTPicker subReviewsDate 
            Height          =   315
            Left            =   1320
            TabIndex        =   3
            Top             =   3180
            Width           =   1995
            _ExtentX        =   3519
            _ExtentY        =   556
            _Version        =   393216
            Format          =   92798977
            CurrentDate     =   39583
         End
         Begin MSComCtl2.DTPicker subLabdipDate 
            Height          =   315
            Left            =   1320
            TabIndex        =   4
            Top             =   2760
            Width           =   1995
            _ExtentX        =   3519
            _ExtentY        =   556
            _Version        =   393216
            Format          =   92798977
            CurrentDate     =   39583
         End
         Begin VB.Label Label50 
            Caption         =   "上批單號"
            Height          =   315
            Left            =   180
            TabIndex        =   19
            Top             =   300
            Width           =   795
         End
         Begin VB.Label Label40 
            Caption         =   "填入日期"
            Height          =   315
            Left            =   3840
            TabIndex        =   18
            Top             =   3240
            Width           =   915
         End
         Begin VB.Label Label3 
            Caption         =   "顏色結果"
            Height          =   255
            Index           =   4
            Left            =   180
            TabIndex        =   17
            Top             =   1560
            Width           =   1035
         End
         Begin VB.Label Label23 
            Caption         =   "評語日期"
            Height          =   255
            Left            =   180
            TabIndex        =   16
            Top             =   3240
            Width           =   1035
         End
         Begin VB.Label Label3 
            Caption         =   "顏色名稱"
            Height          =   255
            Index           =   3
            Left            =   180
            TabIndex        =   15
            Top             =   1140
            Width           =   1035
         End
         Begin VB.Label Label22 
            Caption         =   "訂單號"
            Height          =   255
            Left            =   180
            TabIndex        =   14
            Top             =   720
            Width           =   1035
         End
         Begin VB.Label Label15 
            Caption         =   "評語"
            Height          =   255
            Left            =   180
            TabIndex        =   13
            Top             =   1980
            Width           =   1035
         End
         Begin VB.Label Label13 
            Caption         =   "加工廠"
            Height          =   255
            Left            =   180
            TabIndex        =   12
            Top             =   2400
            Width           =   1035
         End
         Begin VB.Label Label10 
            Caption         =   "上批日期"
            Height          =   255
            Left            =   180
            TabIndex        =   11
            Top             =   2820
            Width           =   1035
         End
         Begin VB.Label Label7 
            Caption         =   "填寫人"
            Height          =   255
            Left            =   3840
            TabIndex        =   10
            Top             =   2760
            Width           =   1035
         End
      End
   End
End
Attribute VB_Name = "frmBeforeColorSub"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public newItem As Boolean 'true表示增加
Private Sub ActiveBar21_ToolClick(ByVal Tool As ActiveBar2LibraryCtl.Tool)
    Select Case Tool.Name
            Case "cmdSave":
                 Save newItem
           Case "cmdCancel":
                Unload Me
            Case "cmdDel":
                DelOperatorInf
    End Select
End Sub
Private Sub Form_Load()
    Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
    Initcbb subFactoryName, "FactoryName", "tBasicFactory"
    Initcbb subColorName, "Color", "tBasicColor"
    InitTitle
End Sub
Private Sub InitTitle()
    Label50.Caption = "上批單號"
    Label22.Caption = "訂單號"
    Label3.item(3).Caption = "顏色名稱"
    Label3.item(4).Caption = "顏色結果"
    Label15.Caption = "評語"
    Label13.Caption = "加工廠"
    Label10.Caption = "上批日期"
    Label7.Caption = "填寫人"
    Label23.Caption = "評語日期"
    Label40.Caption = "填入日期"
    Me.Caption = "顏色明細"
End Sub
Private Sub DelOperatorInf()
    Dim strSql As String
    On Error GoTo errHandle
    If MsgBox("确定要刪除？", vbQuestion + vbYesNo, "询问") = vbNo Then
        Exit Sub
    Else
        strSql = "delete from  tBeforeLabdipColorSub where LabdipNo='" & subLabdipNo & "' and ColorName='" & subColorName & "'"
        objDatabase.ExecCmd strSql
        MsgBox "刪除成功!", vbInformation, "提示"
    End If
        frmBeforeInfo.FillMshf3 ("select * from tBeforeLabdipColorSub where LabdipNo='" & subLabdipNo & "'")
    Unload Me
    Exit Sub
errHandle:
   objDatabase.DatabaseError
    
End Sub
Public Sub InitInfo(strId As String, LabdipNo As String, OrderNo As String)
    If newItem = False Then
    Dim rs As ADODB.Recordset
      SystemExecuteStart Me
     ' On Error GoTo errLabel
      Set rs = New ADODB.Recordset
      With rs
        .CursorLocation = adUseClient
        .CursorType = adOpenDynamic
        .LockType = adLockOptimistic
        Set .ActiveConnection = Cn
      End With
      Dim strSql As String
        strSql = "select * from tBeforeLabdipColorSub where id=" & strId
        rs.Open strSql
        If Not rs.EOF Then
            subLabdipNo.Text = NullValue(rs.Fields!LabdipNo)
            subOrderNo.Text = NullValue(rs.Fields!OrderNo)
            subId = NullValue(rs.Fields!ID)
            subColorName.Text = NullValue(rs.Fields!ColorName)
            subColor.Value = IIf(rs.Fields!Color, "1", "0")
            subReviews.Text = NullValue(rs.Fields!Reviews)
            subFactoryName.Text = NullValue(rs.Fields!FactoryName)
            subLabdipDate = NullValue(rs.Fields!LabdipDate)
            subReviewsDate = NullValue(rs.Fields!ReviewsDate)
            subUpdateOperator = NullValue(rs.Fields!UpdateOperator)
            subUpdateDate = NullValue(rs.Fields!UpdateDate)
        End If
        rs.Close
      Set rs = Nothing
      SystemExecuteEnd Me
Exit Sub
Else
        subLabdipNo.Text = LabdipNo
        subOrderNo.Text = OrderNo
SystemExecuteEnd Me
Exit Sub
End If
errLabel:
    SystemExecuteEnd Me
    objDatabase.DatabaseError
End Sub
Private Sub Save(Optional blModi As Boolean)
    Dim strSql As String
    Dim strCdh, strZl, strSl As String
    Dim rs As ADODB.Recordset
    Dim mycomm As ADODB.Command
    Set rs = New ADODB.Recordset
    With rs
      .CursorLocation = adUseClient
      .CursorType = adOpenDynamic
      .LockType = adLockOptimistic
      Set .ActiveConnection = Cn
    End With
        On Error GoTo errHandle
        If blModi Then
        strSql = "select * from tBeforeLabdipColorSub"
        rs.Open strSql
            If subColorName = "" Or subLabdipNo = "" Or subOrderNo = "" Then
               MsgBox "請將信息填寫完整 ", vbCritical, " 提示"
               rs.Close
               Set rs = Nothing
               subLabdipNo.SetFocus
               Exit Sub
            End If
            If MsgBox("是否增加？", vbQuestion + vbYesNo, "询问") = vbNo Then
                rs.Close
                Set rs = Nothing
                Exit Sub
            End If
                    
            rs.AddNew '新建
        Else
            strSql = "select * from tBeforeLabdipColorsub where id=" & subId
            rs.Open strSql
            If rs.EOF Then '修改
                MsgBox "没有可修改的信息!", vbExclamation, "修改"
                rs.Close
                Set rs = Nothing
                subLabdipNo.SetFocus
                Exit Sub
            End If
            If MsgBox("是否修改记录？", vbYesNo + vbQuestion, "修改") = vbNo Then
                rs.Close
                Set rs = Nothing
                Exit Sub
            End If
        End If
        rs.Fields!LabdipNo = Trim$(subLabdipNo)
        rs.Fields!OrderNo = Trim$(subOrderNo)
        rs.Fields!ColorName = Trim$(subColorName)
        rs.Fields!Color = subColor.Value
        rs.Fields!Reviews = Trim$(subReviews)
        rs.Fields!FactoryName = Trim$(subFactoryName)
        rs.Fields!LabdipDate = subLabdipDate.Value
        rs.Fields!ReviewsDate = subReviewsDate.Value
        rs.Fields!UpdateOperator = Trim$(subUpdateOperator)
        rs.Fields!UpdateDate = Now
        rs.Update
        MsgBox "操作成功！", vbInformation, "恭喜"
        rs.Close
        Set mycomm = New ADODB.Command
         With mycomm
            .ActiveConnection = Cn
            .CommandText = "pModiColor"
            .CommandType = 4
            .Prepared = True
            .Parameters.Append .CreateParameter("@Color", 20, 1, 1, subColor.Value)
            .Parameters.Append .CreateParameter("@ColorName", 129, 1, 50, subColorName.Text)
            .Execute
         End With
         rs.Open ("select Color from tBeforeLabdipColor where Color = 0 and LabdipNo='" & subLabdipNo & "'")
         If rs.EOF Or rs.BOF Then
            frmBeforeInfo.chkColor.Value = 1
         Else
            frmBeforeInfo.chkColor.Value = 0
         End If
         rs.Close
         Set rs = Nothing
         frmBeforeInfo.FillMshf2 ("select * from tBeforeLabdipColor where LabdipNo='" & subLabdipNo & "'")
        frmBeforeInfo.FillMshf3 ("select * from tBeforeLabdipColorSub where LabdipNo='" & subLabdipNo & "'")
        Unload Me
        Exit Sub
errHandle:
    Set rs = Nothing
    objDatabase.DatabaseError
End Sub