郵便カスタマーバーコード変換ロジック

いきなり始めた、このBlog。
これまでの業務で作ったプログラムや、HowToやTipsなんかを書いていこうかと。

今回は、郵便カスタマーバーコードを作成するための変換ロジックを公開します。
一応免責事項として、このロジックを使って不具合や損害が発生しても、責任は
持ちませんので、利用される場合は十分なテスト、動作確認を行った上で使用し
てくださいね。

AccessVBAで作成しているので、Accessで利用してください。
その際、「Microsoft VBScript Regular Expressions 5.5」の参照設定が必要です
ので、ご注意ください。

このロジックは、日本郵政が公開している「バーコードに必要な文字情報の抜き出し法」
を参考に作成しました。
【参考】　http://www.post.japanpost.jp/zipcode/zipmanual/p17.html

--------以下、コード---------
Option Compare Database

Public Const FIND_NUM As String = "壱弐参〇一二三四五六七八九十百千"
Public Const FIND_TEXT As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"

Public Function CreateCustomerBarCode(strZip As String, ByVal strAddress As String) As String

    Dim strRetZip       As String
    Dim strRetAddress   As String
    Dim strChar         As String
    Dim blnConvFlg      As Boolean   'ハイフンに置き換え済みフラグ
    Dim intLoop         As Integer
    Dim i               As Integer
    Dim j               As Integer
    Dim intCount        As Integer
    Dim intPos          As Integer
    Dim intTextLength   As Integer
    Dim intTargetPos    As Integer
    Dim strFindKeyword  As String
    Dim strTargetText   As String
    Dim strConvertText  As String
    Dim strTemp()       As String
    Dim strResult       As String
    Dim varConvertNum   As Variant
    Dim varDeleteText   As Variant
    Dim intFindPos      As Integer
    Dim objRegExp       As RegExp   '参照設定要(Microsoft VBScript Regular Expressions 5.5)
    Dim objMatchCollect As MatchCollection
    Dim objMatch        As Match
    Dim strTarget()     As String
    Dim intMatchPos()   As Integer
   
    varConvertNum = Array("1", "2", "3", "0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "100", "1000")
   
    varDeleteText = Array("&", "＆", "/", "／", "･", "・", ".", "．")
   
    '郵便番号にハイフンがあったら除外します
    strRetZip = Replace(strZip, "-", "", , , vbTextCompare)
   
    '住所の全角文字を半角に変換します
    strAddress = StrConv(strAddress, vbNarrow)
     
    '住所に含まれる記号を除外します
    For intLoop = 1 To UBound(varDeleteText)
      strAddress = Replace(strAddress, varDeleteText(intLoop), "", , , vbTextCompare)
    Next intLoop

    '２つ以上連続したアルファベットを「-」へ置換する
    Set objRegExp = New RegExp
    '正規表現で２つ以上連続したアルファベットを検索し、「-」へ置換する。
    objRegExp.Pattern = "[a-zA-Z][a-zA-Z]+"
    objRegExp.Global = True '複数該当する場合に対応
    strAddress = objRegExp.Replace(strAddress, "-")
   
    '抜き出しの補足ルール
    'http://www.post.japanpost.jp/zipcode/zipmanual/p19.html
   
    '1. 漢数字が下記の特定文字の前にある場合は抜き出し対象とし、算用数字に変換して抜き出します。
    '特定文字群(9種類) "丁目"　 "丁 "　"番地" 　"番"　 "号" 　"地割" 　"線"　 "の" 　"ノ"
   
    '１つずつ見ていく
    For i = 1 To 9
        strFindKeyword = ""
        Select Case i
            Case 1
                strFindKeyword = "丁目"
            Case 2
                strFindKeyword = "丁"
            Case 3
                strFindKeyword = "番地"
            Case 4
                strFindKeyword = "番"
            Case 5
                strFindKeyword = "号"
            Case 6
                strFindKeyword = "地割"
            Case 7
                strFindKeyword = "線"
            Case 8
                strFindKeyword = "の"
            Case 9
                strFindKeyword = "ノ"
        End Select
       
        '当該キーワードが見つかるか？
        intPos = InStr(strAddress, strFindKeyword)
       
        '見つかったら変換処理を行う。
        If intPos > 0 Then
            '見つかったところから左へ１つずつ移動し漢数字じゃなくなったら終了
            For intCount = intPos To 2 Step -1
                strTargetText = Mid$(strAddress, (intCount - 1), 1)
                intTargetPos = InStr(FIND_NUM, strTargetText)
               
                '漢数字なら継続
                If intTargetPos > 0 Then
                Else
                    '漢数字以外ならループを抜ける
                    Exit For
                End If
            Next intCount
           
            strResult = ""
           
            'カウントが開始位置と同一なら漢数字なしと判定して何もしない。
            If intPos = intCount Then
            Else
                strConvertText = Mid$(strAddress, intCount, (intPos - intCount))
                intTextLength = Len(strConvertText)
                ReDim strTemp(intTextLength)
                For j = 1 To intTextLength
                    intTargetPos = InStr(FIND_NUM, Mid$(strConvertText, j, 1))
                    strTemp(j) = varConvertNum(intTargetPos - 1)
                Next j
               
                strResult = "0"
               
                '計算して数値を求める
                For j = 1 To intTextLength
                    If (j = 1) Then
                        strResult = strTemp(j)
                    Else
                        '２桁以上なら前の桁と掛け算して足す
                        If Len(strTemp(j)) >= 2 Then
                            'すでに代入されている値が２桁以上なら足す
                            If Len(strResult) >= 2 Then
                                strResult = CStr(CInt(strResult) + (CInt(strTemp(j - 1)) * CInt(strTemp(j))))
                            Else
                                '代入されている数字が１桁なら、そのまま代入
                                strResult = CStr(CInt(strTemp(j - 1)) * CInt(strTemp(j)))
                            End If
                        Else
                            '１つ前が２桁以上か？
                            If Len(strTemp(j - 1)) >= 2 Then
                                '最終桁だったら足す
                                If j = intTextLength Then
                                    strResult = CStr(CInt(strResult) + CInt(strTemp(j)))
                                Else
                                    'それ以外だったら何もしないで次にまわす
                                End If
                            Else
                                '１桁なら結合する
                                strResult = strResult & strTemp(j)
                            End If
                        End If
                    End If
                Next j
            End If
            '変換した結果があれば処理する
            If Len(strResult) = 0 Then
            Else
                strAddress = Left$(strAddress, (intCount - 1)) & strResult & Mid$(strAddress, intPos)
            End If
        End If
    Next i
 
    '住所から数字部分だけを取り出して"("で区切ります
    strRetAddress = ""
   
    blnConvFlg = True '先頭の数字以外の文字は無視する設定
   
    For intLoop = 1 To Len(strAddress)
      '１文字取り出し
      strChar = Mid$(strAddress, intLoop, 1)
     
        If IsNumeric(strChar) Then
           
            '数字のとき
            strRetAddress = strRetAddress & strChar
            blnConvFlg = False
         
        Else
       
            'ハイフンに置き換え済みでないとき
            If Not blnConvFlg Then
                'アルファベットだったらそのままくっつける
                intFindPos = InStr(FIND_TEXT, strChar)
                If intFindPos > 0 Then
                    If intFindPos = 6 Then  'Fだったら特別扱い->"-"に置き換え
                        strRetAddress = strRetAddress & "-"
                    Else
                        If Right$(strRetAddress, 1) = "-" Then
                            strRetAddress = strRetAddress & strChar
                        Else
                            strRetAddress = strRetAddress & "-" & strChar & "-"
                        End If
                    End If
                Else
                    strRetAddress = strRetAddress & "-"
                End If
                blnConvFlg = True
            Else

                'アルファベットだったらそのままくっつける
                intFindPos = InStr(FIND_TEXT, strChar)
                If intFindPos > 0 Then
                    If Right$(strRetAddress, 1) = "-" Then
                        strRetAddress = strRetAddress & strChar
                    Else
                        strRetAddress = strRetAddress & "-" & strChar & "-"
                    End If
                Else
                    strRetAddress = strRetAddress & "-"
                End If
                blnConvFlg = True
            End If
        End If
    Next intLoop
   
    '最終処理
   
    '連続したハイフンは１つする
    objRegExp.Pattern = "\-\-+"
    objRegExp.Global = True '複数該当する場合に対応
    strRetAddress = objRegExp.Replace(strRetAddress, "-")
   
    '最後と先頭のハイフンを除去します
   
    If Left$(strRetAddress, 1) = "-" Then
      strRetAddress = Mid$(strRetAddress, 2)
    End If
   
    If Right$(strRetAddress, 1) = "-" Then
      strRetAddress = Left$(strRetAddress, Len(strRetAddress) - 1)
    End If
   
    '（アルファベットの前後の-(ハイフン)は取り除きます）
    objRegExp.Pattern = "-[a-zA-Z]-"
    objRegExp.Global = True '複数該当する場合に対応
   
    'パターンマッチするものをCollectionへ格納
    Set objMatchCollect = objRegExp.Execute(strRetAddress)
    '１つ以上あれば以降の処理を継続
    If objMatchCollect.Count > 0 Then
        '配列を再定義
        ReDim strTarget(objMatchCollect.Count)
        ReDim intMatchPos(objMatchCollect.Count)
       
        '複数該当に対応する
        For i = 0 To (objMatchCollect.Count - 1)
            'Collectionの情報を展開
            Set objMatch = objMatchCollect.Item(i)
            '-(ハイフン)をスペースへ変換して格納
            strTarget(i + 1) = Replace(objMatch.Value, "-", " ", , , vbTextCompare)
            '文字列が見つかった場所を格納
            intMatchPos(i + 1) = objMatch.FirstIndex
        Next i
       
        '実際に置き換える
        For i = 1 To objMatchCollect.Count
            strRetAddress = Left$(strRetAddress, intMatchPos(i)) & strTarget(i) & Mid$(strRetAddress, (intMatchPos(i) + Len(strTarget(i)) + 1))
        Next i
        '文字列中の空白を削って終了
        strRetAddress = Replace(strRetAddress, " ", "", , , vbTextCompare)
       
    End If

    '変換された郵便番号と住所を結合して返します
    CreateCustomerBarCode = strRetZip & strRetAddress

End Function