Excel 平面直角座標XYからgeojsonファイル作成

　Excel表で作成された平面直角座標XYのデータをGoogle Mapに簡単に登録することができるGeojson形式にする機会があり、GeoJson fileを作成するExcel VBAを作成してみました。

【使用方法】
・ここからExcel(Excel2geojson.xlsm)ファイルをダウンロートする。
・直角平面座標→緯度経度変換（xy2geojsonシート）
　－geojsonファイル名を入力
　－直角座標系を選択
　－X、Y列に入力して「変換」ボタンをオンするとgeojsonファイルが作成される。
・緯度経度座標→直角平面変換（latLng2geojsonシート）
　－geojsonファイル名を入力
　－直角座標系を選択
　－緯度、経度列に入力して「変換」ボタンをオンするとgeojsonファイルが作成される。

【geojsonファイル】
・geojsonファイルはExcelがあるフォルダー内に出力される。
・Excel表の先頭行と最終行の座標値が等しい場合はPolygon、等しくない場合はLinestringとなる。
・geojsonファイルはUTF-8文字コード、改行コードはLF、BOM付きで出力される。

平面直角座標XY⇔緯度経度 変換Excelプログラム

　先日「Excelで写真のExif情報を読み取りKLM ファイルを作成し、GoogleEarthに貼付」で作成したExcelから緯度・経度⇔直角平面座標XY変換の部分のみを抜き取り、緯度・経度を直角平面座標に直角平面座標を緯度・経度に変換するExcelを作成してみました。

【使用方法】
・ここからExcel xyLatlngTran.xlsmファイルをダウンロートする。
・平面直角座標→緯度経度変換（xy->latlngシート）
　－直角座標系を選択
　－X、Y列に入力して「変換」ボタンをオンすると、緯度、経度列に出力
・緯度経度座標→直角平面変換（latlng->xyシート）
　－直角座標系を選択
　－緯度、経度列に入力して「変換」ボタンをオンすると、X、Y列に出力

Excelで写真のExif情報を読み取りKMLファイルを作成し、GoogleEarthに貼付

　Google Earthに写真のExif情報を利用して写真を貼付るためのkmlファイルをExcelで作成しててみました。

【処理内容】
・Excelで写真(JPEG)を読み込み
・Exif情報を抽出（抽出方法はこちらを参照）
・写真中心座標をExif GPSで取得
・中心座標(緯度・経度)を直角平面座標(XY)に変更(変更はこちらを参照）
・Exif情報の焦点距離(mm)、高度(m)、方向(度)を取得
・Exif情報に高度・方向が無い場合を想定してマニアル入力も可能とする
・イメージセンサー幅(mm)・高さ(mm)をマニアル入力
・焦点距離(mm)、高度(m),イメージセンサー幅(mm)・高さ(mm)から
　 写真撮影範囲を計算（計算方法はこちらを参照）
・写真左上座標(XY)、右下座標(XY)を計算（計算方法はこちらを参照）
・写真左上座標(XY)、右下座標(XY)を緯度・経度に変換
　（計算方法はこちらを参照）
・写真左上座標、右下座標の緯度・経度をdoc.klmに書き込み

【使用方法】
・ここからklm.xlsmをダウンロードする。
・klm.xlsmを開く
　　－ｲﾒｰｼﾞセンサ（W x H)mmを入力する（必須）
　　－直角平面座標系番号（プルダウン選択）
　　－高度・写真傾きがExifに無い場合、補正が必要な場合は入力する
・「写真貼付ボタン」をオンして貼付る写真を選択する
・Excel表に写真、Exif情報が表示されexcelが置いてあるフォルダーに
　doc.klmファイル、filesフォルダーが作成される
　注）高度、撮影方向がマニアルで入力された場合は赤文字で表示される
・作成されたdoc.klm,filesを圧縮プログラムを使用して圧縮して
　{適当な名前.kmz}で保存する
・作成したkmzファイルのダブルクリックでGoogle Earthを起動する。

注意：
・本プログラムはエラー処理を一切していません！

直角平面座標CSVファイルから緯度経度CSVファイルへの一括変換プログラム(VBS)

　csvで作成された大量の直角座標XYを緯度経度に変換する必要があり、国土地理院の「緯度、経度への換算」サイトの一括変換も考えたたが、geojsonへ変換することもあり,Windowsなら他に何もプログラムがなくても動くようにvbsで自作することにしました。
　自作といっても国土地理院の「緯度、経度への換算」サイトの計算式をVBSで書き直しただけですが。。。

ここで公開していますのでお使いください。
【使用方法】
・XY2LatLng.zipを解凍するとXY2LatLng.txtができる
・XY2LatLng.txtをXY2LatLng.vbsに名前変更
・XY2LatLng.vbsにcsvファイルDrag&Dropするだけ
・変換元csvがあったフォルダーに緯度経度に変換された"元ファイル名_LatLng.csv"
　ファイルが作成されます。

【ソース XYLatLng.vbs】

Option Explicit
Dim args, arg, k, FName

Set args = WScript.Arguments
For Each arg In args
	Call MsgBox(arg & "を処理中")
	Do
		k = InputBox("平面直角座標系:" & vbCr & "系番号入力(1から19)")
	Loop While (k < 1 or k > 19)
	
	genLatLng(arg)
	
	Call MsgBox(FName & "_LatLng.csv" & " 書込み完了")
Next

Sub genLatLng(arg)
	Dim fso, pos, PathName
	Set fso = WScript.CreateObject("Scripting.FileSystemObject")

	Dim inputFile
	Set inputFile = fso.OpenTextFile(arg, 1, False, 0)
	
	' パス、ファイル名取得
	pos = InStrRev(arg,".")
	PathName = Left(arg, pos - 1)
	FName = Mid(arg, InStrRev(arg,"\") + 1, pos - InStrRev(arg,"\") - 1)
	
	' 出力ファイル
	Dim outputFile
	Set outputFile = fso.OpenTextFile(PathName & "_LatLng.csv", 2, True)

	Do Until inputFile.AtEndOfStream
		Dim lineStr,aryStrings
		lineStr = inputFile.ReadLine
		aryStrings = Split(lineStr, ",")
		If aryStrings(0) = "" Then
			Exit Do
		End If

		Dim latLngStr
		latLngStr = xy2LatLng(k, aryStrings(0), aryStrings(1))
		outputFile.WriteLine latLngStr
	Loop
	
	inputFile.Close
	outputFile.Close

End Sub

Function xy2LatLng(k, x, y)
	Dim b0, L0
	Select Case k
		case  1
			b0=33.0
			L0=129.5
		case  2
			b0=33.0
			L0=131.0
		case  3
			b0=36.0
			L0=132.1666666666666
		case  4
			b0=33.0
			L0=133.5
		case  5
			b0=36.0
			L0=134.3333333333333
		case  6
			b0=36.0
			L0=136.0
		case  7
			b0=36.0
			L0=137.1666666666666
		case  8
			b0=36.0
			L0=138.5
		case  9
			b0=36.0
			L0=139.833333333333
		case 10
			b0=40.0
			L0=140.833333333333
		case 11
			b0=44.0
			L0=140.25
		case 12
			b0=44.0
			L0=142.25
		case 13
			b0=44.0
			L0=144.25
		case 14
			b0=26.0
			L0=142.0
		case 15
			b0=26.0
			L0=127.5
		case 16
			b0=26.0
			L0=124.0
		case 17
			b0=26.0
			L0=131.0
		case 18
			b0=20.0
			L0=136.0
		case 19
			b0=26.0
			L0=154.0
	End Select

  Const a  = 6378137.0             ' 長半径
  Const F  = 298.257222101         ' 逆扁平率
  Const m0 = 0.9999                ' 平面直角座標系のX軸上における縮尺係数
	Const Pi = 3.1415926535897932

	' 緯度経度をラジアン変換
	Dim radLat0, radLng0
	radLat0 = deg2rad(b0)            ' 座標原点の緯度
	radLng0 = deg2rad(L0)            ' 座標原点の経度

	Dim n
	n  = 1/(2*F-1)
	
	Dim beta1, beta2, beta3, beta4, beta5
	beta1 = n/2 - 2/3*(n^2.0) + 37/96*(n^3.0) - 1/360*(n^4.0) - 81/512*(n^5.0)
	beta2 = 1/48*(n^2.0) + 1/15*(n^3.0) - 437/1440*(n^4.0) + 46/105*(n^5.0)
	beta3 = 17/480*n^3.0 - 37/840*(n^4.0) - 209/4480*(n^5.0)
	beta4 = 4397/161280*(n^4.0) - 11/504*(n^5.0)
	beta5 = 4583/161280*(n^5.0)

	Dim delta1, delta2, delta3, delta4, delta5, delta6
	delta1 = 2*n - 2/3*(n^2.0) - 2*(n^3.0) + 116/45*(n^4.0) + 26/45*(n^5.0) - 2854/675*(n^6.0)
	delta2 = 7/3*(n^2.0) - 8/5*(n^3.0) - 227/45*(n^4.0) + 2704/315*(n^5.0) + 2323/945*(n^6.0)
	delta3 = 56/15*(n^3.0) - 136/35*(n^4.0) - 1262/105*(n^5.0) + 73814/2835*(n^6.0)
	delta4 = 4279/630*(n^4.0) - 332/35*(n^5.0) - 399572/14175*(n^6.0)
	delta5 = 4174/315*(n^5.0) - 144838/6237*(n^6.0)
	delta6 = 601676/22275*(n^6.0)
	
	Dim A0, A1, A2, A3, A4, A5, A6
	A0 = 1 + n^2.0/4 + (n^4.0)/64
	A1 = -3/2*(n - n^3.0/8 - (n^5.0)/64)
	A2 = 15/16*(n^2.0 - (n^4.0)/4)
	A3 = -35/48*(n^3.0 - 5/16*(n^5.0))
	A4 = 315/512*(n^4.0)
	A5 = -693/1280*(n^5.0)

	Dim Sbar, Abar, xi, eta
	Sbar = (m0*a/(1 + n))*(A0*radLat0 + (A1*Sin(2*1*radLat0) + A2*Sin(2*2*radLat0)) + A3*Sin(2*3*radLat0) + A4*Sin(2*4*radLat0) + A5*Sin(2*5*radLat0))
	Abar = (m0*a/(1 + n))*A0
	xi   = (x + Sbar)/Abar
	eta  = y/Abar
	
	Dim xi_d, eta_d, chi, lat, lng
	xi_d = xi - (beta1*Sin(2*1*xi)*cosh(2*1*eta) + beta2*Sin(2*2*xi)*cosh(2*2*eta) + beta3*Sin(2*3*xi)*cosh(2*3*eta) + beta4*Sin(2*4*xi)*cosh(2*4*eta) + beta5*Sin(2*5*xi)*cosh(2*5*eta))
	eta_d = eta - (beta1*Cos(2*1*xi)*sinh(2*1*eta) + beta2*Cos(2*2*xi)*sinh(2*2*eta) + beta3*Cos(2*3*xi)*sinh(2*3*eta) + beta4*Cos(2*4*xi)*sinh(2*4*eta) + beta5*Cos(2*5*xi)*sinh(2*5*eta))
	chi = asin(Sin(xi_d)/cosh(eta_d))

	lat = chi + (delta1*Sin(2*1*chi) + delta2*sin(2*2*chi) + delta3*Sin(2*3*chi) + delta4*Sin(2*4*chi) + delta5*Sin(2*5*chi) + delta6*Sin(2*6*chi))
	lng = radLng0 + Atn(sinh(eta_d)/Cos(xi_d))
	
	lat = lat * (180/Pi)
	lng = lng * (180/Pi)
	xy2LatLng = lat & "," & lng
End Function

Function deg2rad(x)
	Const Pi = 3.1415926535897932
	deg2rad = (x * Pi)/180
End Function

Function asin(x)
	asin =  Atn(X / Sqr(-X * X + 1))
End Function

Function cosh(x)
	cosh = (Exp(X) + Exp(-X)) / 2
End Function

Function sinh(x)
	sinh = (Exp(X) - Exp(-X)) / 2
End Function

Excel でQRコード作成(Google Chart API)

　Google Chart APIを使用すると簡単にQRコードが簡単に作成できることが「Google Chart APIを使ってQRコードを作る」でわかったので、ここを参照にしてExcel表 に入力された文字列をQRコードに変換するVBAで作成してみた。ここでExcelファイルを公開しています。
試してみてください。

VBAスクリプト概要
URLDownloadToFileを使用してGoogle chart APIで"http：//chart.apis.google.com/chart?chs=150x150&cht=qr&chl=文字列"から取り込んだQRコード画像データをファイルにダウンロード後、Excelセルに貼付しています。

サンプルExcel画像
作成文字列の入力行数は任意です。

VBA ReDimではまる

　”「差し込み印刷」を使わないでWordにCSVデータの差し込み”を作成していた時の話。
　何列あるか分からないCSVデータ１行分のデータを配列に取り込むため、読み込む前にReDimで配列の要素数を再定義するコードを書きました。しかし結果を見ると最後のデータのみが配列に取り込まれており、前のデータは全て空。冷静に考えればReDimの使い方の問題と直ぐに気づくはずであるが。。Preserveキーワードを付けないでReDimで再定義すると、それまで格納されていたデータがクリアされてしまう仕様でした。データが格納された配列にデータ追加したいときReDimを使う場合が多いと思うが。クリアしたい場合キーワードを付けるほうが親切な仕様なのでは。

コード

    Do Until EOF(1)
      ReDim Preserve tmp(i)  ← Preserveが抜けていた。
      Line Input #1, strLine
      tmp(i) = strLine
      i = i + 1
    Loop

　ReDimを使う場合

ビットコイン(bitFlyer)の過去チャートをExcelで取得

　 Excel　VBAの勉強のためJSONデータを取得してみようと思い立ち、何か面白いものはないかと探していました。最近何かと世間をにぎわせているbitCoinの過去チャートがJSONデータで公開さしているサイトがあることをここで見つけました。この記事を参照させてもらいbitFlyerの過去チャートをダウンロードするExcel マクロをVBAで作成してみました。

サンプル画像
ここで公開しています。


コード

Sub get_chart()
  '過去データの取得
  Dim targetURI
  Dim HttpReq
  Dim oXML
  Dim sc, objJSON, rcd
  Dim i As Integer
  
  targetURI = "https://min-api.cryptocompare.com/data/histohour?fsym=BTC&tsym=JPY&limit=2000&e=bitFlyer"
  Set HttpReq = CreateObject("MSXML2.XMLHTTP")
  HttpReq.Open "GET", targetURI, False
  HttpReq.send (Null)
  
  Dim restext As String
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", targetURI, False
    .send
    Set oXML = .responseXML
    restext = .responseText
  End With

  Set sc = CreateObject("ScriptControl")
  sc.Language = "JScript"
  sc.AddCode "function jsonParse(s) { return eval('(' + s + ')'); }"
  Set objJSON = sc.CodeObject.jsonParse(restext)
  
  i = 5 'データ先頭行
  For Each rcd In objJSON.Data
    Cells(i, 1) = (CallByName(rcd, "time", VbGet) + 32400) / 86400 + 25569
    Cells(i, 2) = CallByName(rcd, "open", VbGet)
    Cells(i, 3) = CallByName(rcd, "close", VbGet)
    Cells(i, 4) = rcd.high
    Cells(i, 5) = rcd.low
    Cells(i, 6) = rcd.volumefrom
    Cells(i, 7) = rcd.volumeto
    i = i + 1
  Next
End Sub

Sub get_rate()
  '現在のレート
  Dim targetURI
  Dim HttpReq
  Dim oXML
  Dim sc, objJSON, rcd

  targetURI = "https://api.bitflyer.jp/v1/ticker?product_code=BTC_JPY"
  Set HttpReq = CreateObject("MSXML2.XMLHTTP")
  HttpReq.Open "GET", targetURI, False
  HttpReq.send (Null)

  Dim restext As String
  With CreateObject("MSXML2.XMLHTTP")
    .Open "GET", targetURI, False
    .send
    Set oXML = .responseXML
    restext = .responseText
  End With

  Set sc = CreateObject("ScriptControl")
  sc.Language = "JScript"
  sc.AddCode "function jsonParse(s) { return eval('(' + s + ')'); }"
  Set objJSON = sc.CodeObject.jsonParse(restext)
  
    Cells(3, 4) = objJSON.timestamp
    Cells(3, 7) = objJSON.ltp
    Cells(3, 8) = objJSON.best_bid
    Cells(3, 9) = objJSON.best_ask
End Sub

「差し込み印刷」を使わないでWordにCSVデータの差し込み(差し込み印刷もどき その２)

以前にExcelからWord文書への「差し込み印刷もどき」を作成してみたが、同じように考えている方が多いようで当Blogで一番のアクセスがある記事となっています。
　帳票等で不定行数の表データを差し込みたい場合も多いが、前回の方式では実現できない。そこで不定行数の表データをWord文書に差し込むマクロを作成してみた。Word　VBAに慣れるためExcelからWordを制御するのでは無く、Word VBAでCSVデータと差し込む方式で作成してみた。

概要

• 差し込むCSVデータを作成(data.csv)

• Word文書のCSVデータを差し込む表を作成(csv2word.docm)

• PDF出力

Word VBAコード

Public Sub read_csv()
  Dim Path As String, file As String, buf As String, strLine As String, data_ary() As Variant
  Dim arrLine As Variant, tmp() As String
  Dim max_n As Long, i As Long, j As Long, max_c As Long
  Dim myPath As String
  
  myPath = ActiveDocument.Path
  file = myPath & "\data.csv"

  'CSVデータ読み取り
  i = 0
  Open file For Input As #1 'CSVファイルを開く
    Do Until EOF(1)
      ReDim Preserve tmp(i)
      Line Input #1, strLine
      tmp(i) = strLine
      i = i + 1
    Loop
  Close #1
  
  '2次元配列に格納
  max_n = UBound(tmp)
  max_c = UBound(Split(tmp(0), ","))
  ReDim data_ary(max_n + 1, max_c + 1) As Variant
  For i = 0 To UBound(tmp)
    arrLine = Split(tmp(i), ",")
    For j = 0 To UBound(arrLine) - 1
      data_ary(i, j) = arrLine(j)
    Next j
  Next i
  Close #1
  
  'データ書き込み
  If ActiveDocument.Tables.Count >= 1 Then
    For i = 1 To max_n
      For j = 0 To max_c
        With ActiveDocument.Tables(1).Cell(Row:=i + 2, Column:=j + 1).Range
          .Delete
          .InsertAfter Text:=data_ary(i, j)
        End With
      Next j
      ActiveDocument.Tables(1).Rows.Add
    Next i
  End If
  
  'pdf出力
   ActiveDocument.ExportAsFixedFormat _
     OutputFileName:=myPath & "\" & "出力.pdf", _
     ExportFormat:=wdExportFormatPDF
  
  '終了
  MsgBox "完了しました。"
  Application.Quit SaveChanges:=wdDoNotSaveChanges
End Sub

サンプルの使用方法

• ダウンロード　Wordファイル(csv2word.docm)はこちら、CSVファイル(data.csv)はこちら
• サンプルのWord、CSVファイルは同じフォルダー内に保存
• Word（csv2word.docm）を起動すると、セキュリティの警告がでますがコンテンツの有効化ボタンをクリック。
• 実行ボタンを押すと、CSVデータが差し込まれたPDFファイル"出力.pdf"が作成されます。なおcsv2word.docmは更新されませんので何度でも使用できます。

Excelで郵便番号から住所変換(WEBSERVICE,Addin,WEBAPI)

　Excel表で郵便番号を入力すると自走で住所が入ると便利なことがある。そこでExcel 2013で追加された「WEBSERVICE」関数、zipcode7.xlaアドイン、普通にWebAPIでXMLデータを取得する方法の３種類作成してみた。

「WEBSERVICE」関数を使用する方法
　こちらの「郵便番号検索API」サービスを使用させてもらい、住所のセルに=FILTERXML(WEBSERVICE("http://zip.cgis.biz/xml/zip.php?zn=" & 郵便番号cell),"/ZIP_result/ADDRESS_value/value[@address]/@address")とすれば簡単に実現できる。
　しかし複数行に渡って入力するには上記の式をコピーになければいけなくスマートではないのでVBAで制御することにした。
サンプル
実際のサンプルはここ
コード

'-------------------------------------------------------------------------------------------
'    Sheet1 マクロ
'　セルの値が変化したときA列の郵便番号をB列の住所に変換
'------------------------------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim i As Integer
  Dim zipcode, cellad As String
  
  For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
    If Target.Address() = "$A$" + CStr(i) Then
      cellad = "$A$" + CStr(i)
      Cells(i, 2) = zip2address(Range(cellad))
    End If
  Next
End Sub
’------------------------------------------------------------------------------------------------
'   Module1 マクロ
'     FilterXML, WebServiceをWorksheetFunctionを使いvbaで使用
’------------------------------------------------------------------------------------------------
Function zip2address(ByVal 郵便番号 As String)
  Dim httpAdd, State, city, Address As String
  
  郵便番号 = Replace(郵便番号, "-", "")
  httpAdd = "http://zip.cgis.biz/xml/zip.php?zn="
  If 郵便番号 <> "" Then
    State = WorksheetFunction.FilterXML(WorksheetFunction.WebService(httpAdd + 郵便番号), "/ZIP_result/ADDRESS_value/value[@state]/@state")
    city = WorksheetFunction.FilterXML(WorksheetFunction.WebService(httpAdd + 郵便番号), "/ZIP_result/ADDRESS_value/value[@city]/@city")
    Address = WorksheetFunction.FilterXML(WorksheetFunction.WebService(httpAdd + 郵便番号), "/ZIP_result/ADDRESS_value/value[@address]/@address")
  
    zip2address = State + city + Address
 Else
    zip2address = ""
 End If
End Function

Microsoftのzipcode7.xlaアドイン
　インターネットに接続しなくても使えるように、こちらの郵便番号変換アドイン"zipcode7.xla"を使用してみた。本アドインを組み込んで使用する方法は組み込むにも手間がかかること、３ステップもの[郵便番号変換ウィザード ステップ］に入力が必要なのでVBAでzipcode7.xlaのコアな機能のみを使ってみることにした。
　しかしaddin側のfunctionを使用するには、Excelの[セキュリィセンター]-[マクロの設定]-[開発者向けのマクロ設定]-[ＶＢＡプロジェクトとオウジェクトモデルへのアクセスを信頼する(Y)]をチェックする必要があることが分かり、この方法も諦め。zipcode7.xlaのコアな機能のみを切り出し、今回作成するExcelのModuleに取り込む方法で実現した。
　取込んだModule(zipcode7.xlaからインポート): Addin_Common, YUBIN7_Core

サンプル
実際のサンプルはここ
コード

'-------------------------------------------------------------------------------------------
'    Sheet1 マクロ
'-------------------------------------------------------------------------------------------
' WEBSERVICEと同じ

’------------------------------------------------------------------------------------------------
'   Module1 マクロ
’------------------------------------------------------------------------------------------------
Public Function zip2address(郵便番号 As String)
    Dim 県 As String * 255, 都市 As String * 255, 都市2 As String * 255
    Dim 町名 As String * 255, 町名2 As String * 255
    Dim Ret As String
    
  If 郵便番号 <> "" Then
    Call YUBIN7_Core.fnStartYubin7
    Call GetZipDecision(郵便番号, 県, 都市, 都市2, 町名, 町名2)
    
    Ret = Replace(県 & 都市 & 都市2 & 町名 & 町名2, Chr(0), vbNullString)
    Ret = Replace(Ret, Chr(32), vbNullString)
    zip2address = Ret
  Else
    zip2address = ""
  End If
End Function

普通にWebAPIでXMLデータを取得する方法
「WEBSERVICE」関数を使用する方法と同じAPIを使用させてもらい、普通にVBAでHTTPリクエストを投げレスポンスを受け取る方法で住所を取得している。
サンプル
実際のサンプルはここ
コード

'-------------------------------------------------------------------------------------------
'    Sheet1 マクロ
'-------------------------------------------------------------------------------------------
' WEBSERVICEと同じ

’------------------------------------------------------------------------------------------------
'   Module1 マクロ
’------------------------------------------------------------------------------------------------
Function zip2address(ByVal 郵便番号 As String)
  Dim objXMLHttp As Object, zipArr, xmldata
  Dim state As String, city As String, address As String

  郵便番号 = Replace(郵便番号, "-", "")
  If 郵便番号 <> "" Then
    Set objXMLHttp = CreateObject("MSXML2.XMLHTTP")
    objXMLHttp.Open "GET", "http://zip.cgis.biz/xml/zip.php?zn=" & 郵便番号, False
    objXMLHttp.Send
    Set xmldata = objXMLHttp.responseXML

    state = xmldata.ChildNodes(1).ChildNodes(9).ChildNodes(4).Attributes.Item(0).Text
    city = xmldata.ChildNodes(1).ChildNodes(9).ChildNodes(5).Attributes.Item(0).Text
    address = xmldata.ChildNodes(1).ChildNodes(9).ChildNodes(6).Attributes.Item(0).Text
    zip2address = state + city + address
  Else
    zip2address = ""
  End If
End Function

ExcelのリストでOutlookから一斉メールを送信

　Excelのリストで管理している宛先にメールを一斉に送信できれば
便利なのでここを参考にして作成してみた。
　Basp21でもExcel VBAで操作してメール送信できるが、Basp21の
インストール、SMTP等のメールサーバ情報の設定が必要となるため
簡単にはに使えない。
　そこでWindowsユーザーなら大多数の方が使用しているOutlookを使い、
VBAでOutlokを操作してメールを送信してみた。


使用方法
実際のサンプル(mail_outlook.xlsm)はこちらからダウンロードしてください。

mail_list sheet

• 送信欄に”〇”があるメールアドレスにメールを送信。”〇”以外は送信しない。

mail_template sheet

• 件名：「Test Mail」部分を変更
• 本文：「テストメールです。」部分を変更
  　　　　TO：　｛０｝様　→　TO：”メール配信先リストの氏名”に自動変更
  　　　　FROM：　｛１｝　→　FROM："送信者名"に自動変更
• 送信者名：「そうしんしゃ」部分を変更

サンプルはこちら ”