mdlfunction.bas

用VB6.0编写的关于车辆运输调度的系统

Attribute VB_Name = "mdlFunction"
Option Explicit

Public Function GetCusCode(ByVal sCode As Variant) As Long

    With frmCusHelpList
        Load frmCusHelpList
        If sCode = "" Then
            sCode = 0
        End If
        .sCusCode = sCode
        
        .ShowItem (.sCusCode)
        
        If Trim(.txtcode) = sCode Then
            .cmdOK = True
            GetCusCode = .txtcode.Tag
        Else
            .Show vbModal
            If .Tag = vbOK Then
                GetCusCode = .txtcode.Tag
            Else
                GetCusCode = -1
            End If
        End If
    End With

End Function

Public Function ClerkDay(ByVal ldate As Long) As Boolean '判断是否是YYYYMMDD
Dim sdate As String
Dim syear, smonth, sday As String
Dim iyear, imonth, iday As Integer
    
    sdate = str(ldate)
    sdate = LTrim(sdate)
    If Len(sdate) <> 8 Then
        ClerkDay = False
        Exit Function
    Else
        
        syear = Left(sdate, 4)
        smonth = Mid(sdate, 5, 2)
        sday = Right(sdate, 2)
        iyear = CInt(syear)
        imonth = CInt(smonth)
        iday = CInt(sday)
        ClerkDay = False
        
        If iyear > 2500 And iyear < 1500 Then
            MsgBox "Wrong input!!"
            'ClerkDay = False
            Exit Function
            
        Else: Select Case imonth
            
                Case 1, 3, 5, 7, 8, 10, 12
                    If iday < 0 And iday > 31 Then
                        MsgBox "Wrong input!!"
                 '       ClerkDay = False
                        Exit Function
                    Else
                        ClerkDay = True
                        Exit Function
                    End If
                Case 4, 6, 9, 11
                    If iday < 0 And iday > 30 Then
                        MsgBox "wrong input !"
                  '      ClerkDay = False
                        Exit Function
                    Else
                        ClerkDay = True
                        Exit Function
                    End If
                Case 2
                    If (iyear Mod 4) = 0 Then
                        If iday < 0 And iday > 29 Then
                            MsgBox "wrong input!!"
                   '         ClerkDay = False
                            Exit Function
                        Else
                            ClerkDay = True
                            Exit Function
                        End If
                    ElseIf iday < 0 And iday > 28 Then
                    '        MsgBox "Wrong Input!!"
                            ClerkDay = False
                            Exit Function
                        Else
                            ClerkDay = True
                            Exit Function
                    End If
                    
                Case Else
                    MsgBox "Wrong Date Inpute!!"
                   ' ClerkDay = False
                    Exit Function
                    
            End Select
        End If
   End If
End Function

Public Function clerkminute(ByVal ltime As Long) As Boolean '判断是否是HHMM？
Dim stime, shour, sminute As String
Dim ihour, iminute As Integer
    
    stime = str(ltime)
    stime = LTrim(stime)
    shour = Left(stime, 2)
    sminute = Right(stime, 2)
    ihour = CInt(shour)
    iminute = CInt(sminute)
    clerkminute = False
    If ihour < 0 And ihour > 23 Then
        MsgBox "Wrong Time Inpute!!"
        Exit Function
    ElseIf iminute < 0 And iminute > 59 Then
        MsgBox "Wrong Time Inpute!!"
        Exit Function
    Else
        clerkminute = True
        Exit Function
    End If
    
End Function

Public Function ChangeDate(ByVal tdate As Date) As Long
Dim tlngdate As Date
    
    tlngdate = Format(tdate, "YYYY-MM-DD")
    ChangeDate = CLng(Mid(tlngdate, 1, 4) & Mid(tlngdate, 6, 2) & Mid(tlngdate, 9, 2))
    
End Function

Public Function LongToDate(ByVal ldate As Long) As Date
    
    LongToDate = Mid(ldate, 1, 4) & "-" & Mid(ldate, 5, 2) & "-" & Mid(ldate, 7, 2)
    
End Function

Public Function TxtAscii(sStr As String, KeyAscii As Integer) As Integer
On Error Resume Next
    
    Select Case KeyAscii
        Case 48 To 57
            TxtAscii = KeyAscii
        Case 46
            If InStr(1, sStr, ".", vbTextCompare) = 0 Then
                TxtAscii = KeyAscii
            Else
                TxtAscii = 0
            End If
        Case 8
            TxtAscii = KeyAscii
        Case Else
            TxtAscii = 0
    End Select

End Function

Public Function NumericAscii(KeyAscii As Integer) As Integer
On Error Resume Next
    
    Select Case KeyAscii
        Case 48 To 57
            NumericAscii = KeyAscii
        Case 8
            NumericAscii = KeyAscii
        Case Else
            NumericAscii = 0
    End Select

End Function

Public Sub EnableDelete(ByVal rolcode As String, ByVal control As UserControl1)
    
    If rolcode <> 100 Then
    With control
        .DisplayButton "Delete", "Delete", False, , "Delete", False
    End With
    End If
    
End Sub