テキスト広告まわりの事前チェック関数

・使用不可文字が使われていた場合、その文字を返す関数
Case文のところは使用可能な文字リストと照らし合して都度メンテが必要かと

Public Function chk_adn(str As String) As String
    On Error GoTo Err_Trap
    Dim i As Long
    Dim c As String
    Dim buf As String
    
    buf = ""
    If str = "" Then
        chk_adn = ""
        Exit Function
    End If
    
    For i = 1 To Len(str)
        c = Mid(str, i, 1)
        Debug.Print c, Asc(c), AscW(c)
        Select Case Asc(c)
        '以下、OKパターン→なにもしない
            Case &H20 To &H21 '半角スペースと!
            Case &H28 To &H29 '()
            Case &H2B To &H2E '+,-.
            Case &H30 To &H3B '0123456789:;
            Case &H3F '? →ちょっと特殊な処理が必要になるので別出し
            'UNICODEでのみ持っている文字の場合、この判定方法だと「?」となり、チェックが通ってしまうので追記する
                If AscW(c) <> &H3F Then buf = buf & c
            Case &H41 To &H5A '半角英大文字
            Case &H61 To &H7A '半角&#58803;小文字
            Case &H8141 To &H8149 '全角で使用可能な記号↓
            Case &H814C, &H814D, &H815E, &H8163, &H8165, &H8166, &H8169, &H816A, &H817B, &H817C, &H817E, &H8181, &H818F, &H8193, &H8195, &H8197
            Case &H824F To &H83D6 '全角英数かなカナギリシャ文字
            Case &H889F To &H9872 'JIS第一水準
            Case &H989F To &H9FFC 'JIS第二水準
            Case Else
                buf = buf & c
        End Select
    Next i
    
    chk_adn = buf
    Exit Function
Err_Trap:
    chk_adn = "エラー(" & i & ":" & c & ")>" & Err.Number & ":" & Err.Description
End Function

・連続使用をチェックする関数
　これはどっちかというとY!向けの奴

Public Function CountChr(sChk As String, sValue As String) As Long
    Dim n As Long
    Dim i As Long
    'カウンタをリセット
    n = 0
    
    'チェック先文字列がすべて未入力の場合は0を返す
    If Len(sValue) = 0 Then
        CountChr = 0
        Exit Function
    End If
    
    'チェック文字が空だった場合は0を返す
    If sChk = "" Then
        CountChr = 0
        Exit Function
    End If
    
    i = 1
    Do
        i = InStr(i, sValue, sChk, vbBinaryCompare)
        If i = 0 Then '見つからなかった場合はこれまでのカウント件数を返して終了
            CountChr = n
            Exit Function
        End If
        'カウント
        n = n + 1
        'チェック先の検索開始文字をHit箇所+キーワード文字数に変更
        i = i + Len(sChk)
    Loop

End Function


Public Function ChkRep(sValue As String) As String
    Dim sType As String
    Dim sType2 As String
    Dim sResult As String
    Dim i As Long
    Dim j As Long
    sResult = ""
    For i = 1 To Len(sValue) - 1
        sType = getChrType(Mid(sValue, i, 1))
        If sType <> "通常文字" Then
'16/08/10 スペース文字をスキップする処理を追加
            j = 1
            Do Until Mid(sValue, i + j, 1) <> " " And Mid(sValue, i + j, 1) <> "　"
                j = j + 1
            Loop
'ここまで 16/08/10
            sType2 = getChrType(Mid(sValue, i + j, 1))
            If sType = sType2 Then
                If sResult <> "" Then sResult = sResult & "/"
                sResult = sResult & sType & "(" & i & "-" & i + j & ")"
            End If
        End If
    Next i
    ChkRep = sResult
End Function


Public Function getChrType(chr As String) As String
    Dim sType As String
    Select Case chr
    
    Case "(", "（"
        sType = "括弧(開)"
    Case ")", "）"
        sType = "括弧(閉)"
    
    Case "‘", "’", "｀", "´"
        sType = "引用符"
    Case "％"
        sType = "パーセント"
    Case "＆"
        sType = "アンパサンド"
    Case "：", "；", ":", ";"
        sType = "コロン・セミコロン"
    Case "。", "、"
        sType = "句読点"
    Case "・"
        sType = "中点"
    Case ",", "，"
        sType = "カンマ"
    Case ".", "．"
        sType = "ピリオド"
    Case "…"
        sType = "三点リーダー"
    Case "+", "-", "＋", "−", "×", "÷", "＝", "≠", "∞"
        sType = "計算記号"
    Case "／"
        sType = "スラッシュ"
    Case "？", "！", "?", "!"
        sType = "感嘆符・疑問符"
    Case "￥", "＠"
        sType = "その他"
    Case "＠", "Α", "Β", "Γ", "Δ", "Ε", "Ζ", "Η", "Θ", "Ι", "Κ", "Λ", "Μ", "Ν", "Ξ", "Ο", "Π", "Ρ", "Σ", "Τ", "Υ", "Φ", "Χ", "Ψ", "Ω", "α", "β", "γ", "δ", "ε", "ζ", "η", "θ", "ι", "κ", "λ", "μ", "ν", "ξ", "ο", "π", "ρ", "σ", "τ", "υ", "φ", "χ", "ψ", "ω", "А", "Б", "В", "Г", "Д", "Е", "Ё", "Ж", "З", "И", "Й", "К", "Л", "М", "Н", "О", "П", "Р", "С", "Т", "У", "Ф", "Х", "Ц", "Ч", "Ш", "Щ", "Ъ", "Ы", "Ь", "Э", "Ю", "Я", "а", "б", "в", "г", "д", "е", "ё", "ж", "з", "и", "й", "к", "л", "м", "н", "о", "п", "р", "с", "т", "у", "ф", "х", "ц", "ч", "ш", "щ", "ъ", "ы", "ь", "э", "ю", "я"
        sType = "ギリシャ文字・キリル文字"
    Case Else
        sType = "通常文字"
    End Select
    
    getChrType = sType
End Function