常用方法

1.日期范围判断

Public Function InDate(Par_date As String, par_from As Variant, par_to As Variant) As Integer
Dim i As Integer

    InDate = 0
    If IsDate(Par_date) = False Then
        Exit Function
    End If
    If IsArray(par_from) And IsArray(par_to) Then

        If UBound(par_from) <> UBound(par_to) Then Exit Function

        For i = LBound(par_from) To UBound(par_from)
            If par_from(i) <> "" And par_to(i) <> "" Then
                If Par_date >= par_from(i) And Par_date <= par_to(i) Then
                    InDate = i + 1
                    Exit Function
                End If
            End If
        Next
    Else
        If par_from <> "" And par_to <> "" Then
            If Par_date >= par_from And Par_date <= par_to Then
                InDate = 1
            End If
        End If
    End If

End Function

2.percent

Public Function Format_AddPercent(Par_base As String, Optional sin As Integer = 1) As String
    If IsNumeric(Par_base) = False Then
        Format_AddPercent = ""
    Else
        Format_AddPercent = Format(Par_base, "0." & String(sin, "0")) & "%"
    End If
End Function

3.String pos

Public Function Fnc_get_pos_string(Par_word As String, par_iPos As Integer, Optional par_mark As String) As String
Dim sResult As String
Dim lCnt As Long
Dim lPos As Long

    Fnc_get_pos_string = ""
    If par_mark = "" Then par_mark = " "
    For lCnt = 1 To Len(Par_word)
        If Mid$(Par_word, lCnt, 1) <> par_mark Then
            sResult = sResult & Mid$(Par_word, lCnt, 1)
        Else
            lPos = lPos + 1
            If lPos = par_iPos Then
                Fnc_get_pos_string = sResult
                Exit Function
            Else
                sResult = ""
            End If
        End If
    Next
    If lPos = par_iPos - 1 Then
        Fnc_get_pos_string = sResult
    End If

End Function

4.Number

Public Function chk_TextNum(otxt As TextBox, iAsc As Integer) As Boolean
    chk_TextNum = True
    Select Case iAsc
        Case 13, 22, vbKeyBack
        Case Asc("0") To Asc("9")
            If Len(otxt) >= 9 And otxt.SelLength = 0 Then
                chk_TextNum = False
            End If
        Case Else
            chk_TextNum = False
    End Select
End Function

1. get month days

Public Function getMonthDays(startDate As String, EndDate As String, yearMonth As String) As Integer
Dim stDate As Date
Dim edDate As Date
Dim ym As Date
Dim ymSt As Date
Dim ymEd  As Date

    If startDate = "" Or EndDate = "" Or yearMonth = "" Then
        getMonthDays = 0
        Exit Function
    End If

    If startDate > EndDate Then
        getMonthDays = 0
        Exit Function
    End If

    stDate = Left(startDate, 4) & "/" & Mid(startDate, 5, 2) & "/" & Right(startDate, 2)
    edDate = Left(EndDate, 4) & "/" & Mid(EndDate, 5, 2) & "/" & Right(EndDate, 2)
    ymSt = yearMonth & "/" & "01"
    ymEd = DateAdd("D", -1, DateAdd("M", 1, ymSt))
    ym = Left(yearMonth, 4) & Right(yearMonth, 2)

    If Left(startDate, 6) <= ym And Left(EndDate, 6) >= ym Then
        If Left(startDate, 6) < ym Then
            stDate = ymSt
        End If
        If Left(EndDate, 6) > ym Then
            edDate = ymEd
        End If
        getMonthDays = edDate - stDate + 1

    Else
        getMonthDays = 0

    End If
End Function

6.Dialog

With dialog1
        .CancelError = True
        On Error GoTo Err_Cancel

        .flags = cdlOFNHideReadOnly
        .FileName = ""
        .Filter = "CSV ファイル (*.csv)|*.csv|"
        .FilterIndex = 1
        .ShowOpen

    End With

7.file

Set objFSO = CreateObject("Scripting.FileSystemObject")

     If objFSO.FileExists(par_file) = False Then
     If UCase(objFSO.GetExtensionName(par_file)) <> "CSV" Then
     w_path = objFSO.GetParentFolderName(par_file)

8.log

Public Sub Fnc_PutLog(ByVal sPar_Log As String, ByVal sPar_Msg As String)
Dim sStr        As String
Dim iFNum       As Integer

    On Error GoTo Err

    iFNum = FreeFile
    sStr = Format(Now(), "yyyy/mm/dd hh:mm:ss") & " " & sPar_Msg
    Open sPar_Log For Append As iFNum
    Print #iFNum, sStr
    Close iFNum

    Exit Sub
Err:
    Close iFNum
End Sub

9.input string

Public Function check_form(par_form As Form, Optional v_except As Variant) As Boolean
Dim c_temp As Control
Dim sMsg As String
Dim bChk As Boolean
    check_form = True

    For Each c_temp In par_form.Controls
        If UCase(TypeName(c_temp)) = "TEXTBOX" Then
            bChk = False

            If IsMissing(v_except) = True Then
                bChk = True
            Else
                bChk = Not (IsExist_Arry(c_temp.Name, v_except))

            If bChk = True Then
                If Fnc_chk_str_include(UCase(Trim(c_temp)), CHARS, False) = False Then
                    If Trim(c_temp.Tag) <> "" Then
                        sMsg = "「" & Trim(c_temp.Tag) & "」"
                    End If
                    MsgBox sMsg & "Errinfo", vbExclamation
                    If c_temp.Visible And c_temp.Enabled Then c_temp.SetFocus
                    check_form_boa = False
                    Exit For
                End If
            End If
        End If
    Next
End Function
Public Function IsExist_Arry(par_key As String, par_Arry As Variant) As Boolean
Dim i_cnt As Integer

    IsExist_Arry = False

    On Error GoTo Err_IsExistArry
    For i_cnt = LBound(par_Arry) To UBound(par_Arry)
        If par_key = par_Arry(i_cnt) Then
            IsExist_Arry = True
            Exit For
        End If
    Next

    Exit Function
Err_IsExistArry:

End Function

10 Email

Public Function IsEmail(par_email As String) As Boolean
Dim b_lt As Boolean, b_gt As Boolean
Dim i As Integer

    b_lt = False: b_gt = False

    For i = 2 To Len(par_email) - 1
        If Mid(par_email, i, 1) = "@" And b_lt = True Then
            b_lt = False
            Exit For
        End If

        If Mid(par_email, i, 1) = "@" Then b_lt = True
        If Mid(par_email, i, 1) = "." And b_lt = True Then b_gt = True

    Next

    If b_lt = True And b_gt = True And Right(par_email, 1) <> "." And Left(par_email, 1) <> "@" And InStr(1, par_email, "@.") <= 0 Then
       IsEmail = True
    Else
       IsEmail = False
    End If

End Function