ExcelVBA ～ SoftBankの「シンプルスマホ（おじいちゃん携帯）＝アンドロイド」に、CSVに書き出された電話帳データを一括登録するための、そのデータ作成（vCard、VCF作成）をする方法。（準備さえできれば、実際の一括登録は５００件が１０秒以内に終わります。） | 無駄なお金と時間がない方・零細企業様・独立したい方・個人事業主の方・営業さん・経理さん・学生さん・就活生さん・小学生のお子様、中高生の子たちのための、　　　　「小さな会社の兼任なんちゃって社内SE・パソコン管理術・の基礎知識」

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、のファイル形式に変換して、
　それをクリップボードに送ります。画面上の変化は特にはありません。）

'
'
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
'
'

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のほうが確実なのでこちらでやりました。

'
'
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

'
'

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

投稿タグ: ExcelVBA, スマホトラブル, トラブル解決, パソコンでの自動化, マクロ, 独学, 自動化

MENU

関連記事

最近の投稿

カテゴリー

MENU

関連記事

最近の投稿

カテゴリー

タグ