ちょっと使える関数ライブラリ(1)

Accessなどで使える，VBAの関数で，ちょっと使えるものを載せてみました。

年度を得る

簡単なところで，年度を得る関数。年度の始まりは4月固定。

'/**
' * 年度を得る.
' * @return
' * @param ADate
' */
Function GetNendo(ADate As Variant) As Integer
    Dim m As Integer
    Dim Y As Integer
    m = Month(ADate)
    Y = Year(ADate)
    If m < 4 Then
        Y = Y - 1
    End If
    GetNendo = Y
End Function
 

年齢計算

上記を使って，年度始めの年齢を計算する。

'/**
' * 年齢計算基準日を得る.
' * 基準日は年度の初めの日
' * @return
' * @param ADate
' */
Function GetBaseDate(ADate As Variant) As Date
    GetBaseDate = DateSerial(GetNendo(ADate), 4, 1)
End Function
 
'/**
' * 基準日での年齢計算.
' * @return
' * @param dBirthDay
' * @param Optional dDate
' */
Function GetAge(dBirthDay As Variant, Optional dDate As Variant = Null) As Variant
    Dim n As Integer
    Dim D As Date
 
    If IsNull(dBirthDay) Or (Not IsDate(dBirthDay)) Then
        GetAge = Null
        Exit Function
    End If
    If IsNull(dDate) Then
        D = Date
    ElseIf IsDate(dDate) Then
        D = dDate
    Else
        GetAge = Null
        Exit Function
    End If
    n = DateDiff("yyyy", dBirthDay, GetBaseDate(D))
    If Format(dBirthDay, "mm/dd") > Format(GetBaseDate(D), "mm/dd") Then
        n = n - 1
    End If
    GetAge = n
End Function
 
 

バイト単位でのMid関数

VBのMid関数は，文字単位で文字を切り出しますが，昔々のBASICのようにバイト数で切り出したいときに使います。

'/**
' * バイト単位でのMid関数.
' * @return         切り出された文字列
' * @param AStr     元の文字列
' * @param APos     開始位置
' * @param Optional ALength 長さ
' */
Public Function MidByte(AStr As String, APos As Integer, Optional ALength As Integer = -1)
    Dim temp As String
 
    AStr = StrConv(AStr, vbFromUnicode)
    If ALength < 0 Then
        MidByte = StrConv(MidB(AStr, APos), vbUnicode)
    Else
        MidByte = StrConv(MidB(AStr, APos, ALength), vbUnicode)
    End If
End Function

日付を比較してファイル更新

ファイルの日付を比較して，コピー元の方が新しかったらコピーを実行します。

'/**
' * ファイル更新.
' * ファイル日付を比較して新しければファイルをコピーする
' * @param ASource  コピー元ファイル名
' * @param ADest    コピー先ファイル名
' */
Sub UpdateFile(ASource As String, ADest As String)
    On Error Resume Next
    If Len(Dir(ADest)) = 0 Then
        FileCopy ASource, ADest
    ElseIf FileDateTime(ASource) > FileDateTime(ADest) Then
        FileCopy ASource, ADest
    End If
End Sub