Excel

vCard(.vcf)ファイルをPanasonicの電話帳形式に変換するExcel-VBA

2021年6月15日

購入した電話機はKX-PD915DLです。スマートフォン連携機能付きのFax電話機（HPはこちら）

ダウンロード

とりあえず、急ごしらえで作ったExcelファイルです。

Panasonicの全ての電話機に対応しているかどうかはわかりません
全部で150件という制約を考慮していません。
変換したデータが元データを合っているかを必ずご確認の上、電話機にてインポートさせてください

最終的にShift-JISコードにて保存されなければなりませんので、Shift-JISコードにない文字、例えば簡体字の人名などは???になってしまいます。

1人に対して電話番号は最大10件にしました。

ダウンロードファイルはこちら（スマホ連絡先_to_Panasonic電話帳_Ver0.4.zip）
DOWNLOAD　​

vCard(.vcf)ファイルをPanasonicの電話帳形式に変換するExcel-VBA

拡張子.xlsはOffice97～2003用
拡張子.xlsmはOffice2007以降用

使い方

Andoroidの連絡先をエクスポートするのに使用したアプリ

Google Play で手に入れよう

vCardファイルの例：

BEGIN:VCARD
VERSION:3.0
PRODID:ez-vcard 0.10.5
N:山田;太郎
FN:山田 太郎
X-PHONETIC-FIRST-NAME:たろう
X-PHONETIC-LAST-NAME:やまだ
TEL;TYPE=自宅:03-1234-5678
TEL;TYPE=携帯:090-1234-5678
EMAIL;TYPE=HOME:[email protected]
END:VCARD

.TXTファイルはSDカードのドライブの「\PRIVATE\MEIGROUP\PCC\PCC_DAT\ADDRESS」に置くと良いかもしれません。

参考：Panasonic電話帳編集ソフト（Intenet Explorerでないと開きません💢）

Web版Google連絡先

ChromeにてGoogleの連絡先を表示させて、エクスポートをさせたvCardファイルにも対応しました。

Excelファイルの実行

ダウンロードしたファイルを解凍しましたら、コンテンツの警告メッセージが表示されますので、有効化してください。

メニューバーの「アドイン」にメニューを作ってあります。

シートの初期化　⇨　シート上の個人情報をクリアします
.vcfファイルの読み込み　⇨　.vcfファイル（UTF-8）を読み込んでシート”vCard”に書き込みます
Panasonic電話帳形式の変換　⇨　Panasonicの電話帳形式に変換します（シート”Pana電話帳”に記録）
漢字の名前にカナを振る　⇨　読み仮名（ひらがな）がある場合は変換、読み仮名がない場合は読み仮名を付けます
.TXTファイルへ書き込み　⇨　指定のフォルダに0000009.TXTファイル（Shift-JIS）を作ります

上記を順番に実行していきます。

.vcfファイルの読み込みから、.TXTファイル書き出しまでを一気に全部行う「全実行」も用意しました。

Panasonic電話帳の列について

2列目は名前・名称、3列目は読み仮名、4列目は電話番号。

1列目はグループ番号（0～9）です。
1:家族・親戚、2:父の知人、3:母の知人・・・
または
1:自宅、2:携帯電話、3:FAX、4:会社・施設・・・
などとするのもあるかもしれません。

Excelシートでは5列目にチェックボックスを付加しています。チェックを入れたデータは.TXTファイルに書き出しません。
電話番号が空欄のデータも.TXTファイルに書き出しません。

電話機の表示

せっかく電話帳を移したのに、電話機本体で確認するのにも戸惑いました。
漢字の名前だけで番号が表示されないのが、デフォルトのようです。
本体の設定にて文字サイズを大⇨ふつう以下に下げる、か、漢字の名前が表示されている状態で「機能」ボタンを押すと番号表示されます。

電話帳でなんとかするのでしたら、名前に工夫する方法も考えられます。
家）山田太郎
F）山田太郎
勤）山田太郎
携）山田太郎
など。

願わくば

vCardからTXTまでをパソコンなしでAndroidスマートフォンのみで行えるアプリを誰か作ってくれないでしょうか？

ExcelのVBAでなくとも、さくらエディタや秀丸エディタのマクロでも作れるかな、と思います。

おまけのVBAコード

アチラコチラからソースをコピペしましたので、変数名など一貫性がありません。
一箇所だけ「On Error Resume Next」があるのみで、エラー処理はほぼありません。

ポイント

文字コード

拡張子.vcfのファイルはUTF-8というエンコードで書かれています。
このファイルをUTF-8で読み込み、Shift-JISのエンコードで.TXTファイルを書き出しています。
Android標準の連絡先アプリ（Google Contact）を使いますと、⇧ここで文字化けしました。どうしても名前の一部（なぜ一部なのか不明）が文字化けします。
Panasonicのサポートによると読み仮名（半角カナ）がないデータはだめなようです。

行の終わり

Easy Backupアプリの行の終わりはLFでした。GoogleのWeb版連絡先ではCR+LFでした。
従って.vcfファイルを読む際には共通するLFで区切りました。
そのままですと、GoogleのWeb版では.TXTファイルを書き出す時に不具合が生じますので、CRも除去しておきます。

Panasonic電話帳形式について

CSVファイルのようなカンマ区切りではありません。Tab区切りです。VBAではvbTabと書きます。

ふりがな変換について

ほとんどのサイトにて

~PHONETIC(A1)

のように書かれていて、これでは貼り付けた漢字の名前から半角カナのふりがなを付けられません。

Application.GetPhonetic(文字列)

とすることで初めてふりがなを付けられます。また、ひらがなから半角カナに直接変換ができず、全角カナを経由しました。

TEL;TYPEについて

頭が痛かったのが、「TEL;TYPE=」でした。
TEL;TYPE=自宅だったり、TEL;TYPE=HOMEだったり。

自宅、携帯、仕事、FAX（自宅）、FAX（勤務先）、その他・・・と、他にもあるかもしれません。

電話番号の列

電話番号が書かれるD列は「文字列」でないといけません。
初期状態は「標準」となっていて、そのセルに電話番号を書くと先頭の0が消えます。

.TXTのファイル名

下1桁が0～9になるようにしてください。それ以外は0で。

This WorkBook（メニューバーの設置）

'メニューバー設置
Private Sub Workbook_Open()
    Dim bar As CommandBar
    Dim menu As CommandBarControl
    Dim btn As CommandBarButton
    
    'Excelのメニューバーを指定
    Set bar = Application.CommandBars("Worksheet Menu Bar")

    'すでにコマンドバーにメニューがある場合は削除
    For Each menu In bar.Controls
        menu.Delete
    Next menu

    'コマンドバーにメニューを追加
    Set btn = bar.Controls.Add(Type:=msoControlButton)
    With btn
        .Style = msoButtonCaption
        .Caption = "シートのクリア"
        .OnAction = "init"
    End With
    
    Set btn = bar.Controls.Add(Type:=msoControlButton)
    With btn
        .Style = msoButtonIconAndCaption
        .FaceId = 23
        .Caption = ".vcfファイルの読み込み"
        .OnAction = "Read_vcf"
    End With
    
    Set btn = bar.Controls.Add(Type:=msoControlButton)
    With btn
        .Style = msoButtonIconAndCaption
        .FaceId = 37
        .Caption = "Panasonic電話帳形式の変換"
        .OnAction = "exchange_to_csv"
    End With
    
    Set btn = bar.Controls.Add(Type:=msoControlButton)
    With btn
        .Style = msoButtonIconAndCaption
        .FaceId = 173
        .Caption = "漢字の名前にカナを振る"
        .OnAction = "Get_kana"
    End With
    
    Set btn = bar.Controls.Add(Type:=msoControlButton)
    With btn
        .Style = msoButtonIconAndCaption
        .FaceId = 3
        .Caption = ".TXTファイルへ書き込み"
        .OnAction = "Write_TXT"
    End With

    Set btn = bar.Controls.Add(Type:=msoControlButton)
    With btn
        .Style = msoButtonCaption
        .Caption = "全実行"
        .OnAction = "Excecute_All"
    End With

End Sub

'Excelを閉じる前にメニューバーをクリアする
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Dim menu As CommandBarControl
    Dim bar As CommandBar
    Set bar = Application.CommandBars("Worksheet Menu Bar")
    For Each menu In bar.Controls
        menu.Delete
    Next menu
End Sub

Module1（メインの処理）

Option Explicit
Private Const g_cnsTitle As String = "VCARDファイル読み込み"
Private Const g_cnsFilter As String = "VCARDファイル (*.vcf),*.vcf,全てのファイル (*.*),*.*"

'******************************************************************
'シートの初期化
'******************************************************************
Sub init()
    Worksheets("Pana電話帳").Cells.Clear
    Worksheets("vCard").Cells.Clear
    Worksheets("Pana電話帳").Columns("D").NumberFormatLocal = "@" '列Ｄ（電話番号）全体を文字列に
    
    'チェックボックスを消す
    Dim shp As Shape
    For Each shp In Worksheets("Pana電話帳").Shapes
        If shp.Type = msoFormControl Then shp.Delete
    Next shp
    
    With Worksheets("Pana電話帳")
        .Activate
        .Cells(1, "A") = "char=01"        '？
        .Cells(2, "A") = "version=001"    '？
        .Cells(3, "A") = "model=w_GBC4YB" '機種名？
        .Cells(4, "A") = "title=test"     '自由に変更してください
        .Cells(6, "A") = "1002"           'グループ（0～9）を指定する
        .Cells(6, "B") = "1000"           '名前（漢字）
        .Cells(6, "C") = "1001"           'ふりがな（半角カナ）
        .Cells(6, "D") = "2000"           '電話番号
    End With
End Sub

'******************************************************************
'vCard(.vcf)ファイルを読み込む
'******************************************************************
Sub Read_vcf()
    Dim objAdost As ADODB.Stream                                    ' 入力ファイル
    Dim lngRow As Long                                              ' 収容するセルの行
    Dim lngRec As Long                                              ' レコード件数カウンタ
    Dim strFileName As String                                       ' OPENするファイル名(フルパス)
    Dim vntFileName As Variant                                      ' ファイル名受取用
    
    Worksheets("vCard").Activate
    
    vntFileName = Application.GetOpenFilename(FileFilter:=g_cnsFilter, Title:=g_cnsTitle)
    If VarType(vntFileName) = vbBoolean Then Exit Sub 'キャンセル処理
    strFileName = vntFileName
    
    Set objAdost = New ADODB.Stream
    ' ADODB.Stream処理
    With objAdost
        .Charset = "UTF-8"
        .LineSeparator = 10 '改行LF（10）
        .Open
        .LoadFromFile strFileName
        ' ファイルのEOF(End of File)まで繰り返す
        Do Until .EOS
            lngRow = lngRow + 1
            Worksheets("vCard").Cells(lngRow, "A") = Replace(.ReadText(adReadLine), vbCr, "") 'CR(キャリッジリターンがある場合は除去)
        Loop
        .Close
    End With
End Sub

'******************************************************************
'Panasonic電話帳形式に変換する
'******************************************************************
Sub exchange_to_csv()
    On Error Resume Next    'JPEGなどの行はエラーになるため
    
    Dim i As Long
    Dim j As Long
    Dim lngRow As Long
    
    Dim strTemp As String
    Dim strTemp1 As String
    Dim strTemp2 As String
    Dim strName As String   '名前
    Dim strTel(10) As String '電話番号
    Dim strFirstName As String
    Dim strLastName As String
    Dim intTelLoop As Integer
    
    With Worksheets("Pana電話帳")
        .Activate
    
        lngRow = 7 '開始行
        strTemp = ""
        strTemp1 = ""
        strTemp2 = ""
        strName = ""
        strFirstName = ""
        strLastName = ""
        For intTelLoop = 0 To 9
            strTel(intTelLoop) = ""
        Next
        
        For i = 1 To Worksheets("vCard").Range("A1").End(xlDown).Row '最大行まで
            
            strTemp = Worksheets("vCard").Cells(i, "A")
            strTemp1 = Mid(strTemp, InStr(strTemp, ":") + 1)    '":"以降の文字列
            strTemp2 = Mid(strTemp, 1, InStr(strTemp, ":") - 1) '":"以前の文字列
    
            Select Case strTemp2 '":"までの文字列で場合分け
                Case "FN"
                    strName = strTemp1
                Case "X-PHONETIC-FIRST-NAME"
                    strFirstName = strTemp1
                Case "X-PHONETIC-LAST-NAME"
                    strLastName = strTemp1
                Case "TEL;TYPE=自宅", "TEL;TYPE=HOME", "TEL;TYPE=携帯", "TEL;TYPE=CELL", "TEL;TYPE=その他", "TEL;TYPE=会社", "TEL;TYPE=FAX（勤務先）", "TEL;TYPE=FAX（自宅）"
                    strTel(intTelLoop) = strTemp1
                    strTel(intTelLoop) = numExtract(strTel(intTelLoop))      '数字以外は除去
                    intTelLoop = intTelLoop + 1
                Case "END"
                    If strTel(intTelLoop) <> "" Then '電話データが1件もない場合はスキップ
                        For j = 0 To intTelLoop
                            .Cells(lngRow, "A") = "1"
                            .Cells(lngRow, "B") = strName
                            .Cells(lngRow, "C") = strLastName & strFirstName
                            .Cells(lngRow, "D") = strTel(intTelLoop)
                            Call Create_Checkbox("E", lngRow)
                            lngRow = lngRow + 1
                        Next
                        strName = ""
                        strLastName = ""
                        strFirstName = ""
                        For intTelLoop = 0 To 9
                            strTel(intTelLoop) = ""
                        Next
                    End If
                Case Else '上記以外は無視
            End Select
            intTelLoop = 0
        Next
    End With
End Sub

'******************************************************************
'読み仮名を半角カナに変換する
'******************************************************************
Sub Get_kana()
    '文字データ取得
    Dim Column As Long '列
    Dim lngRow As Long '行
    Dim itm As String '漢字の名前
    Dim tempValue As String
    
    With Worksheets("Pana電話帳")
        .Activate
        lngRow = 7
        
        Do While .Cells(lngRow, "B") <> ""
            itm = .Cells(lngRow, "B")
            tempValue = Application.GetPhonetic(itm)
            'セルが空欄の場合にのみ読み仮名を半角カナ(vbNarrow)に変換して出力
            If .Cells(lngRow, "C") = "" Then
                .Cells(lngRow, "C") = StrConv(tempValue, vbNarrow)
            Else
                .Cells(lngRow, "C") = StrConv(.Cells(lngRow, "C"), vbKatakana) '一旦全角カナに変換
                .Cells(lngRow, "C") = StrConv(.Cells(lngRow, "C"), vbNarrow)    '半角カナに変換
            End If
            lngRow = lngRow + 1
        Loop
    End With
End Sub

'******************************************************************
'.TXTファイルとして書き出す
'******************************************************************
Sub Write_TXT()
    Dim i As Long
    Dim strFileName As String
    
    strFileName = "00000009.TXT"    'Panasonic電話帳フォーマットの保存ファイル名の初期値
    
    'ファイルパスを指定
    Dim FileName As Variant
    FileName = Application.GetSaveAsFilename(InitialFileName:=strFileName, FileFilter:="TXTファイル,*.txt")
    If FileName = False Then
        Exit Sub
    End If
    
    '同名ファイルがあった場合の上書き確認
    If Dir(FileName) <> "" Then
        If MsgBox("ファイルを上書き保存しますか？", vbYesNo) = vbNo Then
            Exit Sub
        End If
    End If
    
    With Worksheets("Pana電話帳")

        'テキストファイルを開いて出力
        Open FileName For Output As #1
        
        '出力したい分ループ
        For i = 1 To 5
            Print #1, .Cells(i, "A")
        Next i
        i = 6
        If .Cells(i, "D") <> "" Then Print #1, .Cells(i, "A") & vbTab & .Cells(i, "B") & vbTab & .Cells(i, "C") & vbTab & .Cells(i, "D")
        For i = 7 To .Range("A7").End(xlDown).Row
            If .Cells(i, "D") <> "" And .Cells(i, "F") = False Then Print #1, .Cells(i, "A") & vbTab & .Cells(i, "B") & vbTab & .Cells(i, "C") & vbTab & .Cells(i, "D") & ":0:0"
        Next
        Close #1
    End With
End Sub

'******************************************************************
'*文字列から数字のみ抽出
'******************************************************************
Function numExtract(StringValue As String) As String
 
  Dim i As Integer
  Dim numText As String
 
  For i = 1 To Len(StringValue)
      numText = Mid(StringValue, i, 1)
    'numText[0-9]に該当する場合 変数numExtractに格納していく
      If numText Like "[0-9]" Then: numExtract = numExtract & numText
  Next i
 
End Function

'******************************************************************
'読み込みから書き出しまで全実行
'******************************************************************
Sub Excecute_All()
    Call init
    Call Read_vcf
    Call exchange_to_csv
    Call Get_kana
    Call Write_TXT
End Sub

'******************************************************************
'チェックボックス作成
'******************************************************************
Sub Create_Checkbox(strCell As String, i As Long)

    Dim CellW As Long
    Dim CellH As Long

    
    Worksheets("Pana電話帳").Range(strCell & CStr(i)).Select
    CellW = ActiveCell.Width
    CellH = ActiveCell.Height

    Worksheets("Pana電話帳").CheckBoxes.Add(0, 0, CellH, CellH).Select
    With Selection
        .Caption = ""
        .value = xlOff
        .LinkedCell = CStr("F") & i
        .Display3DShading = False
        .Top = ActiveCell.Top
        .Left = ActiveCell.Left + (CellW - CellH) / 2
    End With
End Sub

-Excel
-, , , , ,