人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルでA1に入っている文字列をUTF-8に変換、URLエンコードをして、ファイルに書き出すというマクロ?VBA?はどう書きますか?

また、その中に簡単なコメントも入れてほしいです。

さらに、そのマクロ?VBA?はどこにどうかいてどう実行すればいいのかまで教えてください。

●質問者: iiiiiiiii
●カテゴリ:インターネット ウェブ制作
✍キーワード:A1 URL UTF-8 VBA エクセル
○ 状態 :キャンセル
└ 回答数 : 1/1件

▽最新の回答へ

1 ● SALINGER

まずVBAの説明から。

自分で作ったマクロはVBEの標準モジュールというところに書き込みます。以下を参考にしてみてください。

http://www.officepro.jp/excelvba/ini/index1.html

http://www.officepro.jp/excelvba/ini/index2.html

http://www.officepro.jp/excelvba/ini/index3.html


コードではADODB.Streamを使いUTF-8に変換し、

http://www.geocities.co.jp/SilkRoad/4511/vb/urlenc.htm

のUrlEncode関数を使いURLエンコードをしています。


以下の2つのコードを標準モジュールにコピペして、コードの先頭の方にあるファイルのパスを指定して、

メニューから実行→sub/ユーザーフォームの実行

を選べば、指定した位置にテキストファイルを作成します。


Option Explicit
 
Private Sub Con_Charset()
  '書き出すテキストファイルのパスに書き換えてください。
 Const Filename = "C:\Documents and Settings\hogehoge\デスクトップ\test.txt"
 Dim shiftjObj As Object
 Dim utf8Obj As Object
 Dim str As String
 
  'Shift-JISのADODB.Streamを作成してA1セルを読み込みます
 Set shiftjObj = CreateObject("ADODB.Stream")
 With shiftjObj
 .Type = 2
 .Charset = "shift-jis"
 .Open
 .WriteText() = ActiveSheet.Range("A1")
 .Position = 0
 End With
 
  'Utf-8のADODB.Streamを作成します
 Set utf8Obj = CreateObject("ADODB.Stream")
 With utf8Obj
 .Type = 2
 .Charset = "utf-8"
 .Open
 End With

  'Shift-JISのADODB.StreamをUtf-8のADODB.Streamをコピーします
 shiftjObj.CopyTo utf8Obj
 utf8Obj.Position = 0
 
  'Urlエンコードします
 str = UrlEncode(utf8Obj.ReadText())
 utf8Obj.Position = 0
 utf8Obj.WriteText() = str
 
  'Utf-8のADODB.Streamを保存します(2は上書き)
 utf8Obj.Savetofile Filename, 2
End Sub

以下は、VBの関数ですがそのまま使えそうなのでリンク先と一緒です。

Public Function UrlEncode(ByRef strSource As String) As String

 Dim lngLength As Long  '文字列のサイズ(S-JIS 変換後)を格納する
 Dim bytSource() As Byte  'ANSI/S-JIS に変換した文字列を格納するバイト型配列
 Dim strBuffer As String  'URL エンコードされた文字列を一時格納するバッファ
 Dim bytSingle As Byte  '配列から抜き出した 1 バイトを格納する
 Dim strSingleHex As String  '文字コードを 16 進化した文字列を格納する
 Dim lngReadCount As Long  'bytSource 読み込み位置カウンタ
 Dim lngWriteCount As Long  'strBuffer 書き込み位置カウンタ
 
 lngLength = LenB(StrConv(strSource, vbFromUnicode))  'ANSI/S-JIS 変換後のサイズを求める
 If Not CBool(lngLength) Then Exit Function  '0 バイトの場合関数を抜ける
 ReDim bytSource(lngLength - 1)  'ANSI/S-JIS 変換文字列を格納する領域を確保
 bytSource = StrConv(strSource, vbFromUnicode)  'ANSI/S-JIS に変換し bytSource に格納
 
 strBuffer = String$(lngLength * 3, vbNullChar)  'URL エンコード文字列一時格納バッファを確保
 strSingleHex = "%00"  '16 進化した文字コードを格納するバッファを確保
 lngWriteCount = 1  '書き込みカウンタは 1 から開始
 
 Do  '文字列の終端までループ
 bytSingle = bytSource(lngReadCount)  '配列から 1 バイト抜く(毎回参照するより速い?)
 If ((bytSingle >= &H81) And (bytSingle <= &H9F)) Or _
 ((bytSingle >= &HE0) And (bytSingle <= &HEF)) Then  'Shift-JIS 2 バイト文字と確認された場合
 Mid(strSingleHex, 2, 2) = Hex$(bytSingle)  '文字コードを 16 進数に変換(上位バイト)
 Mid(strBuffer, lngWriteCount, 3) = strSingleHex  'URL エンコードされた文字列をバッファに書き込む
 lngReadCount = lngReadCount + 1  '読み込みカウンタをインクリメント
 lngWriteCount = lngWriteCount + 3  '書き込みカウンタを 3 増やす
 If lngReadCount = lngLength Then Exit Do  '文字列の終端に達した場合、ループを抜ける
 bytSingle = bytSource(lngReadCount)  '配列から 1 バイト抜く
 Mid(strSingleHex, 2, 2) = Hex$(bytSingle)  '文字コードを 16 進数に変換(下位バイト)
 Mid(strBuffer, lngWriteCount, 3) = strSingleHex  'URL エンコードされた文字列をバッファに書き込む
 lngReadCount = lngReadCount + 1  '読み込みカウンタをインクリメント
 lngWriteCount = lngWriteCount + 3  '書き込みカウンタを 3 増やす
 ElseIf bytSingle = &H20 Then  '半角スペース文字(" ")の場合
 Mid(strBuffer, lngWriteCount, 1) = "+"  '"+" を代わりに書き込む
 lngReadCount = lngReadCount + 1  '読み込みカウンタをインクリメント
 lngWriteCount = lngWriteCount + 1  '書き込みカウンタを 1 増やす
 ElseIf ((bytSingle >= &H40) And (bytSingle <= &H5A)) Or _
 ((bytSingle >= &H61) And (bytSingle <= &H7A)) Or _
 ((bytSingle >= &H30) And (bytSingle <= &H39)) Or _
 (bytSingle = &H2A) Or _
 (bytSingle = &H2D) Or _
 (bytSingle = &H2E) Or _
 (bytSingle = &H5F) Then  '無変換文字であった場合
 Mid(strBuffer, lngWriteCount, 1) = Chr$(bytSingle)  '文字コードを文字列に戻して書き込む(^^;
 lngReadCount = lngReadCount + 1  '読み込みカウンタをインクリメント
 lngWriteCount = lngWriteCount + 1  '書き込みカウンタを 1 増やす
 Else  'その他の文字の場合
 If bytSingle <= &HF Then  'Hex$() の結果が 1 文字になる場合
 Mid(strSingleHex, 2, 1) = "0"  '0 を先頭に付加
 Mid(strSingleHex, 3, 1) = Hex$(bytSingle)  '文字コードを 16 進数に変換
 Else  '0 を付加する必要がない場合
 Mid(strSingleHex, 2, 2) = Hex$(bytSingle)  '文字コードを 16 進数に変換
 End If
 Mid(strBuffer, lngWriteCount, 3) = strSingleHex  'URL エンコードされた文字列をバッファに書き込む
 lngReadCount = lngReadCount + 1  '読み込みカウンタをインクリメント
 lngWriteCount = lngWriteCount + 3  '書き込みカウンタを 3 増やす
 End If
 Loop Until lngReadCount = lngLength

 Erase bytSource  'バイト型配列を消去
 
 If lngWriteCount > 1 Then  'バッファに文字列が書き込まれた場合
 UrlEncode = Left$(strBuffer, lngWriteCount - 1)  'バッファの余分な部分を削り、戻り値とする
 End If

End Function
関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ