'Copyright (c) 2015 nicotan
'Released under the MIT license
'http://opensource.org/licenses/mit-license.php
'http://nicotan.at-ninja.jp/blog/newWindow/conversion_Excel_JANCODE-nicotan.html

Sub janHelp()
    Application.MacroOptions macro:="Jan", _
        Description:="Janコードをエクセル上でバーコード表示します。()の中に7桁、8桁、12桁、13桁のJANを入力してください。もしくはJANコードが入力されているセルを指定してください。" & vbCrLf & "表示された文字のフォントをJANCODE-nicotanに変更するとバーコードが表示されます。", _
        Category:="JANCODE"
    Application.MacroOptions macro:="JanCD", _
        Description:="7桁、12桁のJANコードのチェックデジットを計算して0～9の数字を返します。", _
        Category:="JANCODE"
    Application.MacroOptions macro:="reJan", _
        Description:="JANコードのフォント用文字列をJANコードの数値に戻します。", _
        Category:="JANCODE"
    Application.MacroOptions macro:="JanW", _
        Description:="JANCODE-nicWabun フォントの数字なしのバーコードを表示するため数式です。" & vbCrLf & "=JAN()の答えを全角化した文字列を返します。", _
        Category:="JANCODE"
    Application.MacroOptions macro:="ITF", _
        Description:="ITFコードの数式です。" & vbCrLf & "第１引数にはインジケータ(外箱)" & vbCrLf & "第２引数にはJANコードを指定してください。" & vbCrLf & "チェックデジットを付与したITFコード(14桁)を返します。", _
        Category:="JANCODE"
    Application.MacroOptions macro:="ITFCD", _
        Description:="ITFコードのチェックデジットを返す数式です。" & vbCrLf & "第１引数にはインジケータ(外箱)" & vbCrLf & "第２引数にはJANコード(12,13)を指定してください。" & vbCrLf & "チェックデジットを返します。", _
        Category:="JANCODE"
        
    '関係ないユーザー定義関数を表示から消す
    Application.MacroOptions macro:="CD", Description:="", Category:=0
    Application.MacroOptions macro:="Eight", Description:="", Category:=0
    Application.MacroOptions macro:="Thirteen", Description:="", Category:=0
    Application.MacroOptions macro:="StartCode", Description:="", Category:=0
    Application.MacroOptions macro:="undo", Description:="", Category:=0
End Sub

Public Function Jan(JANCODE)
'入力されていない場合
If JANCODE = "" Then
    Jan = CVErr(xlErrNA)
    Exit Function
End If

'数値じゃない場合
If Not IsNumeric(JANCODE) Then
    Jan = CVErr(xlErrValue)
    Exit Function
End If

'数字の数が8桁か13桁か
On Error GoTo Err
    Select Case Len(JANCODE)
        Case 7:
            Jan = Eight(JANCODE)
        Case 8:
            Jan = Eight(JANCODE)
        Case 12:
            Jan = Thirteen(JANCODE)
        Case 13:
            Jan = Thirteen(JANCODE)
        Case Else
            GoTo Err
    End Select
Exit Function

Err:
    Jan = CVErr(xlErrValue)
    Exit Function
End Function

Public Function JanW(JANCODE) As String
Dim ans As Variant
ans = Jan(JANCODE)
If IsError(ans) Then
    JanW = ans
Else
    JanW = StrConv(ans, vbWide)
End If
End Function

Public Function JanCD(JANCODE)
'入力されていない場合
If JANCODE = "" Then
    JanCD = CVErr(xlErrNA)
    Exit Function
End If

'数値じゃない場合
If Not IsNumeric(JANCODE) Then
    JanCD = CVErr(xlErrValue)
    Exit Function
End If
'数字の数が8桁か13桁か
On Error GoTo Err
    Select Case Len(JANCODE)
        Case 7:
            JanCD = CD("00000" + CStr(JANCODE))
        Case 8:
            JanCD = CD("00000" + CStr(JANCODE))
        Case 12:
            JanCD = CD(JANCODE)
        Case 13:
            JanCD = CD(JANCODE)
        Case Else
            GoTo Err
    End Select
Exit Function

Err:
    JanCD = CVErr(xlErrValue)
    Exit Function
End Function

Public Function reJan(strJan)
Dim JANCODE As String, ans As Variant
On Error GoTo Err
'全角なら半角に
strJan = StrConv(strJan, vbNarrow)
Select Case Len(strJan)
    Case 11:
        ans = undo(strJan, 11)
        If ans <> False Then
            JANCODE = ans
        End If
    Case 15:
        ans = undo(strJan, 15)
        If ans <> False Then
            JANCODE = ans
        End If
    Case Else
        GoTo Err
End Select

reJan = JANCODE

Exit Function
Err:
    reJan = CVErr(xlErrValue)
    Exit Function
End Function

Private Function CD(strJancode) As Byte
Dim g As Byte, k As Byte, h As Byte
g = 0
k = 0
h = 0
For i = 12 To 1 Step -2
    g = g + Val(Mid(strJancode, i, 1))
    k = k + Val(Mid(strJancode, i - 1, 1))
Next
h = (g * 3 + k) Mod 10
If h = 0 Then
    CD = 0
Else
    CD = 10 - h
End If
End Function

Private Function Eight(n)
Dim strJanfont As String, CheckDigit As Byte, BAR As Variant
BAR = getBar
'スタートコードの代入
strJanfont = "Y"
For i = 1 To 4
    strJanfont = strJanfont + Mid(n, i, 1)
Next
'センターコードの代入
strJanfont = strJanfont + "K"
'右側
For i = 5 To 7
    strJanfont = strJanfont + BAR(2)(CByte(Mid(n, i, 1)))
Next
'チェックデジットの計算
CheckDigit = CD("00000" + CStr(n))
'チェックデジットの追加
strJanfont = strJanfont + BAR(2)(CheckDigit)
'エンドコードの追加
strJanfont = strJanfont + "Z"
'結果
Eight = strJanfont
End Function
Private Function Thirteen(n)
Dim strJanfont As String
Dim Initial(9) As Variant
Dim nIni As Byte
Dim CheckDigit As Byte
Dim BAR As Variant

'頭の文字によってパターンが決まる
Initial(0) = "000000"
Initial(1) = "001011"
Initial(2) = "001101"
Initial(3) = "001110"
Initial(4) = "010011"
Initial(5) = "011001"
Initial(6) = "011100"
Initial(7) = "010101"
Initial(8) = "010110"
Initial(9) = "011010"
strJanfont = ""
nIni = 0
BAR = getBar
    
'スタートコードの代入
nIni = Left(n, 1)
strJanfont = getStartCode(nIni)

'6パターン繰り返す
For i = 1 To 6
    strJanfont = strJanfont + BAR(CByte(Mid(Initial(nIni), i, 1)))(CByte(Mid(n, i + 1, 1)))
Next
'センターコードの追加
strJanfont = strJanfont + "K"
'右側
For i = 8 To 12
    strJanfont = strJanfont + BAR(2)(CByte(Mid(n, i, 1)))
Next
'チェックデジットの計算
CheckDigit = CD(n)
'チェックデジットの追加
strJanfont = strJanfont + BAR(2)(CheckDigit)
'エンドコードの追加
strJanfont = strJanfont + "Z"
'結果
Thirteen = strJanfont
End Function

Private Function undo(strJan, n)
Dim temp As String
temp = ""
For i = 1 To n
    Select Case Mid(strJan, i, 1)
        Case "a", "0", "A", "L"
            temp = temp + "0"
        Case "b", "1", "B", "M"
            temp = temp + "1"
        Case "c", "W", "2", "C", "N"
            temp = temp + "2"
        Case "d", "3", "D", "O"
            temp = temp + "3"
        Case "e", "X", "4", "E", "P"
            temp = temp + "4"
        Case "f", "5", "F", "Q"
            temp = temp + "5"
        Case "g", "6", "G", "R"
            temp = temp + "6"
        Case "h", "7", "H", "S"
            temp = temp + "7"
        Case "i", "8", "I", "T"
            temp = temp + "8"
        Case "j", "9", "J", "U"
            temp = temp + "9"
        Case "K", "Y", "Z"
        
        Case Else
            undo = False
            Exit Function
    End Select
Next
undo = temp
End Function

Private Function getStartCode(n) As String
Dim Startbar(9) As String
Startbar(0) = "a"
Startbar(1) = "b"
Startbar(2) = "W"
Startbar(3) = "d"
Startbar(4) = "X"
Startbar(5) = "f"
Startbar(6) = "g"
Startbar(7) = "h"
Startbar(8) = "i"
Startbar(9) = "j"
getStartCode = Startbar(n)
End Function

Private Function getBar() As Variant
Dim BAR(2) As Variant
Dim k(9) As String
Dim g(9) As String
Dim r(9) As String
k(0) = "0"
k(1) = "1"
k(2) = "2"
k(3) = "3"
k(4) = "4"
k(5) = "5"
k(6) = "6"
k(7) = "7"
k(8) = "8"
k(9) = "9"
g(0) = "A"
g(1) = "B"
g(2) = "C"
g(3) = "D"
g(4) = "E"
g(5) = "F"
g(6) = "G"
g(7) = "H"
g(8) = "I"
g(9) = "J"
r(0) = "L"
r(1) = "M"
r(2) = "N"
r(3) = "O"
r(4) = "P"
r(5) = "Q"
r(6) = "R"
r(7) = "S"
r(8) = "T"
r(9) = "U"
BAR(0) = k
BAR(1) = g
BAR(2) = r
getBar = BAR
End Function

Public Function ITF(indicator, JANCODE)
Dim ind As String
'入力されていない場合
If indicator = "" Or JANCODE = "" Then
    ITF = CVErr(xlErrNA)
    Exit Function
End If

'数値じゃない場合
If Not IsNumeric(indicator) And IsNumeric(JANCODE) Then
    ITF = CVErr(xlErrValue)
    Exit Function
End If
ind = CStr(indicator Mod 10)

'数字の数が8桁か13桁か
On Error GoTo Err
    Select Case Len(JANCODE)
        Case 7:
            ITF = ind & "00000" & JANCODE & CStr(ITFCD(ind, CStr("00000" & JANCODE)))
        Case 8:
            ITF = ind & "00000" & Mid(CStr(JANCODE), 1, 7) & CStr(ITFCD(ind, CStr("00000" & Mid(CStr(JANCODE), 1, 7))))
        Case 12:
            ITF = ind & CStr(JANCODE) & CStr(ITFCD(ind, CStr(JANCODE)))
        Case 13:
            ITF = ind & Mid(CStr(JANCODE), 1, 12) & CStr(ITFCD(ind, CStr(JANCODE)))
        Case Else
            GoTo Err
    End Select
Exit Function

Err:
    ITF = CVErr(xlErrValue)
    Exit Function
End Function

Public Function ITFCD(indicator As String, JANCODE As String) As Byte
Dim g As Byte, k As Byte, h As Byte
Dim strCODE As String
g = 0
k = 0
h = 0
strCODE = Mid(indicator & JANCODE, 1, 13)
For i = 1 To 13 Step 2
    g = g + Val(Mid(strCODE, i, 1))
    k = k + Val(Mid(strCODE, i + 1, 1))
Next
h = (g * 3 + k) Mod 10
If h = 0 Then
    ITFCD = 0
Else
    ITFCD = 10 - h
End If
End Function