[VBA]メールアドレスの入力チェック

メールアドレスのチェックは複雑で、インターネット検索してもなかなか正解が見つかりません。もっと正確なチェック方法があるのかもしれませんが、とりあえずメモとしておいておきます。

もっといいコードがあったらご紹介いただけるとありがたいです。

'=============================================================
Function mailAddressCheck(mailAddress As String) As Boolean
'=============================================================
'概要：メールアドレス自動訂正の範囲外のメール誤りを検出する
'------------------------------------------------------------
mailAddressCheck = True

If mailAddress = "" Then
    Exit Function
End If

Dim objRegEX As Object
Set objRegEX = CreateObject("VBScript.RegExp")

With objRegEX
    '正規表現をPatternプロパティにセットする
    .Pattern = "^[a-zA-Z0-9_+-]+(\.[a-zA-Z0-9_+-]+)*@([a-zA-Z0-9][a-zA-Z0-9-]*[a-zA-Z0-9]*\.)+[a-zA-Z]{2,}$"
    
        mailAddress = Trim(mailAddress)
        mailAddress = StrConv(mailAddress, vbNarrow)
        mailAddress = Replace(mailAddress, " ", "")
        mailAddress = Replace(mailAddress, "　", "")
        mailAddress = Replace(mailAddress, "＠", "@")
        mailAddress = delDependentChar(mailAddress)
                    
        Dim multipleAddress1() As String
        multipleAddress1 = Split(mailAddress, ";")
        
        Dim multipleAddress2() As String
        multipleAddress2 = Split(mailAddress, vbCrLf)
        
        Dim multipleAddress3() As String
        multipleAddress3 = Split(mailAddress, vbLf)
        
        
        Dim Address() As String
         
        If UBound(multipleAddress1) > 0 Then
            Dim adrs As Variant
            For Each adrs In multipleAddress1
                If adrs <> "" Then Call addDataToLastArrayOfString(Address, CStr(adrs))
            Next
        
        ElseIf UBound(multipleAddress2) > 0 Then
            For Each adrs In multipleAddress2
                If adrs <> "" Then Call addDataToLastArrayOfString(Address, CStr(adrs))
            Next
        
        ElseIf UBound(multipleAddress3) > 0 Then
            For Each adrs In multipleAddress3
                If adrs <> "" Then Call addDataToLastArrayOfString(Address, CStr(adrs))
            Next
        Else
            Call addDataToLastArrayOfString(Address, mailAddress)
        End If
        
        For Each adrs In Address
            If Not (.test(CStr(adrs))) Then  '正規表現にマッチしていない
                mailAddressCheck = False
                Debug_Printb "mailAddressCheck: mailAddress Fault"
            End If
        Next
    
End With

End Function

ちなみに、その前に大文字を入れたりスペースが入っていたりするので、自動訂正をしたあとで形式チェックしたほうがよいです。

自動訂正

'=============================================================
Sub correctMailArray(ByRef mail() As Variant)
'=============================================================
'概要：メールアドレス自動訂正
'       メールアドレス形式が正しいかを点検し異なる場合は
'       削除または修正する
'------------------------------------------------------------
Dim objRegEX As Object
Set objRegEX = CreateObject("VBScript.RegExp")

With objRegEX
    '正規表現をPatternプロパティにセットする
    .Pattern = "^[a-zA-Z0-9_+-]+(\.[a-zA-Z0-9_+-]+)*@([a-zA-Z0-9][a-zA-Z0-9-]*[a-zA-Z0-9]*\.)+[a-zA-Z]{2,}$"
    
    Dim i As Long
        i = 0

    '配列を途中で削除するため、For Eachは利用できない
    '追加・削除対応のため都度配列の最大値（Ubound)を確認する
    
    Do While i <= UBound(mail)

        Dim tempMail As String
        
        tempMail = mail(i)
        Debug_Printb " Sub correctMailArray: mailAddress(replace before) : " & mail(i)
        
        mail(i) = Trim(mail(i))
        mail(i) = StrConv(mail(i), vbNarrow)
        mail(i) = Replace(mail(i), " ", "")
        mail(i) = Replace(mail(i), "　", "")
        mail(i) = Replace(mail(i), "＠", "@")
        mail(i) = delDependentChar(CStr(mail(i)))
        
        If tempMail <> mail(i) Then
            Debug_Printb " Sub correctMailArray: mailAddress(replaced Char) : " & mail(i)
        End If
        
        Dim insertAddress() As String
        
        Erase insertAddress
        insertAddress = Split(mail(i), ";")
        If IsInitArrayString(insertAddress) Then
        
            If UBound(insertAddress) > 0 Then
                Dim Address As Variant
                For Each Address In insertAddress
                    Debug_Printb " Sub correctMailArray: mailAddress(replaced Addreses) :； " & Address
                Next
            
                Call insertArray(mail(), insertAddress(), i)
                Debug_Printb " Sub correctMailArray: mailAddress(Nwe Address) :； " & mail(i)
            End If
            
        End If
        
        Erase insertAddress
        insertAddress = Split(mail(i), vbCrLf)
        If IsInitArrayString(insertAddress) Then
            
            If UBound(insertAddress) > 0 Then
            
                For Each Address In insertAddress
                    Debug_Printb " Sub correctMailArray: mailAddress(replaced Addreses) :vbCRLF " & Address
                Next
                
                Call insertArray(mail(), insertAddress(), i)
                Debug_Printb " Sub correctMailArray: mailAddress(replaced Address) :vbCRLF " & mail(i)
        
            End If
            
        End If
        
        
        Erase insertAddress
        insertAddress = Split(mail(i), vbLf)
        If IsInitArrayString(insertAddress) Then
            
            If UBound(insertAddress) > 0 Then
            
                For Each Address In insertAddress
                    Debug_Printb " Sub correctMailArray: mailAddress(replaced Addreses) :vbLF " & Address
                Next
                
                Call insertArray(mail(), insertAddress(), i)
                Debug_Printb " Sub correctMailArray: mailAddress(replaced Address) :vbLF " & mail(i)
        
            End If
            
        End If
        
        Dim match As Boolean

        If Not (.test(mail(i))) Then  '正規表現にマッチしていない場合、修正ダイアログを表示する

            Debug_Printb " Sub correctMailArray: mailAddress : notMached"

            AutoAddress_mailAddressError.emailAddressInList = mail(i)
            AutoAddress_mailAddressError.correctMailAddress.Value = mail(i)

            AutoAddress_mailAddressError.Show

            Select Case ret

                Case "correct"

                    mail(i) = AutoAddress_mailAddressError.correctMailAddress.Text
                    Debug_Printb " Sub correctMailArray: corrected email Address: " & mail(i)

                    i = i + 1

                Case "garbedge"

                    Call delValFromArray(mail, i)

            End Select

            Unload AutoAddress_mailAddressError

        Else
            '処理なしで次へ

            Debug_Printb " Sub correctMailArray: mailAddress : Mached"
            i = i + 1

        End If

    Loop
    
End With

End Sub