ExcelVBA ～ SoftBankの「シンプルスマホ（おじいちゃん携帯＝アンドロイド）」に、CSVに書き出された電話帳データを一括登録するための、そのデータ作成（vCard、VCF作成）をする方法。（準備さえできれば、実際の一括登録は５００件が１０秒以内に終わります。）
サンプルファイルのダウンロード
※ダウンロード要件？が厳しいブラウザの場合は、右クリックして
「名前を付けてリンク先を保存」といった旨のメニューで
ダウンロードしてください。
FireFoxは普通にダウンロードできるみたいです。
●操作方法
おおまかな手順は以下です。（いつかもう少し詳しく書きます）
(01)「UTF-8N」の文字コードの、空のテキストファイルを作成。
（文字コードが超重要）
（Terapadの「ファイル→文字/改行コード指定保存」などでやれます。）
メモ帳なら「BOMなし」で保存すればいいのかも？ただし未確認です。
参考→文字コードはUTF-8？ UTF-8N？）
(02)電話帳のCSVファイルを用意して開きます。
(03)サンプルファイルをダウンロード・解凍して、開きます。
(04)テストするのでなければ、「Sheet1」にサンプルデータが10件ほど
入っているので、それを消します。
（黄色く色付けしてある部分は、のちほどそこに
フラグを入力するので暫定で色つけしてあります。
10件以上処理するなら、色付け部分の下の行にも
のちほど、フラグを入力します。）
※逆に、サンプルデータでテストするのであれば、
(07)へ飛んで、それ以降をおこなってください。
(05)「Sheet1」の必要な列に、CSVからデータをコピペ。
（その際、行の整合性を崩さないように注意）
また、この段階で「メモ（Note）」などのセルの値に、
普通に改行が入ってしまっていると、
スマホ側では一番上の行の文言しか読み込まれず、
２行目以降は切り捨てられてしまうので、
この段階では、「メモ（Note）」などの値は、
1行につなげ直しておいてください。
(06)一応「連番」の列をオートフィルなどで最後まで埋めます。
（何らかの並べ替えをしたときに原状に戻せるように）
(07)対象のデータの行の「データ化対象フラグ01」の列に１を入力。
（全件でいいなら、全部の行に「１」を入れます）
(08)Alt＋F11でVBEを開きます。
(09)出てきた画面の左側に、「vcf用_データ作成」というモジュールの名前があるので
それをダブルクリック。
(10)「vcf用_データ作成」モジュールの中身が右側に出てきて、
「VcfFileDataMake01()」が見える状態になります。
(11)「Dim l_Flg01 As Long」と書いてあるへんをいったんクリックして、
カーソルが点滅するのを確認します。
(12)その状態のまま、F5キーを押します。 「VcfFileDataMake01() が実行されます。
（選択したデータだけが全部、クリップボードに送られます。
画面としては特に何の変化も起こりません。）
(13)テキストファイルに、Ctrl＋Vでクリップボードの電話帳データを貼り付け。
(14)上書きしてファイルを閉じたのち、拡張子を「.txt」から「.vcf」に変更。
(15)シンプルスマホに添付ファイルとして送信。
(16)シンプルスマホ側でメールアプリなどで点ファイルを開く。
(17)選択登録か全件登録かを聞いてくるので、「全件登録」をします。
これで終わりです。
いちおう、空白のセルの部分も、vCard形式で、「英語の項目名だけ」が書き出されます。
が、そのような項目は、シンプルスマホ側では無視されて、「無かったもの」として扱われ、データのある項目だけがスマホに吸い込まれ、残りますので、心配いりません。
あと、「メモ（Note）」などで、改行を入れてスマホ側に表示したい場合は、
「Note」と「:」のあいだに「;ENCODING=QUOTED-PRINTABLE」を挟んで、
「文言=0D=0A文言=0D=0A文言=0D=0A」とやると
おじいちゃん携帯側で、改行された状態で表示されます。
例
↓
「Note」と「:」のあいだに「;ENCODING=QUOTED-PRINTABLE」を挟んで、
NOTE;ENCODING=QUOTED-PRINTABLE:社長=0D=0A会長=0D=0A部長=0D=0Aああああ
とやると、スマホ側では
社長
会長
部長
ああああ
と表示されます。
サンプルファイルでは、そうなっていませんので、
そうしたかったらそうしてください。
もちろん、吸い込んでから、必要な連絡先のものだけ、
普通に手動で改行を入れてもOKです。
なお、CSVの段階で「メモ（Note）」などに普通に改行が入ってしまっていると、
一番上の行の文言しか読み込まれず、２行目以降は切り捨てられてしまうので、
CSVの段階では、1行につなげ直しておいてください。
（上記の(05)を参照。）
※ご注意
今回、各種の「区分」は機能させていません。
一括で吸い込んだあと、気になるようなら気になるモノだけ手作業で変えてください。
電話やメールの「携帯」「勤務先」「自宅」などの区分も正常に吸い込みたいなら、
ご自分でそのような分岐処理を新たに書き加えてください。
参考URL
↓
Android(2.3.4)の連絡先エクスポートで出力されるvCard形式について
●vCard、VCF、用の電話帳データを生成して、クリップボードに送るプログラム
（CSVの電話帳データを、vCard、VCF、のファイル形式に変換して、
それをクリップボードに送ります。画面上の変化は特にはありません。）
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 |
' ' Option Explicit Sub VcfFileDataMake01() Dim l_Flg01 As Long Dim l_LastRow01 As Long Dim s_SrcWSNm01 As String Dim s_DistWSNm01 As String Dim l_DistLastRow01 As Long Dim l_DistNewRow01 As Long Dim o_SrcWS04 As Worksheet Dim o_DistWS04 As Worksheet Dim l_LoopCnt01 As Long Dim s_OneData01 As String Dim s_ALLData01 As String Let s_SrcWSNm01 = "Sheet1" Let s_DistWSNm01 = "Sheet4" Set o_SrcWS04 = ThisWorkbook.Worksheets.Item(s_SrcWSNm01) ' Set o_DistWS04 = ThisWorkbook.Worksheets.Item(s_DistWSNm01) Let l_LastRow01 = o_SrcWS04.Cells(o_SrcWS04.Cells(Rows.Count, 1).Row, 1).End(xlUp).Row Let s_OneData01 = "" Let s_ALLData01 = "" For l_LoopCnt01 = 2 To l_LastRow01 If o_SrcWS04.Range("B" & l_LoopCnt01) = 1 Then Let s_OneData01 = VCardDataMake01(s_SrcWSNm01, l_LoopCnt01) ' Debug.Print s_OneData01 ' Let l_DistLastRow01 = o_DistWS04.Cells(o_DistWS04.Cells(Rows.Count, 1).Row, 1).End(xlUp).Row ' Let l_DistNewRow01 = l_DistLastRow01 + 1 ' Let o_DistWS04.Range("A" & l_DistNewRow01).Value = s_OneData01 Let s_ALLData01 = s_ALLData01 & s_OneData01 & vbCrLf ' Else End If Next l_LoopCnt01 Call SetClipboard(s_ALLData01) '↑クリップボードにデータを送る End Sub Function VCardDataMake01(s_SrcWSNm01 As String, l_RowNum01 As Long) As String Dim s_Sei01, s_Namae01 As String Dim s_FrgnaSei01, s_FrgnaNamae01 As String Dim s_KaisyameiEtc01 As String Dim s_Yakusyoku01 As String Dim s_KbnTel01, s_TelNum01 As String Dim s_KbnTel02, s_TelNum02 As String Dim s_KbnTel03, s_TelNum03 As String Dim s_KbnMail01, s_MailAdr01 As String Dim s_KbnMail02, s_MailAdr02 As String Dim s_KbnMail03, s_MailAdr03 As String Dim s_KbnMail04, s_MailAdr04 As String Dim s_Note01 As String Dim s_AdrKubun01 As String Dim s_TymeBnti01, s_TyuSonAza01, s_Ken01, s_SiKu01 As String Dim s_AdrKubun02 As String Dim s_TymeBnti02, s_TyuSonAza02, s_Ken02, s_SiKu02 As String Dim o_SrcWS01 As Worksheet Dim o_DistWS01 As Worksheet Set o_SrcWS01 = Application.ThisWorkbook.Worksheets.Item(s_SrcWSNm01) Let s_Sei01 = "C" Let s_Namae01 = "D" Let s_FrgnaSei01 = "E" Let s_FrgnaNamae01 = "F" Let s_KaisyameiEtc01 = "G" Let s_Yakusyoku01 = "H" Let s_KbnTel01 = "I" Let s_TelNum01 = "J" Let s_KbnTel02 = "K" Let s_TelNum02 = "L" Let s_KbnTel03 = "M" Let s_TelNum03 = "N" Let s_KbnMail01 = "O" Let s_MailAdr01 = "P" Let s_KbnMail02 = "Q" Let s_MailAdr02 = "R" Let s_KbnMail03 = "S" Let s_MailAdr03 = "T" Let s_KbnMail04 = "U" Let s_MailAdr04 = "V" Let s_Note01 = "W" Let s_AdrKubun01 = "X" Let s_TymeBnti01 = "Y" Let s_TyuSonAza01 = "Z" Let s_Ken01 = "AA" Let s_SiKu01 = "AB" Let s_AdrKubun02 = "AC" Let s_TymeBnti02 = "AD" Let s_TyuSonAza02 = "AE" Let s_Ken02 = "AF" Let s_SiKu02 = "AG" Dim l_CrntRow As Long ' Let l_CrntRow = 2 Let l_CrntRow = l_RowNum01 Dim vCrdData01 As String Let vCrdData01 = "" Let vCrdData01 = "BEGIN:VCARD" & vbCrLf Let vCrdData01 = vCrdData01 & "VERSION:2.1" & vbCrLf Let vCrdData01 = vCrdData01 & "N:" & o_SrcWS01.Range(s_Sei01 & l_CrntRow) & ";" & o_SrcWS01.Range(s_Namae01 & l_CrntRow) & vbCrLf Let vCrdData01 = vCrdData01 & "FN:" & o_SrcWS01.Range(s_Sei01 & l_CrntRow) & " " & o_SrcWS01.Range(s_Namae01 & l_CrntRow) & vbCrLf Let vCrdData01 = vCrdData01 & "SOUND;X-IRMC-N:" & o_SrcWS01.Range(s_FrgnaSei01 & l_CrntRow) & ";" & o_SrcWS01.Range(s_FrgnaNamae01 & l_CrntRow) & vbCrLf Let vCrdData01 = vCrdData01 & "ORG:" & o_SrcWS01.Range(s_KaisyameiEtc01 & l_CrntRow) & vbCrLf Let vCrdData01 = vCrdData01 & "TITLE:" & o_SrcWS01.Range(s_Yakusyoku01 & l_CrntRow) & vbCrLf Let vCrdData01 = vCrdData01 & "TEL;PREF;CELL:" & o_SrcWS01.Range(s_TelNum01 & l_CrntRow) & vbCrLf Let vCrdData01 = vCrdData01 & "TEL;WORK;VOICE:" & o_SrcWS01.Range(s_TelNum02 & l_CrntRow) & vbCrLf Let vCrdData01 = vCrdData01 & "TEL;HOME;VOICE:" & o_SrcWS01.Range(s_TelNum03 & l_CrntRow) & vbCrLf Let vCrdData01 = vCrdData01 & "EMAIL;PREF;CELL:" & o_SrcWS01.Range(s_MailAdr01 & l_CrntRow) & vbCrLf Let vCrdData01 = vCrdData01 & "EMAIL;PREF;WORK:" & o_SrcWS01.Range(s_MailAdr02 & l_CrntRow) & vbCrLf Let vCrdData01 = vCrdData01 & "EMAIL;PREF;HOME:" & o_SrcWS01.Range(s_MailAdr03 & l_CrntRow) & vbCrLf Let vCrdData01 = vCrdData01 & "EMAIL;PREF;INTERNET:" & o_SrcWS01.Range(s_MailAdr04 & l_CrntRow) & vbCrLf Let vCrdData01 = vCrdData01 & "NOTE;ENCODING=QUOTED-PRINTABLE:" & o_SrcWS01.Range(s_Note01 & l_CrntRow) & vbCrLf '改行を入れたい時は、「;ENCODING=QUOTED-PRINTABLE」を挟んで「文言=0D=0A文言=0D=0A文言=0D=0A」とやると 'おじいちゃん携帯側で、改行された状態で表示されます。 '例 → NOTE;ENCODING=QUOTED-PRINTABLE:社長=0D=0A会長=0D=0A部長=0D=0Aああああ Let vCrdData01 = vCrdData01 & "ADR;WORK:;;;" & _ o_SrcWS01.Range(s_TymeBnti01 & l_CrntRow) & ";" & _ o_SrcWS01.Range(s_TyuSonAza01 & l_CrntRow) & ";" & _ o_SrcWS01.Range(s_Ken01 & l_CrntRow) & ";" & _ o_SrcWS01.Range(s_SiKu01 & l_CrntRow) & vbCrLf Let vCrdData01 = vCrdData01 & "LABEL;WORK;ENCODING=QUOTED-PRINTABLE:" & _ o_SrcWS01.Range(s_TymeBnti01 & l_CrntRow) & "=0D=0A" & _ o_SrcWS01.Range(s_TyuSonAza01 & l_CrntRow) & ";" & _ o_SrcWS01.Range(s_Ken01 & l_CrntRow) & "=0D=0A" & _ o_SrcWS01.Range(s_SiKu01 & l_CrntRow) & vbCrLf Let vCrdData01 = vCrdData01 & "ADR;WORK:;;;" & _ o_SrcWS01.Range(s_TymeBnti02 & l_CrntRow) & ";" & _ o_SrcWS01.Range(s_TyuSonAza02 & l_CrntRow) & ";" & _ o_SrcWS01.Range(s_Ken02 & l_CrntRow) & ";" & _ o_SrcWS01.Range(s_SiKu02 & l_CrntRow) & vbCrLf Let vCrdData01 = vCrdData01 & "LABEL;WORK;ENCODING=QUOTED-PRINTABLE:" & _ o_SrcWS01.Range(s_TymeBnti02 & l_CrntRow) & "=0D=0A" & _ o_SrcWS01.Range(s_TyuSonAza02 & l_CrntRow) & ";" & _ o_SrcWS01.Range(s_Ken02 & l_CrntRow) & "=0D=0A" & _ o_SrcWS01.Range(s_SiKu02 & l_CrntRow) & vbCrLf Let vCrdData01 = vCrdData01 & "REV:20080424T195243Z" & vbCrLf Let vCrdData01 = vCrdData01 & "END:VCARD" ' Debug.Print vCrdData01 Let VCardDataMake01 = vCrdData01 End Function ' ' |
●クリップボードに送受信するためのAPI（64bit、32bit、兼用）
Excelの「DataObject（Microsoft Forms 2.0 Object Library）」を使う方法が、
なぜかダメだった（短い文字列は行けたのですが）、APIのほうが確実なのでこちらでやりました。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 |
' ' Option Explicit #If VBA7 And Win64 Then Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" (ByVal hWnd As LongPtr) As Long Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As LongPtr Private Declare PtrSafe Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As LongPtr) As Long Private Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As LongLong) As LongPtr Private Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr Private Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As LongPtr) As Long Private Declare PtrSafe Function GlobalSize Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongLong Private Declare PtrSafe Sub MoveMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As LongPtr, ByVal Source As LongPtr, ByVal Length As LongLong) #Else Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long Private Declare Function EmptyClipboard Lib "user32.dll" () As Long Private Declare Function CloseClipboard Lib "user32.dll" () As Long Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long Private Declare Function GlobalSize Lib "kernel32.dll" (ByVal hMem As Long) As Long Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long Private Declare Sub MoveMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByVal Destination As Long, ByVal Source As Long, ByVal Length As Long) #End If Public Sub SetClipboard(sUniText As String) #If VBA7 And Win64 Then Dim iStrPtr As LongPtr Dim iLen As LongLong Dim iLock As LongPtr #Else Dim iStrPtr As Long Dim iLen As Long Dim iLock As Long #End If Const GMEM_MOVEABLE As Long = &H2 Const GMEM_ZEROINIT As Long = &H40 Const CF_UNICODETEXT As Long = &HD OpenClipboard 0& EmptyClipboard iLen = LenB(sUniText) iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen + 2&) iLock = GlobalLock(iStrPtr) MoveMemory iLock, StrPtr(sUniText), iLen GlobalUnlock iStrPtr SetClipboardData CF_UNICODETEXT, iStrPtr CloseClipboard End Sub Public Function GetClipboard() As String #If VBA7 And Win64 Then Dim iStrPtr As LongPtr Dim iLen As LongLong Dim iLock As LongPtr #Else Dim iStrPtr As Long Dim iLen As Long Dim iLock As Long #End If Dim sUniText As String Const CF_UNICODETEXT As Long = 13& OpenClipboard 0& If IsClipboardFormatAvailable(CF_UNICODETEXT) Then iStrPtr = GetClipboardData(CF_UNICODETEXT) If iStrPtr Then iLock = GlobalLock(iStrPtr) iLen = GlobalSize(iStrPtr) sUniText = String$(CLng(iLen) \ 2& - 1&, vbNullChar) MoveMemory StrPtr(sUniText), iLock, LenB(sUniText) GlobalUnlock iStrPtr End If GetClipboard = sUniText End If CloseClipboard End Function ' ' |
