Option Explicit

' このプログラムを実行するには
' 
' ●今見ているこのテキスト上で [Ctrl]+[A]、[Ctrl]+[C] としてコピーする
' ●エクセル、ワードなどを起動する
' ●[Alt]+[F11] を押してＶＢＥを起動する
' ●メニューの [挿入(I)] → [標準モジュール(M)] を選択する。
' ●[Ctrl]+[V] として貼り付ける
' ●[F5] として、あとは指示に従う


Private Const NAME = "Mizunara"

Private Const HKEY_CURRENT_USER = &H80000001
Private Const REG_BINARY = 3
Private Const KEY_ALL_ACCESS = &HF003F
Private Const IME_PATH97 = "Software\Microsoft\Ime\msime97\RomaDef"
Private Const IME_PATH98 = "Software\Microsoft\Windows\CurrentVersion\ime\Japan\ime98\RomaDef"
Private Const IME_PATH2000 = "Software\Microsoft\Windows\CurrentVersion\IME\Japan\IMEJP\RomaDef"
Private Const IME_PATH_OLD = "Software\Microsoft\IMEJP\"
Private Const IME_PATH_NEW1 = "Software\Microsoft\IME\"
Private Const IME_PATH_NEW2 = "\IMEJP"

#If Win64 Then
Private Declare PtrSafe Function RegCreateKeyExA Lib "advapi32" _
(ByVal h As LongPtr, ByVal sb As String, ByVal reserved As Long, ByVal cls As Long, _
ByVal opt As Long, ByVal sam As Long, ByVal sec As LongPtr, _
res As LongPtr, dis As Long) As Long

Private Declare PtrSafe Function RegOpenKeyExA Lib "advapi32" _
(ByVal h As LongPtr, ByVal sb As String, ByVal ipt As Long, ByVal san As Long, res As LongPtr) As Long

Private Declare PtrSafe Function RegCloseKey Lib "advapi32" (ByVal h As LongPtr) As Long

Private Declare PtrSafe Function RegSetValueExA Lib "advapi32" _
(ByVal h As LongPtr, ByVal NAME As String, ByVal res As Long, _
 ByVal tp As Long, ddata As Any, ByVal sz As Long) As Long

Private Declare PtrSafe Function RegQueryValueExA Lib "advapi32" _
(ByVal h As LongPtr, ByVal NAME As String, ByVal res As LongPtr, _
 ByRef tp As Long, ddata As Any, ByRef sz As Long) As Long

Private Declare PtrSafe Function RegDeleteValueA Lib "advapi32" (ByVal h As LongPtr, ByVal NAME As String) As Long
Private Declare PtrSafe Function RegDeleteKeyA Lib "advapi32" (ByVal h As LongPtr, ByVal NAME As String) As Long
Private h As LongPtr
#Else
Private Declare Function RegCreateKeyExA Lib "advapi32" _
(ByVal h As Long, ByVal sb As String, ByVal reserved As Long, ByVal cls As Long, _
ByVal opt As Long, ByVal sam As Long, ByVal sec As Long, res As Long, _
dis As Long) As Long

Private Declare Function RegOpenKeyExA Lib "advapi32" _
(ByVal h As Long, ByVal sb As String, ByVal ipt As Long, ByVal san As Long, lp As Long) As Long

Private Declare Function RegCloseKey Lib "advapi32" (ByVal h As Long) As Long

Private Declare Function RegSetValueExA Lib "advapi32" _
(ByVal h As Long, ByVal NAME As String, ByVal res As Long, _
 ByVal tp As Long, ddata As Any, ByVal sz As Long) As Long

Private Declare Function RegQueryValueExA Lib "advapi32" _
(ByVal h As Long, ByVal NAME As String, ByVal res As Long, _
 ByRef tp As Long, ByVal ddata As Long, ByVal sz As Long) As Long

Private Declare Function RegDeleteValueA Lib "advapi32" (ByVal h As Long, ByVal NAME As String) As Long
Private Declare Function RegDeleteKeyA Lib "advapi32" (ByVal h As Long, ByVal NAME As String) As Long
Private h As Long
#End If

Private num As Long
Private BinData(0 To 10000) As Byte
Private mizu As String
Private roma As String
Private TSUKI_DEF As String
Private TSUKI_NAME As String

Private Sub InitTsuki()
 mizu = ""
 mizu = mizu & "d'」 d[「 d]」 "
 mizu = mizu & "qも  wに  eは  rて  tで  yれ  uっ  iし  oと  pの  aか  fな  gる  hき  "
 mizu = mizu & "jん  ;い  zこ  xが  cだ  vた  bょ  nく  mう  kqご kwづ keぼ krほ ktへ "
 mizu = mizu & "kaあ ksけ kdす kfお kgさ kzや kxゆ kcぜ kvね kbよ dyぉ duぷ diぶ doえ "
 mizu = mizu & "dpゃ d@「 dhひ djつ dkち dlじ d;ま d:」 dnぬ dmみ d,ぺ d.ゅ d/ぴ lqべ "
 mizu = mizu & "lwぃ leぁ lrど ltぞ laら lsせ ldわ lfろ lgそ lzび lxぇ lcげ lvふ lbざ "
 mizu = mizu & "suぱ siぽ soば spず shぎ sjー skめ slり s;を snぐ smむ s,ヴ s.ぅ s/ぢ "
 mizu = mizu & " "
 roma = ""
 roma = roma & "-ー     aあ     baば    beべ    biび    boぼ    buぶ    byaびゃ byeびぇ "
 roma = roma & "byiびぃ byoびょ byuびゅ caか    ceせ    chaちゃ cheちぇ chiち   choちょ "
 roma = roma & "chuちゅ ciし    coこ    cuく    cyaちゃ cyeちぇ cyiちぃ cyoちょ cyuちゅ "
 roma = roma & "daだ    deで    dhaでゃ dheでぇ dhiでぃ dhoでょ dhuでゅ diぢ    doど    "
 roma = roma & "duづ    dwaどぁ dweどぇ dwiどぃ dwoどぉ dwuどぅ dyaぢゃ dyeぢぇ dyiぢぃ "
 roma = roma & "dyoぢょ dyuぢゅ eえ     faふぁ  feふぇ  fiふぃ  foふぉ  fuふ    fwaふぁ "
 roma = roma & "fweふぇ fwiふぃ fwoふぉ fwuふぅ fyaふゃ fyeふぇ fyiふぃ fyoふょ fyuふゅ "
 roma = roma & "gaが    geげ    giぎ    goご    guぐ    gwaぐぁ gweぐぇ gwiぐぃ gwoぐぉ "
 roma = roma & "gwuぐぅ gyaぎゃ gyeぎぇ gyiぎぃ gyoぎょ gyuぎゅ haは    heへ    hiひ    "
 roma = roma & "hoほ    huふ    hyaひゃ hyeひぇ hyiひぃ hyoひょ hyuひゅ iい     jaじゃ  "
 roma = roma & "jeじぇ  jiじ    joじょ  juじゅ  jyaじゃ jyeじぇ jyiじぃ jyoじょ jyuじゅ "
 roma = roma & "kaか    keけ    kiき    koこ    kuく    kwaくぁ kyaきゃ kyeきぇ kyiきぃ "
 roma = roma & "kyoきょ kyuきゅ laぁ    leぇ    liぃ    lkaヵ   lkeヶ   loぉ    ltsuっ  "
 roma = roma & "ltuっ   luぅ    lwaゎ   lyaゃ   lyeぇ   lyiぃ   lyoょ   lyuゅ   maま    "
 roma = roma & "meめ    miみ    moも    muむ    myaみゃ myeみぇ myiみぃ myoみょ myuみゅ "
 roma = roma & "n'ん    naな    neね    niに    nnん    noの    nuぬ    nyaにゃ nyeにぇ "
 roma = roma & "nyiにぃ nyoにょ nyuにゅ oお     paぱ    peぺ    piぴ    poぽ    puぷ    "
 roma = roma & "pyaぴゃ pyeぴぇ pyiぴぃ pyoぴょ pyuぴゅ qaくぁ  qeくぇ  qiくぃ  qoくぉ  "
 roma = roma & "quく    qwaくぁ qweくぇ qwiくぃ qwoくぉ qwuくぅ qyaくゃ qyeくぇ qyiくぃ "
 roma = roma & "qyoくょ qyuくゅ raら    reれ    riり    roろ    ruる    ryaりゃ ryeりぇ "
 roma = roma & "ryiりぃ ryoりょ ryuりゅ saさ    seせ    shaしゃ sheしぇ shiし   shoしょ "
 roma = roma & "shuしゅ siし    soそ    suす    swaすぁ sweすぇ swiすぃ swoすぉ swuすぅ "
 roma = roma & "syaしゃ syeしぇ syiしぃ syoしょ syuしゅ taた    teて    thaてゃ theてぇ "
 roma = roma & "thiてぃ thoてょ thuてゅ tiち    toと    tsaつぁ tseつぇ tsiつぃ tsoつぉ "
 roma = roma & "tsuつ   tuつ    twaとぁ tweとぇ twiとぃ twoとぉ twuとぅ tyaちゃ tyeちぇ "
 roma = roma & "tyiちぃ tyoちょ tyuちゅ uう     vaヴぁ  veヴぇ  viヴぃ  voヴぉ  vuヴ    "
 roma = roma & "vyaヴゃ vyeヴぇ vyiヴぃ vyoヴょ vyuヴゅ waわ    weうぇ  whaうぁ wheうぇ "
 roma = roma & "whiうぃ whoうぉ whuう   wiうぃ  woを    wuう    xaぁ    xeぇ    xiぃ    "
 roma = roma & "xkaヵ   xkeヶ   xnん    xoぉ    xtuっ   xtsuっ  xuぅ    xwaゎ   xyaゃ   "
 roma = roma & "xyeぇ   xyiぃ   xyoょ   xyuゅ   yaや    yeいぇ  yiい    yoよ    yuゆ    "
 roma = roma & "zaざ    zeぜ    ziじ    zoぞ    zuず    zyaじゃ zyeじぇ zyiじぃ zyoじょ "
 roma = roma & "zyuじゅ "
 roma = roma & " "
 TSUKI_DEF = "\RomaDef\" & NAME
 TSUKI_NAME = NAME
End Sub

Private Function MakeData(ByVal src As String, ByVal ime97 As Boolean, ByVal test As Boolean) As Long
    Dim t As String
    Dim table(0 To 4096) As String
    Dim i, j, c, n, dsize As Long
    Dim f As Boolean
    dsize = 0
    i = 1
    n = 0
    Do While i <= Len(src)
        table(n) = ""
        Do While i <= Len(src)
            t = Mid(src, i, 1)
            If t <> " " And t <> "　" And t <> vbTab Then Exit Do
            i = i + 1
        Loop
        If i > Len(src) Then Exit Do
        Do
            c = Asc(Mid(src, i, 1))
            If c < 0 Or c >= 128 Then Exit Do
            i = i + 1
            If i > Len(src) Then Exit Do
            table(n) = table(n) & Chr(c)
        Loop
        If i > Len(src) Then Exit Do
        table(n) = table(n) & "="
        Do
            t = Mid(src, i, 1)
            c = Asc(t)
            If t = " " Or t = "　" Or t = vbTab Then Exit Do
            table(n) = table(n) & t
            i = i + 1
            If i > Len(src) Then Exit Do
        Loop
        Do
            t = Mid(src, i, 1)
            If t <> " " And t <> "　" And t <> vbTab Then Exit Do
            i = i + 1
            If i > Len(src) Then Exit Do
        Loop
        n = n + 1
        If i > Len(src) Then Exit Do
    Loop
    For i = 1 To n - 1
        If table(i - 1) > table(i) Then
            t = table(i)
            j = i - 1
            Do
                table(j + 1) = table(j)
                j = j - 1
                If j < 0 Then
                    f = False
                ElseIf table(j) <= t Then
                    f = False
                Else
                    f = True
                End If
            Loop While f
            table(j + 1) = t
        End If
    Next i
    For i = 0 To n - 1
        t = StrConv(table(i), vbFromUnicode)
        For j = 1 To LenB(t)
            BinData(dsize) = AscB(MidB(t, j, 1))
            dsize = dsize + 1
        Next j
        BinData(dsize) = 0
        dsize = dsize + 1
        If ime97 Then
            BinData(dsize) = 0
            dsize = dsize + 1
        End If
    Next i
    If Not ime97 Then
        BinData(dsize) = 0
        dsize = dsize + 1
    End If
    If test Then
        t = ""
        For i = 0 To n - 1
            t = t & table(i) & vbTab
        Next i
        MsgBox t
    End If
    
    
    MakeData = dsize
End Function

Private Sub SetTsuki()
    Dim d, i, a, b, t(64), dsize As Long
    Dim buf, v, s(64) As String
    Dim r As Integer
    
    buf = ""
    num = 0
    
    If RegOpenKeyExA(HKEY_CURRENT_USER, IME_PATH97, 0, KEY_ALL_ACCESS, h) = 0 Then
        If RegCloseKey(h) <> 0 Then
            MsgBox "Close失敗"
            Exit Sub
        End If
        num = num + 1
        s(num) = IME_PATH97
        t(num) = 97
        buf = buf & s(num) & vbCr
    End If
    
    If RegOpenKeyExA(HKEY_CURRENT_USER, IME_PATH98, 0, KEY_ALL_ACCESS, h) = 0 Then
        If RegCloseKey(h) <> 0 Then
            MsgBox "Close失敗"
            Exit Sub
        End If
        num = num + 1
        s(num) = IME_PATH98
        t(num) = 98
        buf = buf & s(num) & vbCr
    End If
    
    If RegOpenKeyExA(HKEY_CURRENT_USER, IME_PATH2000, 0, KEY_ALL_ACCESS, h) = 0 Then
        If RegCloseKey(h) <> 0 Then
            MsgBox "Close失敗"
            Exit Sub
        End If
        num = num + 1
        s(num) = IME_PATH2000
        t(num) = 2000
        buf = buf & s(num) & vbCr
    End If
    
    For a = 8 To 24
       For b = 0 To 2
           If a <= 14 Then
               v = IME_PATH_OLD & a & "." & b Mod 10
           Else
               v = IME_PATH_NEW1 & a & "." & b & IME_PATH_NEW2
           End If
           If RegOpenKeyExA(HKEY_CURRENT_USER, v, 0, KEY_ALL_ACCESS, h) = 0 Then
               If RegCloseKey(h) <> 0 Then
                   MsgBox "Close失敗"
                   Exit Sub
               End If
               num = num + 1
               s(num) = v
               t(num) = a
               buf = buf & v & vbCr
           End If
        Next b
    Next a
    
    If num = 0 Then
        MsgBox "IME が見つかりませんでした"
    Else
        MsgBox buf & vbCr & "を見つけました。"
    End If
    
    For i = 1 To num
        If False Then
           If num = 1 Then
              v = ""
           Else
               If i = num Then v = "(推奨)" Else v = "(非推奨)"
           End If
        Else
           v = ""
        End If
        buf = s(i) & " に配列を設定しますか？" & v
        If t(i) = 97 Or t(i) = 98 Then
            buf = s(i) & " " & v & vbCrLf & vbCrLf & " Yes:みずなら配列／No:ローマ字配列？"
            r = MsgBox(buf, vbYesNoCancel)
            If r <> vbCancel Then
                If r = vbYes Then dsize = MakeData(mizu, t(i) = 97, False)
                If r = vbNo Then dsize = MakeData(roma, t(i) = 97, False)
                If RegOpenKeyExA(HKEY_CURRENT_USER, s(i), 0, KEY_ALL_ACCESS, h) <> 0 Then
                    MsgBox "Create失敗"
                    Exit Sub
                End If
                If RegSetValueExA(h, "ROMA0", 0, REG_BINARY, BinData(0), dsize) <> 0 Then
                    MsgBox "SetValue失敗"
                    If RegCloseKey(h) <> 0 Then
                        MsgBox "Close失敗"
                    End If
                    Exit Sub
                End If
                If RegCloseKey(h) <> 0 Then
                    MsgBox "Close失敗"
                    Exit Sub
                End If
                MsgBox "成功" & vbCrLf & vbCrLf & "この設定はＯＳを再起動後に有効になります"
            End If
        ElseIf t(i) = 2000 Then
            If MsgBox(buf, vbYesNo) = vbYes Then
                If RegOpenKeyExA(HKEY_CURRENT_USER, s(i), 0, KEY_ALL_ACCESS, h) <> 0 Then
                    MsgBox "Create失敗"
                    Exit Sub
                End If
                dsize = MakeData(mizu, False, False)
                If RegSetValueExA(h, TSUKI_NAME, 0, REG_BINARY, BinData(0), dsize) <> 0 Then
                    MsgBox "SetValue失敗"
                    If RegCloseKey(h) <> 0 Then
                        MsgBox "Close失敗"
                    End If
                    Exit Sub
                End If
                If RegCloseKey(h) <> 0 Then
                    MsgBox "Close失敗"
                    Exit Sub
                End If
                MsgBox "成功" & vbCrLf & vbCrLf & "IMEのプロパティを設定すると有効になります"
            End If
        Else
            If MsgBox(buf, vbYesNo) = vbYes Then
                If RegCreateKeyExA(HKEY_CURRENT_USER, s(i) & TSUKI_DEF, 0, 0, 0, KEY_ALL_ACCESS, 0, h, d) <> 0 Then
                    MsgBox "Create失敗"
                    Exit Sub
                End If
                dsize = MakeData(mizu, False, False)
                If RegSetValueExA(h, "table", 0, REG_BINARY, BinData(0), dsize) <> 0 Then
                    MsgBox "SetValue失敗"
                    If RegCloseKey(h) <> 0 Then
                        MsgBox "Close失敗"
                    End If
                    Exit Sub
                End If
                If RegCloseKey(h) <> 0 Then
                    MsgBox "Close失敗"
                    Exit Sub
                End If
                MsgBox "成功" & vbCrLf & vbCrLf & "IMEのプロパティを設定すると有効になります"
            End If
        End If
    Next i
End Sub

Private Sub DelTsuki()
    Dim d, i, a, b, t(64) As Long
    Dim v, buf, s(64) As String
    
    buf = ""
    num = 0
    
    If RegOpenKeyExA(HKEY_CURRENT_USER, IME_PATH2000, 0, KEY_ALL_ACCESS, h) = 0 Then
        If RegQueryValueExA(h, TSUKI_NAME, 0, d, 0, 0) = 0 Then
            num = num + 1
            s(num) = IME_PATH2000
            t(num) = 2000
            buf = buf & s(num) & vbCr
        End If
        If RegCloseKey(h) <> 0 Then
            MsgBox "Close失敗"
            Exit Sub
        End If
    End If
    
    For a = 8 To 19
       For b = 0 To 2
           If a <= 14 Then
               v = IME_PATH_OLD & a & "." & b & TSUKI_DEF
           Else
               v = IME_PATH_NEW1 & a & "." & b & IME_PATH_NEW2 & TSUKI_DEF
           End If
           If RegOpenKeyExA(HKEY_CURRENT_USER, v, 0, KEY_ALL_ACCESS, h) = 0 Then
               If RegCloseKey(h) <> 0 Then
                   MsgBox "Close失敗"
                   Exit Sub
               End If
               num = num + 1
               s(num) = v
               t(num) = a
               buf = buf & v & vbCr
           End If
        Next b
    Next a
    
    If num = 0 Then
        MsgBox "みずなら配列が見つかりませんでした"
    Else
        MsgBox buf & vbCr & "にみずなら配列を見つけました。"
    End If
    
    For i = 1 To num
       If MsgBox(s(i) & vbCrLf & vbCrLf & "のみずなら配列を削除しますか？" & vbCrLf & vbCrLf & _
                        "(みずなら配列を選択している場合は削除しないでください)", vbYesNo) = vbYes Then
           If t(i) = 2000 Then
               If RegOpenKeyExA(HKEY_CURRENT_USER, s(i), 0, KEY_ALL_ACCESS, h) <> 0 Then
                    MsgBox "Open失敗(1)"
                    Exit Sub
               End If
               If RegDeleteValueA(h, TSUKI_NAME) <> 0 Then
                    MsgBox "DeleteValue失敗"
                    If RegCloseKey(h) <> 0 Then
                        MsgBox "Close失敗"
                    End If
                    Exit Sub
               End If
               If RegCloseKey(h) <> 0 Then
                   MsgBox "Close失敗"
                   Exit Sub
               End If
               MsgBox "成功"
           
           Else
               If RegOpenKeyExA(HKEY_CURRENT_USER, s(i), 0, KEY_ALL_ACCESS, h) <> 0 Then
                    MsgBox "Open失敗(1)"
                    Exit Sub
               End If
               If RegDeleteValueA(h, "table") <> 0 Then
                    MsgBox "DeleteValue失敗"
                    If RegCloseKey(h) <> 0 Then
                        MsgBox "Close失敗"
                    End If
                    Exit Sub
               End If
               If RegCloseKey(h) <> 0 Then
                   MsgBox "Close失敗"
                   Exit Sub
               End If
               v = s(i)
               a = 0
               b = 1
               Do While b <= Len(v)
                   If Mid(v, b, 1) = "\" Then a = b
                   b = b + 1
               Loop
               v = Left(v, a - 1)
               If RegOpenKeyExA(HKEY_CURRENT_USER, v, 0, KEY_ALL_ACCESS, h) <> 0 Then
                    MsgBox "Open失敗(2)"
                    Exit Sub
               End If
               If RegDeleteKeyA(h, TSUKI_NAME) <> 0 Then
                    MsgBox "DeleteKey失敗"
                    If RegCloseKey(h) <> 0 Then
                        MsgBox "Close失敗"
                    End If
                    Exit Sub
               End If
               If RegCloseKey(h) <> 0 Then
                   MsgBox "Close失敗"
                   Exit Sub
               End If
               MsgBox "成功"
          End If
       End If
    Next i
End Sub

Public Sub ExeTsuki()
    Call InitTsuki
    Call MakeData(mizu, False, True)
    If MsgBox("配列を設定しますか？" & vbCrLf & vbCrLf & "(IME97,IME98 をローマ字に戻すときも「はい」を選びます)", vbYesNo) = vbYes Then
        Call SetTsuki
    ElseIf MsgBox("配列を削除しますか？" & vbCrLf & vbCrLf & "(通常、削除しなくても問題ありません)", vbYesNo) = vbYes Then
        Call DelTsuki
    End If
End Sub