Sub MyCsvLboxEx()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 選択文字列挿入処理(リストボックス三重連)MyCsvLbox改名版
  Rem (コンマ区切り形式ファイル SQL文指定 データ参照処理)
  Rem 作譜:Hitrock Camellia Shinopy
  Rem 言語:Word VBA
  Rem 機能...
  Rem   1. リストボックス1から挿入したい文字列の分類を選択する。
  Rem   2. リストボックス2から文字列を選択して文書上に挿入する。
  Rem 注記...
  Rem   1. MyCsvLboxと共に使用するため、この改名版を作成。(見掛け上、リストボックス六重連を実現。)
  Rem      コンマ区切り形式ファイルの保存先フォルダ・「schema.ini」ファイル・CSVファイルを作成しておくこと。
  Rem      MyCsvLboxExConst(既定値設定処理)で、保存先フォルダ名・CSVファイル名を指定する。
  Rem     (既定値は、注記2・3の通り。MyCsvLboxと同じ。)
  Rem   2. 「DBPath」にコンマ区切り形式ファイルの保存先フォルダを指定すること。
  Rem      関連フォルダ名の既定値は、マイドキュメントの\MyCsvLboxフォルダ。
  Rem   3. 「CsvDB」にファイル名を指定すること。
  Rem      関連CSVファイル名の既定値は、MyCsvLbox.csv。
  Rem   4.「MyCsvLbox」と「MyCsvLboxEx」を起動して、ツールバーを追加・表示しておき、使用する。
  Rem   5. マクロ実行時に画面表示が最大化の状態の場合、通常表示に変更する。(MyCsvLboxExFullScreen)
  Rem   6. コンマ区切り形式ファイルを参照する部分を、下記の書籍から引用して、Word VBA用に改変した。
  Rem      小島政行『VisualBasic,VBA,VBScriptのための実践&リファレンスADO』アプライドナレッジの
  Rem        「第3部 ADOの活用  第2章 VBA」
  Rem     佐藤信正『VBScript実用プログラミング・テクニック』メディア・テック出版の
  Rem        「Part5 [16]12万件の郵便番号を検索する」
  Rem 履歴...
  Rem   第01版:2009/10/10:作成。
  Rem   第02版:2015/01/30:MyCsvLbox修正に伴い再作成。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  Dim i As Long
  Dim j As Long
  Dim myValuePrev As String
  '
  Dim myConn As Object ' ADODB.Connection
  Dim myRecSet As Object ' ADODB.Recordset
  Dim DBPath As String
  Dim CsvDB As String
  Dim mySQL As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myTitle = "MyCsvLboxEx"
  Call MyCsvLboxExConst("myTitleNew", myTitle)
  Call MyCsvLboxExConst("DBPath", DBPath)
  Call MyCsvLboxExConst("CsvDB", CsvDB)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Call MyCsvLboxExFullScreen ' [次へ]押下時にポップヒントを無理やり表示させるため。(苦肉の策!)
  Call MyCsvLboxExCmmdBar(myTitle)
  '
  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 *----*----*    *----*----*    *----*----*    *----*----*
  '
MyCsvLboxExSubEntry:
  Rem [分類]のデータを整列せず、リストボックス1に表示する場合
  mySQL = "SELECT  分類  FROM  " & CsvDB & ";"
  '
  Rem テーブルへの参照を取得
  With myRecSet
    .ActiveConnection = myConn
    .Source = mySQL
    .Open
  End With
  '
  i = 0
  myValuePrev = ""
  '
  If myRecSet.EOF Then
    MsgBox "[ " & CsvDB & " ]にデータがありません。 ", vbCritical
    GoTo MyCsvLboxExSubExit
  End If
  '
  Rem レコードを転記
  Do While Not myRecSet.EOF
    If myRecSet.Fields(0).Value <> myValuePrev Then
      i = i + 1
      '
      For j = 1 To 3
        With CommandBars(myTitle & CStr(j)).Controls(2)
          .AddItem myRecSet.Fields(0).Value, i
          .DropDownLines = i
          .ListIndex = 0
          .Parameter = ""
        End With
      Next ' j
      '
      myValuePrev = myRecSet.Fields(0).Value
    End If
    myRecSet.MoveNext
  Loop
  '
  GoTo MyCsvLboxExSubExit
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem [分類]のデータを整列して、リストボックス1に表示する場合
  mySQL = "SELECT  DISTINCT 分類  FROM  " & CsvDB & ";"
  ' mySQL = "SELECT  分類  FROM  " & CsvDB & "  GROUP  BY 分類;"
  '
  With myRecSet
    .ActiveConnection = myConn
    .Source = mySQL
    .Open
  End With
  '
  i = 0
  Do While Not myRecSet.EOF
    i = i + 1
    '
    For j = 1 To 3
      With CommandBars(myTitle & CStr(j)).Controls(2)
        .AddItem myRecSet.Fields(0).Value, i
        .DropDownLines = i
        .ListIndex = 0
        .Parameter = ""
      End With
    Next ' j
    '
    myRecSet.MoveNext
  Loop
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyCsvLboxExSubExit:
  Rem 接続を閉じる
  On Error Resume Next
  myRecSet.Close
  myConn.Close
  On Error GoTo 0
  '
  Set myConn = Nothing
  Set myRecSet = Nothing
End Sub ' MyCsvLboxEx *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxExCmmdBar(myTitle As String)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem コマンドバー設定処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim i As Long
  '
  Dim myCmmdBar1 As CommandBar
  Dim myCtrl1BttnType As CommandBarControl
  Dim myCtrl1DdwnOne As CommandBarControl
  Dim myCtrl1DdwnTwo As CommandBarControl
  Dim myCtrl1BttnNext As CommandBarControl
  '
  Dim myCmmdBar2 As CommandBar
  Dim myCtrl2BttnType As CommandBarControl
  Dim myCtrl2DdwnOne As CommandBarControl
  Dim myCtrl2DdwnTwo As CommandBarControl
  Dim myCtrl2BttnNext As CommandBarControl
  '
  Dim myCmmdBar3 As CommandBar
  Dim myCtrl3BttnType As CommandBarControl
  Dim myCtrl3DdwnOne As CommandBarControl
  Dim myCtrl3DdwnTwo As CommandBarControl
  Dim myCtrl3BttnNext As CommandBarControl
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  On Error Resume Next
  CommandBars(myTitle).Delete
  For i = 1 To 3
    CommandBars(myTitle & CStr(i)).Delete
  Next ' i
  On Error GoTo 0
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myCmmdBar1 = CommandBars.Add(Name:=myTitle & "1", Position:=msoBarTop, Temporary:=True)
  Set myCtrl1BttnType = myCmmdBar1.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
  Set myCtrl1DdwnOne = myCmmdBar1.Controls.Add(Type:=msoControlDropdown, Before:=2, Temporary:=True)
  Set myCtrl1DdwnTwo = myCmmdBar1.Controls.Add(Type:=msoControlDropdown, Before:=3, Temporary:=True)
  Set myCtrl1BttnNext = myCmmdBar1.Controls.Add(Type:=msoControlButton, Before:=4, Temporary:=True)
  '
  Set myCmmdBar2 = CommandBars.Add(Name:=myTitle & "2", Position:=msoBarTop, Temporary:=True)
  Set myCtrl2BttnType = myCmmdBar2.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
  Set myCtrl2DdwnOne = myCmmdBar2.Controls.Add(Type:=msoControlDropdown, Before:=2, Temporary:=True)
  Set myCtrl2DdwnTwo = myCmmdBar2.Controls.Add(Type:=msoControlDropdown, Before:=3, Temporary:=True)
  Set myCtrl2BttnNext = myCmmdBar2.Controls.Add(Type:=msoControlButton, Before:=4, Temporary:=True)
  '
  Set myCmmdBar3 = CommandBars.Add(Name:=myTitle & "3", Position:=msoBarTop, Temporary:=True)
  Set myCtrl3BttnType = myCmmdBar3.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
  Set myCtrl3DdwnOne = myCmmdBar3.Controls.Add(Type:=msoControlDropdown, Before:=2, Temporary:=True)
  Set myCtrl3DdwnTwo = myCmmdBar3.Controls.Add(Type:=msoControlDropdown, Before:=3, Temporary:=True)
  Set myCtrl3BttnNext = myCmmdBar3.Controls.Add(Type:=msoControlButton, Before:=4, Temporary:=True)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  With myCtrl1BttnType
    .DescriptionText = "挿入ボタン"
    .Style = msoButtonIcon
    .Caption = "Type"
    .TooltipText = "文字列を挿入します。"
    .FaceId = 31
    .Parameter = ""
    .OnAction = myTitle & "1BttnType"
  End With
  '
  With myCtrl1DdwnOne
    .DescriptionText = "リストボックス1"
    .Style = msoComboNormal ' ラベルテキストを表示しない。
    .Caption = ""
    .TooltipText = "挿入したい文字列の分類を選択して下さい。"
    .BeginGroup = True
    .DropDownWidth = 400
    .OnAction = myTitle & "1DdwnOne"
  End With
  '
  With myCtrl1DdwnTwo
    .DescriptionText = "リストボックス2"
    .Style = msoComboNormal
    .Caption = ""
    .TooltipText = "選択した文字列を挿入します。"
    .BeginGroup = True
    .DropDownWidth = 400
    .OnAction = myTitle & "1DdwnTwo"
  End With
  '
  With myCtrl1BttnNext
    .DescriptionText = "次へボタン"
    .Style = msoButtonIcon
    .Caption = "Next"
    .TooltipText = "次の文字列を挿入します。"
    .FaceId = 157
    .Parameter = ""
    .OnAction = myTitle & "1BttnNext"
  End With
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  With myCtrl2BttnType
    .DescriptionText = "挿入ボタン"
    .Style = msoButtonIcon
    .Caption = "Type"
    .TooltipText = "文字列を挿入します。"
    .FaceId = 31
    .Parameter = ""
    .OnAction = myTitle & "2BttnType"
  End With
  '
  With myCtrl2DdwnOne
    .DescriptionText = "リストボックス1"
    .Style = msoComboNormal
    .Caption = ""
    .TooltipText = "挿入したい文字列の分類を選択して下さい。"
    .BeginGroup = True
    .DropDownWidth = 400
    .OnAction = myTitle & "2DdwnOne"
  End With
  '
  With myCtrl2DdwnTwo
    .DescriptionText = "リストボックス2"
    .Style = msoComboNormal
    .Caption = ""
    .TooltipText = "選択した文字列を挿入します。"
    .BeginGroup = True
    .DropDownWidth = 400
    .OnAction = myTitle & "2DdwnTwo"
  End With
  '
  With myCtrl2BttnNext
    .DescriptionText = "次へボタン"
    .Style = msoButtonIcon
    .Caption = "Next"
    .TooltipText = "次の文字列を挿入します。"
    .FaceId = 157
    .Parameter = ""
    .OnAction = myTitle & "2BttnNext"
  End With
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  With myCtrl3BttnType
    .DescriptionText = "挿入ボタン"
    .Style = msoButtonIcon
    .Caption = "Type"
    .TooltipText = "文字列を挿入します。"
    .FaceId = 31
    .Parameter = ""
    .OnAction = myTitle & "3BttnType"
  End With
  '
  With myCtrl3DdwnOne
    .DescriptionText = "リストボックス1"
    .Style = msoComboNormal
    .Caption = ""
    .TooltipText = "挿入したい文字列の分類を選択して下さい。"
    .BeginGroup = True
    .DropDownWidth = 400
    .OnAction = myTitle & "3DdwnOne"
  End With
  '
  With myCtrl3DdwnTwo
    .DescriptionText = "リストボックス2"
    .Style = msoComboNormal
    .Caption = ""
    .TooltipText = "選択した文字列を挿入します。"
    .BeginGroup = True
    .DropDownWidth = 400
    .OnAction = myTitle & "3DdwnTwo"
  End With
  '
  With myCtrl3BttnNext
    .DescriptionText = "次へボタン"
    .Style = msoButtonIcon
    .Caption = "Next"
    .TooltipText = "次の文字列を挿入します。"
    .FaceId = 157
    .Parameter = ""
    .OnAction = myTitle & "3BttnNext"
  End With
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  For i = 1 To 3
    CommandBars(myTitle & CStr(i)).Controls("Type").Enabled = False
    CommandBars(myTitle & CStr(i)).Controls("Next").Enabled = False
    CommandBars(myTitle & CStr(i)).Visible = True
  Next ' i
End Sub ' MyCsvLboxExCmmdBar *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxEx1BttnType(Optional myDummy As Boolean)
  Dim myTitle As String
  Call MyCsvLboxExConst("myTitle", myTitle)
  Call MyCsvLboxExConst("myCmmdBarNumber", myTitle & "1")
  Call MyCsvLboxExBttnType
End Sub ' MyCsvLboxEx1BttnType *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxEx1DdwnOne(Optional myDummy As Boolean)
  Dim myTitle As String
  Call MyCsvLboxExConst("myTitle", myTitle)
  Call MyCsvLboxExConst("myCmmdBarNumber", myTitle & "1")
  Call MyCsvLboxExDdwnOne
End Sub ' MyCsvLboxEx1DdwnOne *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxEx1DdwnTwo(Optional myDummy As Boolean)
  Dim myTitle As String
  Call MyCsvLboxExConst("myTitle", myTitle)
  Call MyCsvLboxExConst("myCmmdBarNumber", myTitle & "1")
  Call MyCsvLboxExDdwnTwo
End Sub ' MyCsvLboxEx1DdwnTwo *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxEx1BttnNext(Optional myDummy As Boolean)
  Dim myTitle As String
  Call MyCsvLboxExConst("myTitle", myTitle)
  Call MyCsvLboxExConst("myCmmdBarNumber", myTitle & "1")
  Call MyCsvLboxExBttnNext
End Sub ' MyCsvLboxEx1BttnNext *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxEx2BttnType(Optional myDummy As Boolean)
  Dim myTitle As String
  Call MyCsvLboxExConst("myTitle", myTitle)
  Call MyCsvLboxExConst("myCmmdBarNumber", myTitle & "2")
  Call MyCsvLboxExBttnType
End Sub ' MyCsvLboxEx2BttnType *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxEx2DdwnOne(Optional myDummy As Boolean)
  Dim myTitle As String
  Call MyCsvLboxExConst("myTitle", myTitle)
  Call MyCsvLboxExConst("myCmmdBarNumber", myTitle & "2")
  Call MyCsvLboxExDdwnOne
End Sub ' MyCsvLboxEx2DdwnOne *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxEx2DdwnTwo(Optional myDummy As Boolean)
  Dim myTitle As String
  Call MyCsvLboxExConst("myTitle", myTitle)
  Call MyCsvLboxExConst("myCmmdBarNumber", myTitle & "2")
  Call MyCsvLboxExDdwnTwo
End Sub ' MyCsvLboxEx2DdwnTwo *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxEx2BttnNext(Optional myDummy As Boolean)
  Dim myTitle As String
  Call MyCsvLboxExConst("myTitle", myTitle)
  Call MyCsvLboxExConst("myCmmdBarNumber", myTitle & "2")
  Call MyCsvLboxExBttnNext
End Sub ' MyCsvLboxEx2BttnNext *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxEx3BttnType(Optional myDummy As Boolean)
  Dim myTitle As String
  Call MyCsvLboxExConst("myTitle", myTitle)
  Call MyCsvLboxExConst("myCmmdBarNumber", myTitle & "3")
  Call MyCsvLboxExBttnType
End Sub ' MyCsvLboxEx3BttnType *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxEx3DdwnOne(Optional myDummy As Boolean)
  Dim myTitle As String
  Call MyCsvLboxExConst("myTitle", myTitle)
  Call MyCsvLboxExConst("myCmmdBarNumber", myTitle & "3")
  Call MyCsvLboxExDdwnOne
End Sub ' MyCsvLboxEx3DdwnOne *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxEx3DdwnTwo(Optional myDummy As Boolean)
  Dim myTitle As String
  Call MyCsvLboxExConst("myTitle", myTitle)
  Call MyCsvLboxExConst("myCmmdBarNumber", myTitle & "3")
  Call MyCsvLboxExDdwnTwo
End Sub ' MyCsvLboxEx3DdwnTwo *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxEx3BttnNext(Optional myDummy As Boolean)
  Dim myTitle As String
  Call MyCsvLboxExConst("myTitle", myTitle)
  Call MyCsvLboxExConst("myCmmdBarNumber", myTitle & "3")
  Call MyCsvLboxExBttnNext
End Sub ' MyCsvLboxEx3BttnNext *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxExBttnType(Optional myDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 挿入ボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  '
  Call MyCsvLboxExConst("myCmmdBar", myTitle)
  '
  If Len(CommandBars(myTitle).Controls(2).Text) = 0 Then
    Rem [分類]を選択していない状態(通常ではあり得ない)
    Exit Sub
  End If
  '
  CommandBars(myTitle).Controls("Type").FaceId = 964
  '
  If Len(CommandBars(myTitle).Controls(3).Text) <> 0 Then
    Call MyCsvLboxExText(CommandBars(myTitle).Controls(3).Text)
  Else
    Rem [本文]の項目を選択していない状態
    Call MyCsvLboxExText(CommandBars(myTitle).Controls(2).Text)
  End If
  '
  CommandBars(myTitle).Controls("Type").FaceId = 31
End Sub ' MyCsvLboxExBttnType *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxExDdwnOne(Optional myDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem リストボックス1処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  Dim i As Long
  '
  Dim myConn As Object ' ADODB.Connection
  Dim myRecSet As Object ' ADODB.Recordset
  Dim DBPath As String
  Dim CsvDB As String
  Dim mySQL As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Call MyCsvLboxExConst("myCmmdBar", myTitle)
  Call MyCsvLboxExConst("DBPath", DBPath)
  Call MyCsvLboxExConst("CsvDB", CsvDB)
  '
  Rem リストボックス2を設定し直す。
  With CommandBars(myTitle)
    .Controls("Type").FaceId = 964
    .Controls(3).Delete
    .Controls.Add Type:=msoControlDropdown, Before:=3, Temporary:=True
  End With
  '
  With CommandBars(myTitle).Controls(3)
    .DescriptionText = "リストボックス2"
    .Style = msoComboNormal
    .Caption = ""
    .TooltipText = "選択した文字列を挿入します。"
    .BeginGroup = True
    .DropDownWidth = 400
    .OnAction = myTitle & "DdwnTwo"
  End With
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem [本文]の項目をリストボックス2に設定する。
  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 *----*----*    *----*----*    *----*----*    *----*----*
  '
  mySQL = "SELECT  本文 FROM  " & CsvDB & "  "
  mySQL = mySQL & "WHERE  分類='" & CommandBars(myTitle).Controls(2).Text & "';"
  '
  Rem テーブルへの参照を取得
  With myRecSet
    .ActiveConnection = myConn
    .Source = mySQL
    .Open
  End With
  '
  i = 0
  Rem レコードを転記
  Do While Not myRecSet.EOF
    i = i + 1
    '
    With CommandBars(myTitle).Controls(3)
      .AddItem myRecSet.Fields(0).Value, i
      .DropDownLines = i
      .ListIndex = 0
      .Parameter = ""
    End With
    myRecSet.MoveNext
  Loop
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem 接続を閉じる
  On Error Resume Next
  myRecSet.Close
  myConn.Close
  On Error GoTo 0
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  With CommandBars(myTitle)
    .Controls("Type").Enabled = True
    .Controls("Type").TooltipText = .Controls(2).Text
    If .Controls(3).ListCount > 0 Then
      .Controls("Next").Enabled = True
      .Controls("Next").TooltipText = .Controls(3).List(1)
    Else
      Rem [分類]に該当する[本文]の項目がなかった場合(通常ではあり得ない)
      .Controls("Type").TooltipText = .Controls(2).Text
      .Controls("Next").Enabled = False
      .Controls("Next").TooltipText = ""
    End If
    .Controls("Type").FaceId = 31
  End With
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myConn = Nothing
  Set myRecSet = Nothing
End Sub ' MyCsvLboxExDdwnOne *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxExDdwnTwo(Optional myDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem リストボックス2処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  '
  Call MyCsvLboxExConst("myCmmdBar", myTitle)
  '
  If CommandBars(myTitle).Controls(3).Index = 0 Then
    Rem [本文]の項目を選択していない状態
    Exit Sub
  End If
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  CommandBars(myTitle).Controls("Type").FaceId = 964
  '
  Call MyCsvLboxExText(CommandBars(myTitle).Controls(3).Text)
  '
  With CommandBars(myTitle)
    .Controls("Type").TooltipText = .Controls(3).Text
    If .Controls(3).ListIndex < .Controls(3).ListCount Then
      .Controls("Next").TooltipText = .Controls(3).List(.Controls(3).ListIndex + 1)
    Else
      Rem [本文]の最後の項目を選択した場合
      .Controls("Next").TooltipText = "[先頭に戻る]"
    End If
  End With
  '
  CommandBars(myTitle).Controls("Type").FaceId = 31
End Sub ' MyCsvLboxExDdwnTwo *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxExBttnNext(Optional myDummy As Boolean)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 次へボタン処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  '
  Call MyCsvLboxExConst("myCmmdBar", myTitle)
  '
  With CommandBars(myTitle)
    Select Case True
      Case Len(.Controls(2).Text) = 0
        Rem [分類]を選択していない状態(通常ではあり得ない)
        Exit Sub
      Case .Controls(3).ListIndex >= .Controls(3).ListCount
        Rem 既に[本文]の最後の項目を選択している状態
        .Controls(3).ListIndex = 0
        .Controls("Type").TooltipText = .Controls(2).Text
        .Controls("Next").TooltipText = .Controls(3).List(1)
        Rem ポップヒントを無理やり表示させる。(苦肉の策!)
        Call MyCsvLboxExFullScreen
        Beep
        Exit Sub
    End Select
  End With
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  With CommandBars(myTitle)
    .Controls("Next").FaceId = 964
    .Controls(3).ListIndex = .Controls(3).ListIndex + 1
    .Controls("Type").TooltipText = .Controls(3).Text
  End With
  '
  Call MyCsvLboxExText(CommandBars(myTitle).Controls(3).Text)
  '
  With CommandBars(myTitle)
    If .Controls(3).ListIndex >= .Controls(3).ListCount Then
      Rem [本文]の最後の項目を選択した状態
      .Controls("Next").TooltipText = "[先頭に戻る]"
    Else
      Rem 次の[本文]項目のポップヒント表示を設定する。
      .Controls("Next").TooltipText = .Controls(3).List(.Controls(3).ListIndex + 1)
    End If
    .Controls("Next").FaceId = 157
  End With
  '
  Rem ポップヒントを無理やり表示させる。(苦肉の策!)
  Call MyCsvLboxExFullScreen
End Sub ' MyCsvLboxExBttnNext *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxExText(myText As String)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 文字列挿入処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  '
  Call MyCsvLboxExConst("myCmmdBar", myTitle)
  '
  Rem 括弧・引用符の中にカーソルを移す。
  If myText <> CommandBars(myTitle).Controls(2).Text Then
    Select Case CommandBars(myTitle).Controls(2).Text
      Case "半角括弧", "全角括弧", "引用符"
        Call MyCsvLboxExTextBracket(myTitle, myText)
        Exit Sub
    End Select
  End If
  '
  Selection.TypeText myText
End Sub ' MyCsvLboxExText *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxExTextBracket(myTitle As String, myText As String)
  If Len(Selection.Range.Text) > 0 Then
    Select Case True
      Case myText = "〔←〕"
        myText = Left(myText, 2) & Selection.Range.Text & Right(myText, 1)
      Case CommandBars(myTitle).Controls(2).Text = "全角括弧"
        myText = Left(myText, 1) & Selection.Range.Text & Right(myText, 1)
      Case CommandBars(myTitle).Controls(2).Text = "引用符"
        myText = Left(myText, 1) & Selection.Range.Text & Right(myText, 1)
      Case CommandBars(myTitle).Controls(2).Text = "半角括弧"
        myText = Left(myText, 2) & Selection.Range.Text & Right(myText, 2)
    End Select
    Selection.TypeText myText
    Exit Sub
  End If
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Selection.TypeText myText
  '
  Rem 括弧・引用符の中にカーソルを移す。
  If myText <> CommandBars(myTitle).Controls(2).Text Then
    Select Case CommandBars(myTitle).Controls(2).Text
      Case "全角括弧", "引用符"
        Selection.MoveLeft Unit:=wdCharacter, Count:=1
      Case "半角括弧"
        Selection.MoveLeft Unit:=wdCharacter, Count:=2
    End Select
  End If
End Sub ' MyCsvLboxExTextBracket *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxExFullScreen(Optional myDummy As Boolean)
  Dim myHeight As Long
  Dim myWidth As Long
  Dim myTop As Long
  Dim myLeft As Long
  '
  Application.ScreenUpdating = False
  '
  If ActiveWindow.WindowState = wdWindowStateMaximize Then
    myTop = Application.Top
    myLeft = Application.Left
    myWidth = Application.Width
    myHeight = Application.Height
    '
    ActiveWindow.WindowState = wdWindowStateNormal
    '
    Application.Top = myTop
    Application.Left = myLeft
    Application.Width = myWidth - 1
    Application.Height = myHeight - 1
  Else
    Rem wdWindowStateNormalの場合
    ActiveWindow.View.FullScreen = Not ActiveWindow.View.FullScreen ' フルスクリーン表示。
    ActiveWindow.View.FullScreen = Not ActiveWindow.View.FullScreen ' フルスクリーン表示を解除。
  End If
  '
  Application.ScreenUpdating = True
End Sub ' MyCsvLboxExFullScreen *----*----*    *----*----*    *----*----*    *----*----*

Sub MyCsvLboxExConst(myFlag As String, myString As String)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 既定値設定処理
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Static myTitleStatic As String
  Static myCmmdBarStatic As String
  Dim myShell As Object
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Select Case myFlag
    Case "myTitleNew"
      myTitleStatic = myString
    Case "myTitle"
      myString = myTitleStatic
    Case "myCmmdBarNumber"
      myCmmdBarStatic = myString
    Case "myCmmdBar"
      myString = myCmmdBarStatic
    Case "DBPath"
      Set myShell = CreateObject("WScript.Shell")
      myString = myShell.Specialfolders("MyDocuments")
      myString = myString & "\" & "MyCsvLbox"
    Case "CsvDB"
      myString = "MyCsvLbox.csv"
  End Select
  '
  Set myShell = Nothing
End Sub ' MyCsvLboxExConst *----*----*    *----*----*    *----*----*    *----*----*

inserted by FC2 system