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 *----*----* *----*----* *----*----* *----*----*