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 *----*----*    *----*----*    *----*----*    *----*----*
inserted by FC2 system