Sub MyFileCbox()
Rem *----*----* *----*----* *----*----* *----*----*
Rem 同一フォルダ内文書ファイル選択処理（[開く]／[閉じる]随時切り替え）
Rem 作譜：Hitrock Camellia Shinopy
Rem 言語：Word VBA
Rem 機能...
Rem 指定したフォルダ内の文書ファイル名を取得し、コンボボックスに表示する。
Rem コンボボックスからファイル名を選択して、文書ファイルを開く。
Rem 別ファイルを選択すると、既に開いている文書ファイルを閉じて、
Rem 選択した文書ファイルを開く。
Rem 注記...
Rem 1. MyFileCboxを起動して使用｡
Rem 2. 表示する文書ファイルの[タイトル][サブタイトル][コメント]を取得して、
Rem コンボボックスのポップ ヒントで表示する。
Rem 履歴...
Rem 第01版：2007/04/24：作成。
Rem *----*----* *----*----* *----*----* *----*----*
Rem 参照設定する場合...
Rem Microsoft Shell Controls And Automation
Rem Microsoft Scripting RunTime
Rem Microsoft VBScript Regular Expressions 5.5
Rem *----*----* *----*----* *----*----* *----*----*
Dim myTitle As String
Dim myFolder As String
Dim myFiles As String
Rem *----*----* *----*----* *----*----* *----*----*
'
myTitle = "MyFileCbox"
'
myFiles = ""
Call MyFileCboxMyFiles(myFolder, myFiles)
'
Select Case myFiles
Case ""
Rem 処理キャンセル
Exit Sub
Case vbCr
MsgBox "文書ファイル（*.doc）がありません。"
Exit Sub
End Select
myFiles = " " & myFiles
myFiles = Left(myFiles, Len(myFiles) - 1)
Rem *----*----* *----*----* *----*----* *----*----*
'
Call MyFileCboxCmmdBar(myTitle, myFolder, myFiles)
Call MyFileCboxBttn(myTitle)
End Sub ' MyFileCbox *----*----* *----*----* *----*----* *----*----*
Sub MyFileCboxBttn(myTitle As String)
Rem *----*----* *----*----* *----*----* *----*----*
Rem 各コマンドコントロール処理
Rem *----*----* *----*----* *----*----* *----*----*
Dim i As Long
'
Dim myBttnPrev As CommandBarControl
Dim myCboxItem As CommandBarControl
Dim myBttnNext As CommandBarControl
Rem *----*----* *----*----* *----*----* *----*----*
'
Set myBttnPrev = CommandBars(myTitle).Controls(1)
Set myCboxItem = CommandBars(myTitle).Controls(2)
Set myBttnNext = CommandBars(myTitle).Controls(3)
'
Select Case CommandBars(myTitle & "Exec").Controls(1).TooltipText
Case "[初期]"
CommandBars(myTitle & "Exec").Controls(1).TooltipText = ""
'
myBttnPrev.Enabled = False
myBttnNext.Enabled = False
Rem *----*----* *----*----*
Case "[前へ]"
CommandBars(myTitle & "Exec").Controls(1).TooltipText = ""
'
i = myCboxItem.ListIndex
i = i - 1
myCboxItem.ListIndex = i
If i = 1 Then
myBttnPrev.Enabled = False
myBttnNext.Enabled = True
Else
myBttnPrev.Enabled = True
myBttnNext.Enabled = True
End If
Call MyFileCboxItem(myTitle)
Rem *----*----* *----*----*
Case "[次へ]"
CommandBars(myTitle & "Exec").Controls(1).TooltipText = ""
'
i = myCboxItem.ListIndex
i = i + 1
myCboxItem.ListIndex = i
If i >= myCboxItem.DropDownLines - 1 Then
myBttnPrev.Enabled = True
myBttnNext.Enabled = False
Else
myBttnPrev.Enabled = True
myBttnNext.Enabled = True
End If
Call MyFileCboxItem(myTitle)
Rem *----*----* *----*----*
Case "[文書選択]"
CommandBars(myTitle & "Exec").Controls(1).TooltipText = ""
'
If myCboxItem.DropDownLines <= 2 Then
myBttnPrev.Enabled = False
myBttnNext.Enabled = False
Else
Select Case myCboxItem.ListIndex
Case 1
myBttnPrev.Enabled = False
myBttnNext.Enabled = True
Case myCboxItem.DropDownLines - 1
myBttnPrev.Enabled = True
myBttnNext.Enabled = False
Case Else
myBttnPrev.Enabled = True
myBttnNext.Enabled = True
End Select
End If
Call MyFileCboxItem(myTitle)
End Select
End Sub ' MyFileCboxBttn *----*----* *----*----* *----*----* *----*----*
Sub MyFileCboxItem(myTitle As String)
Rem *----*----* *----*----* *----*----* *----*----*
Rem [文書選択]実行処理
Rem *----*----* *----*----* *----*----* *----*----*
Dim myFolder As String
Dim myFile As String
Dim myText As String
Dim x As Long
Dim i As Long
Dim myAns As Long
'
Dim myBttnPrev As CommandBarControl
Dim myCboxItem As CommandBarControl
Dim myBttnNext As CommandBarControl
Rem *----*----* *----*----* *----*----* *----*----*
'
Set myBttnPrev = CommandBars(myTitle).Controls(1)
Set myCboxItem = CommandBars(myTitle).Controls(2)
Set myBttnNext = CommandBars(myTitle).Controls(3)
'
Rem 既に開いている文書ファイルを選択した場合は処理しない。
If myCboxItem.Text = ActiveWindow.Document.Name Then Exit Sub
Rem *----*----* *----*----* *----*----* *----*----*
'
x = CommandBars(myTitle).Controls.Count
If CommandBars(myTitle).Controls(x).FaceId = 579 Then
ActiveWindow.Close SaveChanges:=wdDoNotSaveChanges
Else
If ActiveDocument.Saved = True Then
ActiveWindow.Close SaveChanges:=wdDoNotSaveChanges
Else
On Error Resume Next
ActiveDocument.Close SaveChanges:=wdPromptToSaveChanges
If Err.Number <> 0 Then
myCboxItem.ListIndex = CommandBars(myTitle & "Exec").Controls(1).DescriptionText
On Error GoTo 0
Exit Sub
End If
End If
End If
'
myFolder = myCboxItem.DescriptionText
myFile = myCboxItem.Text
'
Documents.Open FileName:=myFolder & "\" & myFile, AddToRecentFiles:=False
Rem *----*----* *----*----* *----*----* *----*----*
'
Rem [タイトル][サバタイトル][コメント]を取得。
If Len(ActiveDocument.BuiltInDocumentProperties("Title")) <> 0 Then
myText = ActiveDocument.BuiltInDocumentProperties("Title")
Else
myText = myCboxItem.Text
End If
myCboxItem.Caption = myText
'
If Len(ActiveDocument.BuiltInDocumentProperties("Subject")) <> 0 Then
myText = ActiveDocument.BuiltInDocumentProperties("Subject")
Else
myText = myCboxItem.Text
End If
If Len(ActiveDocument.BuiltInDocumentProperties("Comments")) <> 0 Then
myText = myText & vbCrLf & ActiveDocument.BuiltInDocumentProperties("Comments")
End If
myCboxItem.TooltipText = myText
Rem *----*----* *----*----* *----*----* *----*----*
'
Rem [前へ][次へ]のポップ ヒントにファイル名を設定。
x = myCboxItem.ListIndex
'
If myBttnPrev.Enabled = False Then
myBttnPrev.TooltipText = "前へ"
Else
i = x - 1
myCboxItem.ListIndex = i
myBttnPrev.TooltipText = myCboxItem.Text
myCboxItem.ListIndex = x
End If
'
If myBttnNext.Enabled = False Then
myBttnNext.TooltipText = "次へ"
Else
i = x + 1
myCboxItem.ListIndex = i
myBttnNext.TooltipText = myCboxItem.Text
myCboxItem.ListIndex = x
End If
'
With CommandBars(myTitle & "Exec").Controls(1)
.DescriptionText = myCboxItem.ListIndex
End With
End Sub ' MyFileCboxItem *----*----* *----*----* *----*----* *----*----*
Sub MyFileCboxMyFiles(myFolder As String, myFiles As String)
Dim myShell As Variant ' Shell32.Shell
Dim myBrowseFolder As Variant ' Shell32.Folder
'
Dim myFso As Variant ' Scripting.FileSystemObject
Dim myScriptingFiles As Variant ' Scripting.Files
Dim myScriptingFile As Variant ' Scripting.File
'
Dim myText As String
Rem *----*----* *----*----* *----*----* *----*----*
'
Set myShell = CreateObject("Shell.Application")
Rem [フォルダの参照]ダイアログボックス表示
myText = "文書ファイルの保存先フォルダを指定して下さい。"
If Application.Windows.Count < 1 Then
Documents.Add DocumentType:=wdNewBlankDocument
End If
Set myBrowseFolder = myShell.BrowseForFolder(0, myText, 1 + 16, ActiveDocument.Path)
If myBrowseFolder Is Nothing Then
Exit Sub
Else
myFolder = myBrowseFolder.Items.Item.Path
End If
'
Set myFso = CreateObject("Scripting.FileSystemObject")
Rem ファイルを名を取り込む
Set myScriptingFiles = myFso.GetFolder(myFolder).Files
myFiles = vbCr
For Each myScriptingFile In myScriptingFiles
Select Case Right(myScriptingFile, 4)
Case ".doc"
myFiles = myFiles & myScriptingFile.Name & vbCr
End Select
Next ' myScriptingFile
Rem *----*----* *----*----* *----*----* *----*----*
'
Set myShell = Nothing
Set myBrowseFolder = Nothing
Set myFso = Nothing
Set myScriptingFiles = Nothing
Set myScriptingFile = Nothing
End Sub ' MyFileCboxMyFiles *----*----* *----*----* *----*----* *----*----*
Sub MyFileCboxCmmdBar(myTitle As String, myFolder As String, myFiles As String)
Rem *----*----* *----*----* *----*----* *----*----*
Rem ツールバー処理
Rem *----*----* *----*----* *----*----* *----*----*
Dim MyArray As Variant
Dim i As Long
Rem *----*----* *----*----* *----*----* *----*----*
'
Rem 同名ツールバーの削除
On Error Resume Next
CommandBars(myTitle).Delete
CommandBars(myTitle & "Exec").Delete
On Error GoTo 0
'
Rem ステータスバーの表示
Application.DisplayStatusBar = True
'
Dim myCmmdBar As CommandBar
Dim myBttnPrev As CommandBarControl
Dim myCboxItem As CommandBarControl
Dim myBttnNext As CommandBarControl
Dim myBttnSave As CommandBarControl
Rem *----*----* *----*----* *----*----* *----*----*
'
Set myCmmdBar = CommandBars.Add(Name:=myTitle, Position:=msoBarTop, Temporary:=True)
Set myBttnPrev = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=1, Temporary:=True)
Set myCboxItem = myCmmdBar.Controls.Add(Type:=msoControlComboBox, Before:=2, Temporary:=True)
Set myBttnNext = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=3, Temporary:=True)
Set myBttnSave = myCmmdBar.Controls.Add(Type:=msoControlButton, Before:=4, Temporary:=True)
Rem *----*----* *----*----* *----*----* *----*----*
'
With myBttnPrev
.DescriptionText = "文書ファイル切り替え処理"
.Style = msoButtonIcon
.Caption = myTitle
.TooltipText = "前へ"
.FaceId = 1925
.OnAction = myTitle & "MyBttnPrev"
End With
'
MyArray = Split(myFiles, vbCr)
'
With myCboxItem
.DescriptionText = myFolder
.BeginGroup = True
.Style = msoComboLabel
.Caption = "文書名"
'
For i = 1 To UBound(MyArray)
.AddItem MyArray(i), i
Next ' i
'
.ListIndex = 0
.TooltipText = "フォルダ：" & myFolder
.DropDownLines = i
.DropDownWidth = 200
.OnAction = myTitle & "MyCboxItem"
End With
'
With myBttnNext
.DescriptionText = "文書ファイル切り替え処理"
.BeginGroup = True
.Style = msoButtonIcon
.Caption = myTitle
.TooltipText = "次へ"
.FaceId = 1924
.OnAction = myTitle & "MyBttnNext"
End With
'
With myBttnSave
.DescriptionText = "文書ファイル切り替え処理"
.BeginGroup = True
.Style = msoButtonIcon
.Caption = myTitle
.TooltipText = "変更があっても、保存しない。"
.FaceId = 579
.OnAction = myTitle & "MyBttnSave"
End With
'
myCmmdBar.Visible = True
'
CommandBars.Add Name:=myTitle & "Exec", Position:=msoBarPopup, Temporary:=True
CommandBars(myTitle & "Exec").Controls.Add Type:=msoControlButton, Before:=1, Temporary:=True
With CommandBars(myTitle & "Exec").Controls(1)
.DescriptionText = myCboxItem.ListIndex
.Caption = "実行！"
.FaceId = 329
.TooltipText = "[初期]"
'.Visible = True
End With
End Sub ' MyFileCboxCmmdBar *----*----* *----*----* *----*----* *----*----*
Sub MyFileCboxMyBttnPrev(Optional myDummy As Boolean)
Rem *----*----* *----*----* *----*----* *----*----*
Rem [前へ]ボタン処理
Rem *----*----* *----*----* *----*----* *----*----*
Dim myTitle As String
'
myTitle = "MyFileCbox"
'
CommandBars(myTitle & "Exec").Controls(1).TooltipText = "[前へ]"
Call MyFileCboxBttn(myTitle)
End Sub ' MyFileCboxMyBttnPrev *----*----* *----*----* *----*----* *----*----*
Sub MyFileCboxMyCboxItem(Optional myDummy As Boolean)
Rem *----*----* *----*----* *----*----* *----*----*
Rem [文書選択]ボタン処理
Rem *----*----* *----*----* *----*----* *----*----*
Dim myTitle As String
Dim x As Long
'
myTitle = "MyFileCbox"
x = CommandBars(myTitle).Controls.Count - 2 ' コマンドバー右端から2番目[文書選択]
'
CommandBars(myTitle & "Exec").Controls(1).TooltipText = "[文書選択]"
Call MyFileCboxBttn(myTitle)
End Sub ' MyFileCboxMyCboxItem *----*----* *----*----* *----*----* *----*----*
Sub MyFileCboxMyBttnNext(Optional myDummy As Boolean)
Rem *----*----* *----*----* *----*----* *----*----*
Rem [次へ]ボタン処理
Rem *----*----* *----*----* *----*----* *----*----*
Dim myTitle As String
'
myTitle = "MyFileCbox"
'
CommandBars(myTitle & "Exec").Controls(1).TooltipText = "[次へ]"
Call MyFileCboxBttn(myTitle)
End Sub ' MyFileCboxMyBttnNext *----*----* *----*----* *----*----* *----*----*
Sub MyFileCboxMyBttnSave(Optional myDummy As Boolean)
Rem *----*----* *----*----* *----*----* *----*----*
Rem [保存可否]ボタン処理
Rem *----*----* *----*----* *----*----* *----*----*
Dim myTitle As String
'
myTitle = "MyFileCbox"
'
With CommandBars(myTitle).Controls(CommandBars(myTitle).Controls.Count)
If .FaceId = 579 Then
.FaceId = 538
.TooltipText = "変更を保存するか確認する。"
Else
.FaceId = 579
.TooltipText = "変更があっても、保存しない。"
End If
End With
End Sub ' MyFileCboxMyBttnSave *----*----* *----*----* *----*----* *----*----*
