frmproductionembryocontractout.frm

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

            Caption         =   "加工廠"
            Height          =   255
            Left            =   3600
            TabIndex        =   8
            Top             =   1080
            Width           =   855
         End
      End
   End
End
Attribute VB_Name = "frmProductionEmbryoOut"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim lngrow As Long
Private Sub ActiveBar21_ToolClick(ByVal Tool As ActiveBar2LibraryCtl.Tool)
     Select Case Tool.Name
        Case "cmdAdd":
            With frmProductionEmbryoOutEdit
                 .txtEmbryoContractNo = txtEmbryoContractNo
                 .txtSuppliersName = txtSuppliersName
                 .txtFabricCode = txtFabricCode
                 .txtFabricName = txtFabricName
                 .txtFactoryName = txtFactoryName
                 .newItem = True
                 .Show vbModal
            End With
        Case "cmdDel":
            DelOperatorInf
        Case "cmdCancel":
            Unload Me
        Case "cmdEdit":
            EditOperatorInf
        Case "cmdFind"
            fraFind.Visible = True
        Case "cmdExport":
            Dim strFile As String
            frmMain.CDFile.ShowOpen
            strFile = frmMain.CDFile.FileName
            If strFile = "" Then Exit Sub
            ExportExcel MSHF1, strFile
       End Select
End Sub
Private Function FormatQuery() As String
    FormatQuery = "select * from tProductionEmbryoOut where EmbryoContractNo='" & txtEmbryoContractNo & "'"
    If chkFoundDate.Value = vbChecked Then
        FormatQuery = FormatQuery & " and FoundDate >= '" & FormatDateStr(Founddate.Value, "long") & "'"
        FormatQuery = FormatQuery & " and FoundDate <= '" & FormatDateStr(EndFounddate.Value, "long") & "'"
    End If
    If Trim$(txtGreige) <> "" Then
        FormatQuery = FormatQuery & " and Greige" & objDatabase.FormatLikeSQL(txtGreige)
    End If
    If Trim$(txtwidth) <> "" Then
        FormatQuery = FormatQuery & " and Width" & objDatabase.FormatLikeSQL(txtwidth)
    End If
    If Trim$(txtRemark) <> "" Then
        FormatQuery = FormatQuery & " and Remark" & objDatabase.FormatLikeSQL(txtRemark)
    End If
End Function
Private Sub cmdCancel_Click()
     fraFind.Visible = False
End Sub

Private Sub CmdFabric_Click()
    frmFabricSelect.Show vbModal
    GetFabricInfo frmFabricSelect.FabricCode
End Sub
Private Sub GetFabricInfo(FabricNo As String)
        Dim rs As ADODB.Recordset
    On Error GoTo errLabel
    Set rs = New ADODB.Recordset
    With rs
      .CursorLocation = adUseClient
      .CursorType = adOpenDynamic
      .LockType = adLockOptimistic
      Set .ActiveConnection = Cn
    End With
    rs.Open "select * from tBasicProduct where FabricCode=" & objDatabase.FormatSQL(FabricNo)
        If Not rs.EOF Then
            txtGreige = NullValue(rs.Fields!Greige)
            txtwidth = NullValue(rs.Fields!Width)
        End If
    rs.Close

remClear:
    Set rs = Nothing
    Exit Sub
errLabel:
    objDatabase.DatabaseError
    GoTo remClear
End Sub

Private Sub CmdFind_Click()
     FillMshf1 FormatQuery
     fraFind.Visible = False
End Sub

Private Sub cmdFindAll_Click()
   FillMshf1 ("select * from tProductionEmbryoOut where EmbryoContractNo='" & txtEmbryoContractNo & "'")
   fraFind.Visible = False
End Sub

Private Sub Form_Load()
'设置窗口大小
    Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
    ActiveBar21.Bands("toolbar").Tools.item("cmdDel").Enabled = False
    ActiveBar21.Bands("toolbar").Tools.item("cmdEdit").Enabled = False
    InitTitle
    HookWheel Me.hwnd
End Sub
Private Sub InitTitle()
    Label1.Caption = "合同編號"
    Label2.Caption = "供應商"
    Label3.item(0).Caption = "布號"
    Label4.Caption = "布名"
    Label5.Caption = "加工廠"
    Label13.Caption = "備註"
    Label9.Caption = "幅寬"
    Label17.Caption = "胚組織"
    Label6.Caption = "投胚日期"
    Label8.Caption = "至"
    Label12.Caption = "模糊查詢項"
    cmdFindAll.Caption = "全部 &A"
    cmdFind.Caption = "查詢 &F"
    cmdCancel.Caption = "取消 &C"
    Me.Caption = "用坯記錄"
End Sub
'編輯坯布合約
Private Sub EditOperatorInf()
    frmProductionEmbryoOutEdit.newItem = False
    If lngrow = 1 Then
       MsgBox "請選擇進胚記錄!", vbInformation + vbOKOnly, "提示"
       Exit Sub
    End If
    With frmProductionEmbryoOutEdit
         .txtEmbryoContractNo = txtEmbryoContractNo
         .txtSuppliersName = txtSuppliersName
         .txtFabricCode = txtFabricCode
         .txtFabricName = txtFabricName
         .txtFactoryName = txtFactoryName
         .InitInfo MSHF1.TextMatrix(lngrow, 7)
         .Show vbModal
    End With
    ActiveBar21.Bands("toolbar").Tools.item("cmdDel").Enabled = False
    ActiveBar21.Bands("toolbar").Tools.item("cmdEdit").Enabled = False
End Sub
'刪除坯布合約
Private Sub DelOperatorInf()
    Dim strSql As String
    Dim mycomm As ADODB.Command
    If lngrow > MSHF1.Rows - 1 Then Exit Sub
    If lngrow <= 1 Then
        MsgBox "请选中一条要删除的记录！", vbExclamation, "提示"
        Exit Sub
    End If
        On Error GoTo errHandle
    
    If MsgBox("确定要刪除？", vbQuestion + vbYesNo, "询问") = vbNo Then
        Exit Sub
    Else
        strSql = "delete from  tProductionEmbryoOut where id=" & MSHF1.TextMatrix(lngrow, 7)
        objDatabase.ExecCmd strSql
        MsgBox "刪除成功!", vbInformation, "提示"
    End If
    Set mycomm = New ADODB.Command
     With mycomm
        .ActiveConnection = Cn
        .CommandText = "pModiEmbryoOut"
        .CommandType = 4
        .Prepared = True
        .Parameters.Append .CreateParameter("@iEmbryoContractNo", adVarChar, adParamInput, 20, txtEmbryoContractNo)
        .Parameters.Append .CreateParameter("@iModiAmount", adBigInt, adParamInput, 8, CInt(MSHF1.TextMatrix(lngrow, 5)))
        .Execute
     End With
    FillMshf1 ("select * from tProductionEmbryoOut where EmbryoContractNo='" & txtEmbryoContractNo & "'")
    frmProductionEmbryoContractMain.FillMshf1 ("select * from tProductionEmbryoContract")
    ActiveBar21.Bands("toolbar").Tools.item("cmdDel").Enabled = False
    ActiveBar21.Bands("toolbar").Tools.item("cmdEdit").Enabled = False
    Exit Sub
errHandle:

   objDatabase.DatabaseError
End Sub
Public Sub FillMshf1(ByVal strSql As String)
   Dim rs As ADODB.Recordset
   Dim lngrow As Long
      Screen.MousePointer = vbHourglass
      On Error GoTo errLabel
      Set rs = New ADODB.Recordset
      With rs
        .CursorLocation = adUseClient
        .CursorType = adOpenDynamic
        .LockType = adLockOptimistic
        Set .ActiveConnection = Cn
      End With
      rs.Open strSql
      With MSHF1
          .Redraw = False
          .Rows = 2
          .Cols = 8
          .Clear
          '初始化
         .WordWrap = False
         .TextMatrix(0, 0) = "序號"
         .ColWidth(0) = 500
         .TextMatrix(0, 1) = "投坯日期"
         .ColWidth(1) = 2000
         .TextMatrix(0, 2) = "胚組織"
         .ColWidth(2) = 2000
         .TextMatrix(0, 3) = "幅寬"
         .ColWidth(3) = 1200
         .TextMatrix(0, 4) = "備注"
         .ColWidth(4) = 3000
         .TextMatrix(0, 5) = "投坯胚數"
         .ColWidth(6) = 1200
         .TextMatrix(0, 6) = "加工單號"
         .ColWidth(7) = 1500
         .TextMatrix(0, 7) = ""
         .ColWidth(7) = 0
         '.....................................................
         .Rows = rs.RecordCount + 2
         On Error Resume Next
         For lngrow = 2 To rs.RecordCount + 1
                .TextMatrix(lngrow, 0) = lngrow - 1
                .TextMatrix(lngrow, 1) = FormatDateStr(rs.Fields!Founddate, "long")
                .TextMatrix(lngrow, 2) = Trim$(NullValue(rs.Fields!Greige))
                .TextMatrix(lngrow, 3) = Trim$(NullValue(rs.Fields!Width))
                .TextMatrix(lngrow, 4) = Trim$(NullValue(rs.Fields!Remark))
                .TextMatrix(lngrow, 5) = Trim$(NullValue(rs.Fields!Amount))
                .TextMatrix(lngrow, 6) = Trim$(NullValue(rs.Fields!OrderNo))
                .TextMatrix(lngrow, 7) = NullValue(rs.Fields!ID)
                rs.MoveNext
          Next
          lngrow = 0
          .TextMatrix(1, 0) = "总计"
          .TextMatrix(1, 1) = .Rows - 2
           SetItemBackColor MSHF1
           .Redraw = True
      End With
      rs.Close
remClear:
    Set rs = Nothing
    Screen.MousePointer = vbDefault
    Exit Sub
errLabel:
    On Error Resume Next
    MSHF1.Redraw = True
    GoTo remClear
End Sub
Public Sub InitInfo(strId As String)
    Dim rs As ADODB.Recordset
     ' 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 tProductionEmbryoContract where EmbryoContractNo='" & strId & "'"
      rs.Open strSql
        If Not rs.EOF Then
            txtEmbryoContractNo = NullValue(rs.Fields!EmbryoContractNo)
            txtSuppliersName = NullValue(rs.Fields!SuppliersName)
            txtFabricCode = NullValue(rs.Fields!FabricCode)
            txtFabricName = NullValue(rs.Fields!FabricName)
            txtFactoryName = NullValue(rs.Fields!FactoryName)
        End If
      rs.Close
      Set rs = Nothing
      FillMshf1 "select * from tProductionEmbryoOut where EmbryoContractNo='" & strId & "'"
      SystemExecuteEnd Me
Exit Sub
errLabel:
    SystemExecuteEnd Me
    objDatabase.DatabaseError
End Sub
Private Sub MSHF1_Click()
    lngrow = Val(MSHF1.row)
    If lngrow = 1 Then
       MSHF1.Sort = 1
    Else
       MSHF1.row = lngrow
        MSHF1.col = 0
        MSHF1.ColSel = MSHF1.Cols - 1
        ActiveBar21.Bands("toolbar").Tools.item("cmdDel").Enabled = True
        ActiveBar21.Bands("toolbar").Tools.item("cmdEdit").Enabled = True
    End If
End Sub

Private Sub MSHF1_DblClick()
   EditOperatorInf
End Sub