hmainmodule.bas

饲料生产控制系统

Attribute VB_Name = "HmainModule"
Option Explicit

Public intKeiryoMon As Integer                      'VB傊捠抦  1:start 2:stop
Public setFocusFlag As String
Public pblnWait As Boolean


'Public Const ANYSIZE_ARRAY = 1
'Public Const TOKEN_ADJUST_PRIVILEGES = &H20
'Public Const TOKEN_QUERY = &H8
'Public Const SE_PRIVILEGE_ENABLED = &H2
'Public Const EWX_LOGOFF = 0            '慡傾僾儕偺廔椆偲尰儐乕僓乕偺儘僌僆僼
'Public Const EWX_SHUTDOWN = 1          '慡僾儘僙僗偺廔椆乮揹尮傪愗傟傞忬懺乯
'Public Const EWX_REBOOT = 2            '慡僾儘僙僗偺廔椆偲嵞婲摦
'Public Const EWX_FORCE = 4             '墳摎偺側偄僾儘僙僗偺嫮惂廔椆
'Public Const EWX_POWEROFF = 8          '慡僾儘僙僗偺廔椆偲揹尮僆僼    DoCmd.Maximize

Public Function Delfile(ByVal model As Long) As Boolean
    Dim url1 As String
    Dim url2 As String
    Dim url3 As String
    Dim url4 As String
    Dim gstrLogPath As String
    Dim rtnVal
    Dim fs As New FileSystemObject
    
On Error GoTo Err
    Delfile = False
    
'    Call ReadMainUrl(url1, url2, url3, url4)
    url1 = gCSVDRIVE
    url2 = gCSVPATH
    url3 = gCSVFILENAME
    url4 = "寁検幚愌(惂屼).CSV"
    
    gstrLogPath = url1 & url2
    
    If model = 0 Then
        If fs.FileExists(gstrLogPath & "\" & url3) Then
            If fileOpen(gstrLogPath & "\" & url3) Then
                Kill (gstrLogPath & "\" & url3)
            Else
                rtnVal = MsgBox(ErrorMsg304_10, vbOKOnly + 48, ErrorMsgTit304_2)
                Delfile = False
                Exit Function
            End If
        End If
    End If
   
    If model = 1 Then
        If fs.FileExists(gstrLogPath & "\" & url4) Then
            If fileOpen(gstrLogPath & "\" & url4) Then
                Kill (gstrLogPath & "\" & url4)
            Else
                rtnVal = MsgBox(ErrorMsg304_10, vbOKOnly + 48, ErrorMsgTit304_2)
                Delfile = False
                Exit Function
            End If
        End If
    End If
    Delfile = True
    
Resume_Err:
    Exit Function

Err:
    Delfile = False
    Resume Resume_Err
End Function

'CSV僼傽僀儖弌椡
Public Function f_Export2Excel(ByVal sRecordSet As ADODB.Recordset, ByVal model As Long) As Boolean
    
    Dim lngj As Integer
    Dim FSOLog As Object
    Dim gstrLogPath As String
    Dim url4 As String
    Dim rtnVal
    Dim fs As New FileSystemObject
    
    Dim FileNo As Integer
    
    Dim strFileName As String
    Dim strLine As String
        
On Error GoTo Err
        
    f_Export2Excel = False
    pblnWait = False

    url4 = "寁検幚愌(惂屼).CSV"

    gstrLogPath = gCSVDRIVE & gCSVPATH
    Set FSOLog = CreateObject("Scripting.FileSystemObject")
   
    'dava 20070930
'    If Dir(gstrLogPath, vbDirectory) = "" Then
'        MkDir gstrLogPath
'    End If
    Dim mfile As New FileSystemObject
    If mfile.FolderExists(gstrLogPath) = False Then
        On Error GoTo Err2
        mfile.CreateFolder (gstrLogPath)
    End If
    
    If model = 0 Then
        strFileName = gstrLogPath & "\" & gCSVFILENAME
    ElseIf model = 1 Then
        strFileName = gstrLogPath & "\" & url4
    End If
 
    If sRecordSet.recordcount > 0 Then
        sRecordSet.MoveFirst
        
        'CSV僼傽僀儖OPEN
        FileNo = FreeFile
        Open strFileName For Output As FileNo
        
        '僞僀僩儖偺彂偒崬傒
        strLine = vbNullString
        strLine = strLine & "儘僢僩No,"
        strLine = strLine & "柫暱僐乕僪,"
        strLine = strLine & "柫暱柤,"
        strLine = strLine & "寁検廔椆擭寧擔,"
        strLine = strLine & "僶僢僠No,"
        strLine = strLine & "憤僶僢僠悢,"
        strLine = strLine & "寁検婍No,"
        strLine = strLine & "價儞No,"
        strLine = strLine & "尨椏僐乕僪,"
        strLine = strLine & "尨椏柤,"
        strLine = strLine & "愝掕抣(Kg),"
        strLine = strLine & "寁検抣(Kg)"
        
        Print #FileNo, strLine
       
        For lngj = 0 To sRecordSet.recordcount - 1
            '僨乕僞偺彂偒崬傒
            strLine = vbNullString
            strLine = strLine & sRecordSet("LotNo") & ","
            strLine = strLine & sRecordSet("MeigaraCode") & ","
            strLine = strLine & sRecordSet("MeigaraName") & ","
            strLine = strLine & sRecordSet("EndDate") & ","
            strLine = strLine & sRecordSet("EndBatchCnt") & ","
            strLine = strLine & sRecordSet("YoteiBatchCnt") & ","
            strLine = strLine & sRecordSet("ScaleKubunCode") & ","
            strLine = strLine & sRecordSet("TankNo") & ","
            strLine = strLine & sRecordSet("GenryoCode") & ","
            strLine = strLine & sRecordSet("GenryoName") & ","
            strLine = strLine & Format(CDbl(sRecordSet("TSYWeight")) / 1000, "#0.000") & ","
            strLine = strLine & Format(CDbl(sRecordSet("TSEWeight")) / 1000, "#0.000")
            Print #FileNo, strLine
            sRecordSet.MoveNext
        Next lngj
        
    End If
    
    f_Export2Excel = True
    
Resume_Err:
    Close FileNo
    pblnWait = True
    Exit Function

Err:
    Resume Resume_Err
    
Err2:
    rtnVal = MsgBox("乽" & gstrLogPath & "乿偑懚嵼偟側偄偨傔丄僼傽僀儖偺嶌惉偼幐攕偟傑偟偨丅", vbOKOnly + vbExclamation, ErrorMsgTit304_1)
    Resume Resume_Err
    Exit Function
    
End Function

'Public Function f_Export2Excel(ByVal sRecordSet As ADODB.Recordset, ByVal model As Long) As Boolean
'
'    Dim xlsapp As Object
'    Dim lngj As Integer
'    Dim FSOLog As Object
'    Dim gstrLogPath As String
'    Dim strname As String
'    Dim url1 As String
'    Dim url2 As String
'    Dim url3 As String
'    Dim url4 As String
'    Dim rtnVal
'    Dim fs As New FileSystemObject
'
'On Error GoTo Err
'
'    f_Export2Excel = False
'    pblnWait = False
'
''    Call ReadMainUrl(url1, url2, url3, url4)
'    url1 = gCSVDRIVE
'    url2 = gCSVPATH
'    url3 = gCSVFILENAME
'    url4 = "寁検幚愌(惂屼).CSV"
'
'    gstrLogPath = url1 & url2
'    Set FSOLog = CreateObject("Scripting.FileSystemObject")
'
'    'dava 20070930
''    If Dir(gstrLogPath, vbDirectory) = "" Then
''        MkDir gstrLogPath
''    End If
'    Dim mfile As New FileSystemObject
'    If mfile.FolderExists(gstrLogPath) = False Then
'        On Error GoTo Err2
'        mfile.CreateFolder (gstrLogPath)
'    End If
'
'    Set xlsapp = CreateObject("excel.application")
'    xlsapp.workbooks.Add (1)
'    If sRecordSet.recordcount > 0 Then
'        sRecordSet.MoveFirst
'        xlsapp.activeworkbook.activesheet.Name = "岥僢僩暿柫暱暿尨椏幚愌(僶僢僠枅)"
'
'        For lngj = 0 To sRecordSet.Fields.Count - 1
'            Select Case sRecordSet.Fields(lngj).Name
'                Case "EndDate"
'                    xlsapp.activesheet.cells(1, lngj + 1).Value = "寁検廔椆擭寧擔"
'                Case "LotNo"
'                    xlsapp.activesheet.cells(1, lngj + 1).Value = "儘僢僩No"
'                Case "MeigaraCode"
'                    xlsapp.activesheet.cells(1, lngj + 1).Value = "柫暱僐乕僪"
'                Case "MeigaraName"
'                    xlsapp.activesheet.cells(1, lngj + 1).Value = "柫暱柤"
'                Case "YoteiBatchCnt"
'                    xlsapp.activesheet.cells(1, lngj + 1).Value = "僶僢僠No"
'                Case "EndBatchCnt"
'                    xlsapp.activesheet.cells(1, lngj + 1).Value = "憤僶僢僠悢"
'                Case "GenryoCode"
'                    xlsapp.activesheet.cells(1, lngj + 1).Value = "尨椏僐乕僪"
'                Case "GenryoName"
'                    xlsapp.activesheet.cells(1, lngj + 1).Value = "尨椏柤"
'                Case "TankNo"
'                    xlsapp.activesheet.cells(1, lngj + 1).Value = "價儞No"
'                Case "ScaleKubunCode"
'                    xlsapp.activesheet.cells(1, lngj + 1).Value = "寁検婍No"
'                Case "TSYWeight"
'                    xlsapp.activesheet.cells(1, lngj + 1).Value = "愝掕抣"
'                Case "TSEWeight"
'                    xlsapp.activesheet.cells(1, lngj + 1).Value = "寁検抣"
'            End Select
'        Next
'
'        xlsapp.Rows(1).Font.colorindex = 5
'        xlsapp.activesheet.range("a" & 2).copyfromrecordset sRecordSet, sRecordSet.recordcount, sRecordSet.Fields.Count
'        xlsapp.cells.Select
'        xlsapp.cells.entirecolumn.autofit
'        xlsapp.range("a1").Select
'    End If
'
'    If model = 0 Then
'        xlsapp.activeworkbook.SaveAs (gstrLogPath & "\" & url3)
'    End If
'
'    If model = 1 Then
'        xlsapp.activeworkbook.SaveAs (gstrLogPath & "\" & url4)
'    End If
'
'    xlsapp.Application.quit
'    Set xlsapp = Nothing
'    f_Export2Excel = True
'
'    pblnWait = True
'
'Resume_Err:
'    Exit Function
'
'Err:
'    pblnWait = True
'    Resume Resume_Err
'
'Err2:
'    pblnWait = True
'    rtnVal = MsgBox("乽" & gstrLogPath & "乿偑懚嵼偟側偄偨傔丄僼傽僀儖偺嶌惉偼幐攕偟傑偟偨丅", vbOKOnly + vbExclamation, ErrorMsgTit304_1)
'    Exit Function
'
'End Function

Private Function fileOpen(ByVal strUrl As String) As Boolean
    Dim fs As New FileSystemObject
On Error GoTo Err
    fileOpen = False
    Call fs.MoveFile(strUrl, strUrl)
    fileOpen = True
Resume_Err:
    Exit Function
            
Err:
    fileOpen = False
    Resume Resume_Err
End Function

'******************************************************************************
'僀儀儞僩柤: cmdDelAll_Click
'婡擻      : 儗僐乕僪傪嶍彍偡傞
'******************************************************************************
Public Sub DelDateOutTime()
On Error GoTo Err                ' 僄儔乕偺応崌

    Dim rtnAns As Integer
    Dim strSql As String
    'Beep
    'rtnAns = MsgBox(ErrorMsg401_1, vbYesNo + vbQuestion, ErrorMsg401_2)

            '僄儔乕傪嶍彍偟傑偡
            strSql = vbNullString
            strSql = strSql & " Delete From ErrLog where datediff(dd, LogDate,getdate()) > " & gHozon_Day
            gfExecSQL (strSql)
            
            '尨椏傪嶍彍偟傑偡
            strSql = vbNullString
            strSql = strSql & " Delete From GenryoLog where datediff(dd, FctDate,getdate()) > " & gHozon_Day
            gfExecSQL (strSql)
            
            '柫暱傪嶍彍偟傑偡
            strSql = vbNullString
            strSql = strSql & " Delete From MeigaraLog where datediff(dd, FctDate,getdate()) > " & gHozon_Day
            gfExecSQL (strSql)
            
            'VM傪嶍彍偟傑偡
            strSql = vbNullString
            strSql = strSql & " Delete From PremixLog where datediff(dd, FctDate,getdate()) > " & gHozon_Day
            gfExecSQL (strSql)
            
            '攝崌梊掕傪嶍彍偟傑偡
            strSql = vbNullString
            strSql = strSql & " Delete From YoteiMas where datediff(dd, EndDate,getdate()) > " & gHozon_Day
            gfExecSQL (strSql)

    Exit Sub
    
Resume_Err:
    Exit Sub

Err:
   'Set adoRes = Nothing
'    rtnVal = MsgBox(ErrorMsg2, vbOKOnly + 64, ErrorMsgDefTit)
   Resume Resume_Err
    
End Sub