hfrm306.frm

饲料生产控制系统

' 僀儀儞僩柤: txt_val_KeyDown
' 婡擻丂丂丂: Fn僉乕偑墴偝傟偨偲偒偺張棟
'******************************************************************************
Private Sub txt_val_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim values As Long
    
    If IsNumeric(txt_val.Text) = False Then
        rtnVal = MsgBox(ErrorMsg306_4, vbOKOnly + 64, ErrorMsgTit306_1)
        txt_val.Text = fpSpread.ActiveRow
        Exit Sub
    End If

    If KeyCode = 13 Then
        
        If adoRes.recordcount = 0 Then
            txt_val.Text = 0
            Exit Sub
        End If
    
        If CLng(txt_val.Text) > 0 And _
           CLng(txt_val.Text) < adoRes.recordcount + 1 Then
           
            Call SetActiveCell(1, CLng(txt_val.Text))
        Else
            rtnVal = MsgBox(ErrorMsg306_4, vbOKOnly + 64, ErrorMsgTit306_1)
            txt_val.Text = valrow
        End If
        
    End If
End Sub

'******************************************************************************
' 僀儀儞僩柤: cmdClose_GotFocus
' 婡擻丂丂丂: 僼僅儞僩傪愝掕偡傞丅
'******************************************************************************
Private Sub cmdClose_GotFocus()
    cmdClose.ForeColor = vbRed
End Sub

'******************************************************************************
' 僀儀儞僩柤: cmdClose_LostFocus
' 婡擻丂丂丂: 僼僅儞僩傪愝掕偡傞丅
'******************************************************************************
Private Sub cmdClose_LostFocus()
    cmdClose.ForeColor = vbBlack
End Sub

'******************************************************************************
' 僀儀儞僩柤: cmdPrint_GotFocus
' 婡擻丂丂丂: 僼僅儞僩傪愝掕偡傞丅
'******************************************************************************
Private Sub cmdPrint_GotFocus()
    cmdPrint.ForeColor = vbRed
End Sub

'******************************************************************************
' 僀儀儞僩柤: cmdPrint_LostFocus
' 婡擻丂丂丂: 僼僅儞僩傪愝掕偡傞丅
'******************************************************************************
Private Sub cmdPrint_LostFocus()
    cmdPrint.ForeColor = vbBlack
End Sub

'******************************************************************************
' 僀儀儞僩柤: cmdPrintAll_GotFocus
' 婡擻丂丂丂: 僼僅儞僩傪愝掕偡傞丅
'******************************************************************************
Private Sub cmdPrintAll_GotFocus()
    cmdPrintAll.ForeColor = vbRed
End Sub

'******************************************************************************
' 僀儀儞僩柤: cmdPrintAll_LostFocus
' 婡擻丂丂丂: 僼僅儞僩傪愝掕偡傞丅
'******************************************************************************
Private Sub cmdPrintAll_LostFocus()
    cmdPrintAll.ForeColor = vbBlack
End Sub

'******************************************************************************
' 僀儀儞僩柤: Form_KeyUp
' 婡擻丂丂丂: Ctrl,Alt,Shift 僉乕偺張棟偡傞
'******************************************************************************
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = 16 Or KeyCode = 17 Or KeyCode = 18 Then
        KeyFlag = False
    End If
End Sub

Private Sub btn_firstend_DblClick(Cancel As MSForms.ReturnBoolean)
    Cancel = True
End Sub

Private Sub btn_last_DblClick(Cancel As MSForms.ReturnBoolean)
    Cancel = True
End Sub

Private Sub btn_lastend_DblClick(Cancel As MSForms.ReturnBoolean)
    Cancel = True
End Sub

Private Sub btn_next_DblClick(Cancel As MSForms.ReturnBoolean)
    Cancel = True
End Sub
'##### END ########丂僀儀儞僩丂################################################

'#####STRAT########丂娭丂丂悢丂################################################
'******************************************************************************
' 娭悢柤 : GetDataGrid
' 婡擻丂 : Spread偵僨乕僞傪撉傒崬傓
' 堷悢   : 側偟
' 栠傝抣 : True:惉岟    False:幐攕
'******************************************************************************
Private Function GetDataGrid() As Boolean
    Dim CurRecount As Long
    Dim i As Long
    Dim j As Long
    
On Error GoTo Err                ' 僄儔乕偺応崌

    GetDataGrid = False
    
    strSql = vbNullString
    strSql = strSql & "SELECT FctDate,MeigaraCode, "
    strSql = strSql & "MeigaraName, "
    strSql = strSql & "TotYoteiWeight, "
    strSql = strSql & "TotEndWeight, "
    strSql = strSql & "KeiryoTime, "
    strSql = strSql & "TotSa, "
    strSql = strSql & "TotBudomari, "
    strSql = strSql & "Nouryoku "
    strSql = strSql & "From MeigaraLogT02_Add "
    strSql = strSql & "where (CONVERT(int, SUBSTRING(CONVERT(char(19),FctDate," & _
                      "120), 1, 4) + SUBSTRING(CONVERT(char(19), FctDate, 120)," & _
                      "6, 2)) >= '" & Trim(GetStrMonth(Dtp1.Value)) & "') "
    strSql = strSql & "and   (CONVERT(int, SUBSTRING(CONVERT(char(19), FctDate," & _
                      " 120), 1, 4) + SUBSTRING(CONVERT(char(19), FctDate, 120)," & _
                      " 6, 2)) <= '" & Trim(GetStrMonth(Dtp2.Value)) & "') "
    
    strSql = strSql & " order by FctDate desc "
    
    Set adoRes = Nothing
    
    '僨乕僞傪庢摼偡傞
    If gfCreateRecordset(strSql, adoRes) = False Then
        Exit Function
    End If

    '僨乕僞偑懚嵼偟側偄偺応崌
    If adoRes.recordcount = 0 Then
        fpSpread.MaxRows = 0
        Exit Function
    Else
        '儁乕僕偺僨乕僞
        CurRecount = adoRes.recordcount
    End If

    'Spread偵僨乕僞傪彂偒偰
    'Spread偵僨乕僞傪彂偒偰
    With fpSpread
        .MaxCols = 8
        .MaxRows = adoRes.recordcount
     For i = 0 To adoRes.recordcount - 1 Step 1
            .row = i + 1
            
            .col = 1                                                  '恊尨椏僐乕僪
            If IsNull(adoRes.Fields("MeigaraCode")) Then
               .Text = ""
            Else
               .Text = adoRes.Fields("MeigaraCode")
            End If
            
            .col = 2                                                  '尨椏柤
            If IsNull(adoRes.Fields("MeigaraName")) Then
               .Text = ""
            Else
               .Text = adoRes.Fields("MeigaraName")
            End If
            
            .col = 3                                                  '愝掕抣
               If IsNull(adoRes.Fields("TotYoteiWeight")) Then
               .Text = ""
            Else
                .Text = Format(CDbl(adoRes.Fields("TotYoteiWeight")) / 1000, "#0.000")
            End If
           
            .col = 4                                                  '寁検抣
            If IsNull(adoRes.Fields("TotEndWeight")) Then
               .Text = ""
            Else
               .Text = Format(CDbl(adoRes.Fields("TotEndWeight")) / 1000, "#0.000")
            End If
                      
            .col = 5                                                  '嵎
            If IsNull(adoRes.Fields("KeiryoTime")) Then
               .Text = ""
            Else
               .Text = GetStrDate(adoRes.Fields("KeiryoTime"))
            End If
            
            .col = 6                                                  '寁検帪娫(昩)
            If IsNull(adoRes.Fields("TotSa")) Then
               .Text = ""
            Else
               .Text = Format(CDbl(adoRes.Fields("TotSa")) / 1000, "#0.000")
            End If
            
            .col = 7                                                  '寁検帪娫(昩)
            If IsNull(adoRes.Fields("Nouryoku")) Then
               .Text = ""
            Else
               .Text = adoRes.Fields("Nouryoku")
            End If
            
            .col = 8                                                  '寁検帪娫(昩)
            If IsNull(adoRes.Fields("TotBudomari")) Then
               .Text = ""
            Else
               .Text = adoRes.Fields("TotBudomari")
            End If
          
            adoRes.MoveNext
                       
        Next i
    
    End With
'    With fpSpread
'        .MaxCols = 8
'        .MaxRows = CurRecount
'        For i = 0 To CurRecount - 1 Step 1
'            .row = i + 1
'            For j = 1 To 8 Step 1
'                .col = j
'                If Not adoRes.Fields(j - 1).Value = "" Then
'                    If j = 5 Then
'                        .Text = GetStrDate(Trim(adoRes.Fields(j - 1).Value))
'                    Else
'                        .Text = Trim(adoRes.Fields(j - 1).Value)
'                    End If
'
'                Else
'                .Text = ""
'                End If
'            Next j
'            adoRes.MoveNext
'            If adoRes.EOF Then
'              Exit Function
'            End If
'        Next i
'    End With

    GetDataGrid = True

Resume_Err:
    Exit Function

Err:
    Set adoRes = Nothing
    GetDataGrid = False
    rtnVal = MsgBox(ErrorMsg2, vbOKOnly + 64, ErrorMsgDefTit)
    Resume Resume_Err
    
End Function

'******************************************************************************
' 娭悢柤 : GetTotleData
' 婡擻丂 : 僨乕僞傪庢摼偡傞
' 堷悢   : 側偟
' 栠傝抣 : True:惉岟    False:幐攕
'******************************************************************************
Private Function GetTotleData() As Boolean
    Dim CurRecount As Long
    Dim i As Integer
    Dim tol_Expr1 As Double
    Dim tol_Expr2 As Double
    Dim tol_Expr3 As Double
    Dim tol_Expr4 As Double
    Dim tol_Expr5 As Double
    Dim tol_Expr6 As Double
    
On Error GoTo Err                ' 僄儔乕偺応崌
    
    GetTotleData = False
    
    CurRecount = adoRes.recordcount
    
    If CurRecount = 0 Then
        Exit Function
    End If
    
    adoRes.MoveFirst
    
    For i = 0 To CurRecount - 1
        
        If adoRes.EOF Then
            Exit Function
        End If
        
        If Not adoRes.Fields(3).Value = "" Then
            tol_Expr1 = tol_Expr1 + CDbl(adoRes.Fields(3).Value) / 1000
        End If
        
        If Not adoRes.Fields(4).Value = "" Then
            tol_Expr2 = tol_Expr2 + CDbl(adoRes.Fields(4).Value) / 1000
        End If
        
        If Not adoRes.Fields(5).Value = "" Then
            tol_Expr3 = tol_Expr3 + CDbl(adoRes.Fields(5).Value)
        End If
        
        If Not adoRes.Fields(6).Value = "" Then
            tol_Expr4 = tol_Expr4 + CDbl(adoRes.Fields(6).Value) / 1000
        End If
        
'        If Not adoRes.Fields(7).Value = "" Then
'            tol_Expr5 = tol_Expr5 + CDbl(adoRes.Fields(7).Value)
'        End If
'
'        If Not adoRes.Fields(8).Value = "" Then
'            tol_Expr6 = tol_Expr6 + CDbl(adoRes.Fields(8).Value)
'        End If

        adoRes.MoveNext
    Next
    
    'tol_Expr5 = tol_Expr5 / CurRecount
    'tol_Expr6 = tol_Expr6 / CurRecount
    tol_Expr5 = (tol_Expr2 / 1000) / (tol_Expr3 / 60)
    tol_Expr6 = tol_Expr2 / tol_Expr1 * 100
    
    lblExpr1.Caption = Format(tol_Expr1, "#0.000")
    lblExpr2.Caption = Format(tol_Expr2, "#0.000")
    lblExpr3.Caption = GetStrDate(CStr(tol_Expr3))
    lblExpr4.Caption = Format(tol_Expr4, "#0.000")
    lblExpr5.Caption = Format(tol_Expr5, "#0.00")
    lblExpr6.Caption = Format(tol_Expr6, "#0.00")
    
Resume_Err:
    Exit Function

Err:
    GetTotleData = False
    Resume Resume_Err
    
End Function

'******************************************************************************
' 娭悢柤 : SetStrMonth
' 婡擻丂 : 僨乕僞傪張棟偡傞丅
' 堷悢   : strDate   ----String
' 栠傝抣 : SetStrMonth
'******************************************************************************
Private Function GetStrMonth(ByVal strDate As String) As Long
    Dim rtnVal As Long
    
    If Not strDate = vbNullString Then
        rtnVal = CLng(Mid(strDate, 1, 4) & Mid(strDate, 6, 2))
    End If
    
    GetStrMonth = rtnVal
      
End Function

'******************************************************************************
' 娭悢柤 : GetStrDate
' 婡擻丂 : 帪娫傪張棟偡傞丅
' 堷悢   : strDate   ----String
' 栠傝抣 : GetStrDate
'******************************************************************************
Private Function GetStrDate(ByVal strDate As String) As String
    Dim rtnVal As String
    Dim idate As Double
    Dim strH As String
    Dim strM As String
    Dim strS As String
    
    rtnVal = vbNullString
    
    If Not strDate = vbNullString Then
        idate = CDbl(strDate) * 60
        
        strH = Int(idate / 3600) & "帪娫"
        strM = Int((idate Mod 3600) / 60) & "暘"
        strS = Int((idate Mod 3600) Mod 60) & "昩"
        
        rtnVal = ""
        
        If Not strH = "0帪娫" Then
            rtnVal = strH
        End If
        
        If Not strM = "0暘" Then
            rtnVal = rtnVal & strM
        End If
        
        If Not strS = "0昩" Then
            rtnVal = rtnVal & strS
        End If

    End If
      
    GetStrDate = rtnVal
      
End Function

'******************************************************************************
' 娭悢柤 : SetActiveCell
' 婡擻丂 : 帪娫傪張棟偡傞丅
' 堷悢   : col   ----峴
'          row   ----楍
' 栠傝抣 : 側偟
'******************************************************************************
Private Function SetActiveCell(ByVal col As Long, ByVal row As Long)
    fpSpread.row = row
    fpSpread.col = col
    fpSpread.Action = ActionActiveCell
    fpSpread.SetFocus
End Function

'******************************************************************************
' 娭悢柤 : Getpic
' 婡擻丂 : 僀儊乕僕傪庢摼
' 堷悢   : 側偟
' 栠傝抣 : Getpic
'******************************************************************************
Private Function Getpic() As Boolean

On Error GoTo Err

    Getpic = False
    btn_firstend.Picture = LoadPicture("..\image\first_end.bmp")
    btn_last.Picture = LoadPicture("..\image\last.bmp")
    btn_next.Picture = LoadPicture("..\image\next.bmp")
    btn_lastend.Picture = LoadPicture("..\image\last_end.bmp")
    Getpic = True

Resume_Err:
    Exit Function

Err:
    Getpic = False
    Resume Resume_Err

End Function

'******************************************************************************
' 娭悢柤    : ShortKeyPressed
' 婡擻丂丂丂: Ctrl,Alt,Shift墴壓偺張棟偡傞
' 堷悢丂丂丂: KeyCode
' 栠傝抣丂  : 側偟
'******************************************************************************
Private Function ShortKeyPressed(ByVal KeyCode As Long) As Boolean
    
    ShortKeyPressed = True
    If KeyCode = 16 Or KeyCode = 17 Or KeyCode = 18 Then
        KeyFlag = True
    End If
    
    If KeyFlag = False Then
        ShortKeyPressed = False
    Else
        ShortKeyPressed = True
    End If
End Function
'##### END ########丂娭丂丂悢丂################################################