Sub MyAdoZip() Rem *----*----* *----*----* *----*----* *----*----* Rem 郵便番号データファイル問い合わせ処理 Rem (CSV形式ファイル SQL文指定 データ参照処理) Rem 作譜:Hitrock Camellia Shinopy Rem 言語:Word VBA Rem 機能... Rem 1. 範囲選択した郵便番号から住所を文書上に書き出しする。 Rem 2. 範囲選択した住所(都道府県名・市区町村名・町域名。地番不可)から Rem 郵便番号を文書上に書き出しする。 Rem 3. 該当するデータが複数ある場合は、リストボックスから選択する。 Rem 4. ADOを使って、任意のフォルダをデータソースとして指定し、 Rem フォルダ内に保存されているCSV形式ファイルをテーブルとして扱い、 Rem SQL文を指定して、該当する内容を取得する。 Rem 注記... Rem 1. CSV形式ファイルを参照する部分を、下記の書籍から引用して、Word VBA用に改変した。 Rem 小島政行『VisualBasic,VBA,VBScriptのための実践&リファレンスADO』アプライドナレッジの Rem 「第3部 ADOの活用 第2章 VBA」 Rem 佐藤信正『VBScript実用プログラミング・テクニック』メディア・テック出版の Rem 「Part5 [16]12万件の郵便番号を検索する」 Rem 2. 実行前に日本郵政公社のサイトから、 Rem 郵便番号データファイルの[全国一括]データをダウンロードしておくこと。 Rem ( http://www.post.japanpost.jp/zipcode/dl/kogaki.html ) Rem 3. 「DBPath」にCSVファイルの保存先フォルダを指定すること。 Rem 4. CSVファイルの保存先フォルダに「schema.ini」ファイルを作成しておくこと。 Rem (「MyAdoSqlCsvSchemaIni」を初回実行前に先行して、一度だけ実行する。) Rem 5. 郵便番号データファイルの市区町村名の内容は、 Rem 「〜市」「〜市〜区」「〜郡〜町」となっている。 Rem 6. 不具合あり... Rem 例:「市川」を問い合わせすると、 Rem 「神奈川県 川崎市川崎区」など、余分な住所を検索する。 Rem 履歴... Rem 第01版:2007/07/25:作成。 Rem 第02版:2007/08/02:注記追加。 Rem 第03版:2007/08/04... Rem 検索した文字列が都道府県名・市区町村名・町域名を跨るものは、 Rem リストボックスに表示しないように修正。 Rem *----*----* *----*----* *----*----* *----*----* Rem 参照設定する場合... Rem Microsoft ActiveX Data Objects 2.8 Library Rem *----*----* *----*----* *----*----* *----*----* Dim myConn As Variant ' ADODB.Connection Dim myRecSet As Variant ' ADODB.Recordset Dim DBPath As String Dim CsvDB As String Dim mySQL As String ' Dim myTitle As String Dim i As Long Dim j As Long Dim k As Long Dim myStatusbar As String ' Dim myRange As Range Dim myText As String Dim myItem As String Dim myText2 As String Dim myAddr As Variant Dim myStr As String Dim myFlagText As String Dim myFlagItem As Boolean Rem *----*----* *----*----* *----*----* *----*----* ' myTitle = "MyAdoZip" DBPath = "C:\Documents and Settings\User\My Documents\Download\郵便番号" CsvDB = "KEN_ALL.CSV" Rem *----*----* *----*----* *----*----* *----*----* ' Set myRange = Selection.Range myText = Selection.Range.Text Call MyAdoZipDelString(myText) myStr = Replace(myText, "-", "") ' If myText = "" Then Exit Sub If myStr Like "#######" Then myFlagText = "Zip>Address" myText = myStr Else myFlagText = "Address>Zip" End If Rem *----*----* *----*----* *----*----* *----*----* ' Rem 新規オブジェクトをセット Set myConn = CreateObject("ADODB.Connection") Set myRecSet = CreateObject("ADODB.Recordset") ' Rem 「Extended Properties=TEXT;」を指定してCSVファイルに接続 myConn.Open _ "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & DBPath & ";" & _ "Extended Properties=TEXT;" Rem *----*----* *----*----* *----*----* *----*----* ' MyAdoZipSubEntry: Select Case myFlagText Case "Zip>Address" mySQL = "SELECT 都道府県名 & ' ' & 市区町村名 & ' ' & 町域名 FROM " & CsvDB & " " mySQL = mySQL & "Where 郵便番号='" & myText & "';" Case "Address>Zip" mySQL = "SELECT 郵便番号, 都道府県名 & ' ' & 市区町村名 & ' ' & 町域名 FROM " & CsvDB & " " mySQL = mySQL & "Where ( 都道府県名 & 市区町村名 & 町域名 ) Like '%" & myText & "%'; " End Select ' Rem テーブルへの参照を取得 With myRecSet .ActiveConnection = myConn .Source = mySQL .Open End With ' Call MyAdoZipCmmdBar(myTitle) CommandBars(myTitle).Controls(1).Parameter = myFlagText ' Rem フィールド名を転記 'For i = 1 To myRecSet.Fields.Count ' Selection.TypeText Text:=myRecSet.Fields(i - 1).Name & " " 'Next ' i ' j = 0 Rem レコードを転記 Do While Not myRecSet.EOF myItem = "" For i = 1 To myRecSet.Fields.Count Select Case myFlagText Case "Zip>Address" myItem = myItem & myRecSet.Fields(i - 1).Value Case "Address>Zip" If i = 1 Then myItem = myItem & myRecSet.Fields(i - 1).Value & ":" & " " Else myItem = myItem & myRecSet.Fields(i - 1).Value End If End Select Next ' i ' myFlagItem = True If myFlagText = "Address>Zip" Then myText2 = myText myAddr = Split(myItem, " ") For k = 1 To UBound(myAddr) myFlagItem = True myText2 = Replace(myText2, myAddr(k), "", 1, 1) If Len(myText2) <= 0 Then Exit For If InStr(myAddr(k), myText2) > 0 Then Exit For myFlagItem = False Next ' k End If ' If myFlagItem = True Then j = j + 1 With CommandBars(myTitle).Controls(2) .AddItem myItem, j .DropDownLines = j .ListIndex = 1 .Parameter = myFlagText End With End If myRecSet.MoveNext Loop ' Call MyAdoZipPopUp(myTitle, j, myRange) Rem *----*----* *----*----* *----*----* *----*----* ' MyAdoZipSubExit: Rem 接続を閉じる On Error Resume Next myRecSet.Close myConn.Close CommandBars(myTitle).Delete On Error GoTo 0 Set myRange = Nothing Set myConn = Nothing Set myRecSet = Nothing End Sub ' MyAdoZip *----*----* *----*----* *----*----* *----*----* Sub MyAdoZipDelString(myText As String) Rem *----*----* *----*----* *----*----* *----*----* Rem 不要文字列除外処理 Rem *----*----* *----*----* *----*----* *----*----* myText = Replace(myText, vbTab, "") myText = Replace(myText, vbCrLf, "") myText = Replace(myText, vbVerticalTab, "") myText = Replace(myText, vbCr, "") myText = Replace(myText, vbLf, "") myText = Replace(myText, " ", "") myText = Replace(myText, " ", "") myText = Replace(myText, "〒", "") End Sub ' MyAdoZipDelString *----*----* *----*----* *----*----* *----*----* Sub MyAdoZipPopUp(myTitle As String, j As Long, myRange As Range) Rem *----*----* *----*----* *----*----* *----*----* Rem リストボックス表示処理 Rem *----*----* *----*----* *----*----* *----*----* Dim myStr As String Dim myStatusbar As String Dim myFaceId As Long Rem *----*----* *----*----* *----*----* *----*----* ' Beep If j <= 0 Then Selection.Collapse wdCollapseStart myStatusbar = "該当するデータは、ありません。" Application.StatusBar = myTitle & ":" & myStatusbar Exit Sub End If ' myStatusbar = "該当するデータが、" & j & "件ありました。" Application.StatusBar = myTitle & ":" & myStatusbar ' If j = 1 Then Call MyAdoZipTypeText(myTitle) myStatusbar = " [ " & CommandBars(myTitle).Controls(2).Text & " ] " Application.StatusBar = myTitle & ":" & myStatusbar Exit Sub End If ' myStr = "該当するデータが、" & vbCrLf & j & "件ありました。" myStr = myStr & vbCrLf & vbCrLf myStr = myStr & "リストボックスから" myStr = myStr & "選択して下さい。" & Space(10) CommandBars(myTitle).Controls(1).Caption = myStr myFaceId = CommandBars(myTitle).Controls(1).FaceId Do On Error Resume Next CommandBars(myTitle).ShowPopup On Error GoTo 0 DoEvents If CommandBars(myTitle).Controls(1).FaceId <> myFaceId Then Exit Do myRange.Select Loop ' If CommandBars(myTitle).Controls(1).FaceId = 330 Then Selection.Collapse wdCollapseStart Exit Sub End If ' Call MyAdoZipTypeText(myTitle) myStatusbar = " [ " & CommandBars(myTitle).Controls(2).Text & " ] " Application.StatusBar = myTitle & ":" & myStatusbar End Sub ' MyAdoZipPopUp *----*----* *----*----* *----*----* *----*----* Sub MyAdoZipTypeText(myTitle As String) Rem *----*----* *----*----* *----*----* *----*----* Rem 書き出し処理 Rem *----*----* *----*----* *----*----* *----*----* Dim myText As String Rem *----*----* *----*----* *----*----* *----*----* ' myText = CommandBars(myTitle).Controls(2).Text If CommandBars(myTitle).Controls(1).Parameter = "Address>Zip" Then Selection.Collapse wdCollapseStart myText = Left(myText, InStr(myText, ":" & " ") - 1) myText = "〒" & Format(myText, "000-0000") Else Selection.Collapse wdCollapseEnd myText = Replace(myText, " ", "") End If ' Selection.TypeText myText End Sub ' MyAdoZipTypeText *----*----* *----*----* *----*----* *----*----* Sub MyAdoZipCmmdBar(myTitle As String) Rem *----*----* *----*----* *----*----* *----*----* Rem 複数データ時ポップアップメニュー設定処理 Rem *----*----* *----*----* *----*----* *----*----* Dim myCmmdBar As CommandBar Dim myCtrlIcon As CommandBarControl Dim myCtrlDdwn As CommandBarControl Dim myCtrlCancel As CommandBarControl ' Dim myText As String Rem *----*----* *----*----* *----*----* *----*----* ' On Error Resume Next CommandBars(myTitle).Delete On Error GoTo 0 Rem *----*----* *----*----* *----*----* *----*----* ' Set myCmmdBar = CommandBars.Add(Name:=myTitle, Position:=msoBarPopup, Temporary:=True) Set myCtrlIcon = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True) Set myCtrlDdwn = myCmmdBar.Controls.Add(Type:=msoControlDropdown, Before:=2, Temporary:=True) Set myCtrlCancel = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=3, Temporary:=True) Rem *----*----* *----*----* *----*----* *----*----* ' With myCtrlIcon .DescriptionText = "郵便番号データファイル問い合わせ処理" .Style = msoButtonIconAndWrapCaption .Caption = "選択して下さい。" .TooltipText = "該当するデータを選択して下さい。" .FaceId = 1089 .Parameter = "0000000" End With ' With myCtrlDdwn .DescriptionText = "郵便番号データファイルのデータをリストボックスから選択させます。" .Style = msoComboNormal ' msoComboLabel .Caption = "" ' "項目:" .TooltipText = "該当する項目を選んで下さい。" .BeginGroup = True ' .DropDownLines = 0 .DropDownWidth = 400 .OnAction = myTitle & "CmmdBarDdwn" End With ' With myCtrlCancel .DescriptionText = "[キャンセル]ボタン" .Style = msoButtonIconAndCaption .Caption = "キャンセル" & String(24, " ") .TooltipText = "処理を中止します。" .BeginGroup = True .FaceId = 330 .OnAction = myTitle & "CmmdBarCancel" End With End Sub ' MyAdoZipCmmdBar *----*----* *----*----* *----*----* *----*----* Sub MyAdoZipCmmdBarDdwn(Optional MyDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem リストボックス処理 Rem *----*----* *----*----* *----*----* *----*----* Dim myTitle As String ' myTitle = "MyAdoZip" CommandBars(myTitle).Controls(1).FaceId = 459 End Sub ' MyAdoZipCmmdBarDdwn *----*----* *----*----* *----*----* *----*----* Sub MyAdoZipCmmdBarCancel(Optional MyDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem キャンセルボタン処理 Rem *----*----* *----*----* *----*----* *----*----* Dim myTitle As String ' myTitle = "MyAdoZip" CommandBars(myTitle).Controls(1).FaceId = 330 End Sub ' MyAdoZipCmmdBarCancel *----*----* *----*----* *----*----* *----*----* Sub MyAdoSqlCsvSchemaIni() ' (Optional myDummy As Boolean) Rem *----*----* *----*----* *----*----* *----*----* Rem MyAdoSqlCsv初期設定処理(郵便番号データファイル) Rem (「MyAdoSqlCsv」初回実行前に一度だけ実行) Rem 機能... Rem 1. MyAdoSqlCsvの初期設定をする。 Rem 見出し情報や内部構造をODBCに伝えるために、 Rem CSVファイルの保存先フォルダに「schema.ini」ファイルを作成する。 Rem 2.「DBPath」にCSVファイルの保存先フォルダを指定すること。 Rem 3.この処理で「schema.ini」ファイルを作成する。 Rem 注記... Rem 1. 佐藤信正『VBScript実用プログラミング・テクニック』メディア・テック出版の Rem 「Part5 [16]12万件の郵便番号を検索する」から引用した。 Rem 2.「MyAdoSqlCsv」初回実行前に先行して一度だけ実行すること。 Rem 履歴... Rem 第01版:2007/07/25 作成。 Rem *----*----* *----*----* *----*----* *----*----* Dim myFso As Variant Dim myFile As Variant ' Dim DBPath As String Dim IniFile As String Dim myFullName As String ' Dim myTitle As String Dim myStatusbar As String Dim myMsg As String Dim myAns As Long Rem *----*----* *----*----* *----*----* *----*----* ' myTitle = "MyAdoSqlCsvSchemaIni" DBPath = "C:\Documents and Settings\User\My Documents\Download\郵便番号" IniFile = "schema.ini" myFullName = DBPath & "\" & IniFile Rem *----*----* *----*----* *----*----* *----*----* ' myMsg = "[初期設定] " & vbCrLf & "処理を実行します。 " & vbCrLf & vbCrLf myMsg = myMsg & "処理を中止したい場合は、" & vbCrLf myMsg = myMsg & "[キャンセル]を選択して下さい。" myStatusbar = Replace(myMsg, vbCrLf, "") ' Application.StatusBar = myTitle & ":" & myStatusbar myAns = MsgBox(myMsg, vbOKCancel + vbCritical + vbDefaultButton2, myTitle) ' If myAns <> vbOK Then Exit Sub Rem *----*----* *----*----* *----*----* *----*----* ' Set myFso = CreateObject("Scripting.FileSystemObject") ' If myFso.FileExists(myFullName) = True Then myMsg = "[初期設定] " & vbCrLf & vbCrLf myMsg = myMsg & "既定のフォルダとファイルは、作成済みです。" MsgBox myMsg, vbOKOnly + vbCritical, myTitle Exit Sub End If ' Rem 関連ファイルを作成する。 Set myFile = myFso.CreateTextFile(myFullName) With myFile .WriteLine ("[KEN_ALL.csv]") ' .WriteLine ("ColNameHeader=False") .WriteLine ("CharacterSet=oem") .WriteLine ("Format=CSVDelimited") ' .WriteLine ("Col1=全国地方公共団体コード Integer") .WriteLine ("Col2=(旧)郵便番号 Char Width 255") .WriteLine ("Col3=郵便番号 Char Width 255") .WriteLine ("Col4=都道府県名半角カタカナ Char Width 255") .WriteLine ("Col5=市区町村名半角カタカナ Char Width 255") .WriteLine ("Col6=町域名半角カタカナ Char Width 255") .WriteLine ("Col7=都道府県名 Char Width 255") .WriteLine ("Col8=市区町村名 Char Width 255") .WriteLine ("Col9=町域名 Char Width 255") .WriteLine ("Col10=一町域が二以上の郵便番号で表される場合の表示 Integer") .WriteLine ("Col11=小字毎に番地が起番されている町域の表示 Integer") .WriteLine ("Col12=丁目を有する町域の場合の表示 Integer") .WriteLine ("Col13=一つの郵便番号で二以上の町域を表す場合の表示 Integer") .WriteLine ("Col14=更新の表示 Integer") .WriteLine ("Col15=変更理由 Integer") .Close End With Rem *----*----* *----*----* *----*----* *----*----* ' myMsg = "[初期設定] " & vbCrLf myMsg = myMsg & "処理が完了しました!" & vbCrLf myStatusbar = Replace(myMsg, vbCrLf, "") ' Application.StatusBar = myTitle & ":" & myStatusbar myAns = MsgBox(myMsg, vbOKOnly + vbInformation, myTitle) ' Set myFso = Nothing Set myFile = Nothing End Sub ' MyAdoSqlCsvSchemaIni *----*----* *----*----* *----*----* *----*----*