Форумы HiProg.com - MS ACCESS, VBA, VB

 

Ответить на сообщение

Вернуться к теме

Вы отвечаете на сообщение:

ник: час
А это вот коментировано не по нашему - я тут плохо понимаю, но функции хорошие - может пригодятся какие для класса


Вопрос: Работа с датами и временем

Совет: 
Option Compare Database   'Use database order for string comparisons
Option Explicit

Const MB_ICONEXCLAMATION = 48

'************************************************************************
'* Function ConDateTime (anyDate As Variant, anyTime As Integer) 
'* By John W.Locke   JoLocke@AOL.com 
'* 1/19/96
'* 
'* Some applications, such as DBase, store date and time values in sep- 
'* arate fields. This function will concatenate those into a single Date
'* and Time string that is usable by Access. The Date/Time value can
'* then be stored, or used in forms, queries or reports. 
'* 
'* This function requires the TimeValue function to convert time stored
'* as numeric data into an Access Time value. 
'************************************************************************
Function ConDateTime (anydate As Variant, anytime As Integer)
On Error GoTo Err_ConDateTime
    
    
    '/* A negative or Null value is unlikely, but we will trap for it anyway, */
    '/* because it could cause an "Illegal Function" error                    */
If (IsNull(anytime) Or (anytime < 0) Or (anytime >= 1440)) Then
     MsgBox "The value '" & anytime & "' is not a valid Time number.", MB_ICONEXCLAMATION, "ConDateTime Invalid Time"
  GoTo Exit_ConDateTime
    Else
End If
    
If IsDate(anydate) = False Then
    MsgBox "The value '" & anydate & "' is not a valid Date.", MB_ICONEXCLAMATION, "ConDateTime Invalid Date"
GoTo Exit_ConDateTime
    Else
End If

ConDateTime = DateValue(anydate) & " " & TimeValue(ConvTime(anytime))
      
Exit_ConDateTime:
    Exit Function
    
Err_ConDateTime:
    MsgBox Err & " " & Error$, MB_ICONEXCLAMATION, "ConDateTime Error Message"
    Resume Exit_ConDateTime
End Function
'************************************************************************
'* Function ConvTime (anyNum)  
'* By John W.Locke   JoLocke@AOL.com 
'* 1/19/96 
'*       
'* This funtion will convert numeric time values, such as those stored 
'* by dBase, into an Access Time value. This can then be used by itself 
'* or concatenated with a date value via the ConDateTime function.  
'* 
'* This function assumes the time value is being stored as an integer
'* between 0(12:00:00 am)and 1439(11:59:00 pm), where 1 = 1 minute. 
'************************************************************************
Function ConvTime (anyNum)
On Error GoTo Err_ConvTime
   
   anyNum = IIf(IsNull(anyNum), 0, anyNum)
   '/* a negative value is unlikely, but we will trap for it anyway. */
   If ((anyNum < 0) Or (anyNum >= 1440)) Then
     MsgBox "The value '" & anyNum & "' is not a valid Time number.", MB_ICONEXCLAMATION, "ConvTime Invalid Time"
     GoTo Exit_ConvTime
   End If
   
   ConvTime = TimeValue(Trim$((Int(anyNum / 60))) & ":" & IIf((((anyNum / 60) - Int(anyNum / 60)) * 60) >= 10, Trim$((((anyNum / 60) - Int(anyNum / 60)) * 60)), "0" & Trim$((((anyNum / 60) - Int(anyNum / 60)) * 60))))
   


Exit_ConvTime:
    Exit Function
    
Err_ConvTime:
    MsgBox Err & " " & Error$, MB_ICONEXCLAMATION, "ConvTime Error Message"
    Resume Exit_ConvTime
End Function
'************************************************************************
'* Function TimeElapsed (Date1, Date2) As Variant   
'* By John W.Locke   JoLocke@AOL.com   
'* 1/19/96  
'*  
'* This function computes the elapsed time between 2 dates, excluding   
'* weekends. It accepts dates as Date/Time strings or Access Date/Time  
'* values. It returns a Variant TimeValue that can be formatted in a 
'* query, form or report.
'*
'************************************************************************
Function TimeElapsed (Date1, Date2) As Variant
On Error GoTo Err_TimeElapsed
 
    Dim Time1, Time2, ElapsedTime, ElapsedDays, ElapsedPartialDay   '/* Variants */
    Dim vwknd As Integer

      Time1 = CVDate(Date1)
      Time2 = CVDate(Date2)
      vwknd = DatePart("ww", Time2) - DatePart("ww", Time1)
      If vwknd > 0 Then
vwknd = vwknd * 2
    Else
vwknd = vwknd
      End If
      
      ElapsedTime = Abs(Time1 - Time2)
      ElapsedDays = Int(ElapsedTime)
      ElapsedPartialDay = (ElapsedTime - ElapsedDays)
      TimeElapsed = ElapsedTime - vwknd
Exit_TimeElapsed:
    Exit Function
    
Err_TimeElapsed:
    MsgBox Err & " " & Error$, MB_ICONEXCLAMATION, "TimeElapsed Error Message"
    Resume Exit_TimeElapsed
   
End Function

'************************************************************************
'* Function DateBeg (varDate, sPeriod As Integer) 
'* By John W.Locke   JoLocke@AOL.com 
'* 2/1/96 
'* Used to get Beginning Date from DateRanger Function. See comments in
'* DateRanger function. 
'************************************************************************
Function DateBeg (varDate, sPeriod As Integer)
On Error GoTo Err_DateBeg

    DateBeg = Left$(DateRanger(varDate, sPeriod), 8)
Exit_DateBeg:
    Exit Function
    
Err_DateBeg:
    MsgBox Err & " " & Error$, MB_ICONEXCLAMATION , "DateBeg Error Message"
    Resume Exit_DateBeg
    
End Function
'************************************************************************
'* Function DateEnd (varDate, sPeriod As Integer) 
'* By John W.Locke   JoLocke@AOL.com 
'* 2/1/96
'*  
'* Used to get Ending Datefrom DateRanger Function. See comments in 
'* DateRanger function.
'************************************************************************
Function DateEnd (varDate, sPeriod As Integer)
On Error GoTo Err_DateEnd
    DateEnd = Right$(DateRanger(varDate, sPeriod), 8)
Exit_DateEnd:
    Exit Function
    
Err_DateEnd:
    MsgBox Err & " " & Error$, MB_ICONEXCLAMATION , "DateEnd Error Message"
    Resume Exit_DateEnd
    
End Function
'************************************************************************
'* Function DateRanger (varDate As Variant, sPeriod As Integer) 
'* By John W.Locke   JoLocke@AOL.com 
'* 2/1/96
'*   
'* This function will return starting and ending dates for pre-defined  
'* date ranges. For example, if varDate = 1/15/96 and sPeriod = 1, 
'* DateRanger will return 12/1/95 as the starting date, and 12/31/95 as 
'* the ending date.
'*       
'* Date ranges currently supported are: 
'* Last Month -     sPeriod =1      Last Quarter -    sPeriod = 3  
'* Last Trimester - sPeriod = 4     Last SemiAnnual - sPeriod = 6 
'* Last Week -      sPeriod = 7     Last Year -       sPeriod = 12
'*  
'* DateRanger is called from it's 2 "front-end" functions, DateBeg and 
'* DateEnd. Usage example: 
'*      DateBeg(#2/12/96#,3) = 11/01/95 
'*      DateEnd(#2/12/96#,3) = 01/31/96  
'************************************************************************
Function DateRanger (varDate As Variant, sPeriod As Integer)
On Error GoTo Err_DateRanger

Dim BegDate, EndDate As Variant
Dim x, y, vDay As Integer
Select Case sPeriod
Case 1
    y = 365.25 / 12     'Last Month(1 month)
Case 3
    y = 365.25 / 4      'Last Quarter(3 months)
Case 4
    y = 365.25 / 3      'Last Trimester(4 months)
Case 6
    y = 365.25 / 2      'Last Semi-Annual(6 months)
Case 7
    GoTo Weeks          'Last Week(1 week)
Case 12
    y = 365.25          'Last Year(12 months)
Case Else
    MsgBox "Wrong Value Entered."
    Exit Function
End Select
    BegDate = DateSerial(Year(varDate - y), Month(DateAdd("m", -sPeriod, varDate)), 1)
    EndDate = DateAdd("m", sPeriod, (BegDate)) - 1
DateRanger = Format$(BegDate, "mm/dd/yy") & Format$(EndDate, "mm/dd/yy")
GoTo Exit_DateRanger
Weeks:
x = Weekday(varDate)
    Select Case x
        Case 1
            vDay = -7
        Case 2
            vDay = -8
        Case 3
            vDay = -9
        Case 4
            vDay = -10
        Case 5
            vDay = -11
        Case 6
            vDay = -12
        Case 7
            vDay = -13
        Case Else
            GoTo Err_DateRanger
    End Select
    BegDate = DateAdd("d", vDay, varDate)
    EndDate = DateAdd("d", vDay + 7, varDate)
    
DateRanger = Format$(BegDate, "mm/dd/yy") & Format$(EndDate, "mm/dd/yy")
GoTo Exit_DateRanger
Exit_DateRanger:
    Exit Function
    
Err_DateRanger:
If IsNull(varDate) Then
    MsgBox "This is a Null Date!"
    Resume Next
        ElseIf IsDate(varDate) = False Then
    Resume Next
End If
    
    MsgBox Err & " " & Error$, MB_ICONEXCLAMATION , "DateRanger Error Message"
    Resume Exit_DateRanger
End Function
'************************************************************************
'* Function EndOfMonth (vDate) 
'* By John W.Locke   JoLocke@AOL.com 
'* 2/1/96  
'*  
'* This function accepts any valid date and returns the last day of the 
'* month. Includes logic to compute "Leap Day". 
'* For example: 
'* EndOfMonth(#2/12/96#) = 29 
'************************************************************************
Function EndOfMonth (vDate)
On Error GoTo Err_EndOfMonth
Dim x, EOM As Integer
Select Case Month(vDate)
Case 1, 3, 5, 7, 10, 12
x = 31
Case 4, 6, 8, 9, 11
x = 30
Case 2
    If Year(vDate) Mod 4 = 0 Then
        x = 29
            Else
        x = 28
    End If
Case Else
MsgBox "Invalid Month in Date"
End Select
EOM = x
EndOfMonth = EOM
Exit_EndOfMonth:
    Exit Function
    
Err_EndOfMonth:
    MsgBox Err & " " & Error$, MB_ICONEXCLAMATION , "EndOfMonth Error Message"
    Resume Exit_EndOfMonth
End Function


Ваше имя:

Пароль:
Цитировать: [quote][/quote] Код: [code][/code]
Жирный: [b][/b] Наклонный: [i][/i]
URL: [url][/url] 

Сообщение:

 Размер файла не более 50 Кбт. Большие файлы можно размещать на www.slil.ru

Прикрепить:

 

Для вставки смайлов в текст щелкните по значку.