| |
あわわ、調べてみたところ、「FileDialog」は、2002以降の機能でした！
その対策をしたのが下のマクロです。
Wordと共にExcelが、パソコンにインストールされていることが前提になりますが、
ファイルを選ぶ部分については、Excelの機能を借りることにしました。
しかし、フォルダの指定が一発でうまくいかず、「DefaultFilePath」を利かせるため、
（不細工ですが）Excelを裏方で二度起動しています。
それから、前回の回答にあった「myWord」は余計なオブジェクトでしたので削除。
取り敢えず、参照設定なしで動作するようにしています。
Sub myTxtInsertU2000()
Rem *----*----* *----*----* *----*----* *----*----*
Rem 複数テキストファイルの挿入
Rem *----*----* *----*----* *----*----* *----*----*
Rem 参照設定の場合...
Rem Microsoft Excel 10.0 Object Library
Rem Microsoft Scripting Runtime
Rem *----*----* *----*----* *----*----* *----*----*
Dim myExcel As Variant ' Excel.Application
Dim myDlgPick As Variant
Dim mySelectedItem As Variant
'
Dim myFso As Variant ' Scripting.FileSystemObject
Dim myFile As Variant
Dim myNewFile As String
'
' 前処理
If Documents.Count >= 2 Then
MsgBox "文書を閉じて下さい。"
Exit Sub
End If
If Documents.Count = 1 Then
If ActiveDocument.Characters.Count > 1 Then
MsgBox "文書を閉じて下さい。"
Exit Sub
Else
If ActiveDocument.Words(1).Text <> vbCr Then
MsgBox "文書を閉じて下さい。"
Exit Sub
Else
ActiveDocument.Close
End If
End If
End If
'
' フォルダの指定
Set myExcel = CreateObject("Excel.Application")
myExcel.DefaultFilePath = "C:\Documents and Settings\User\My Documents\Zzz"
myExcel.Quit
Set myExcel = Nothing
'
'myExcel.DefaultFilePath = "C:\Documents and Settings\User\My Documents\Esperanto"
' ↑フォルダ指定は､2回目実行時から有効｡
' ↓フォルダ指定の効き目なし。
'ChDrive "C:"
'ChDir "C:\Documents and Settings\User\My Documents\Zzz"
'
' ファイルの指定
Set myExcel = CreateObject("Excel.Application")
myDlgPick = myExcel.Application.GetOpenFilename(filefilter:="テキスト,*.txt,文書,*.doc", _
Title:="ファイルを選ぶ", _
MultiSelect:=True)
If TypeName(myDlgPick) = "Boolean" Then
Rem [キャンセル]ボタン時
myExcel.Quit
Set myExcel = Nothing
Set myDlgPick = Nothing
Exit Sub
End If
'
' ファイルの挿入
Set myFso = CreateObject("Scripting.FileSystemObject")
Application.Documents.Add
'
For Each mySelectedItem In myDlgPick
With Selection
.HomeKey Unit:=wdStory, Extend:=wdMove
.InsertFile FileName:=mySelectedItem, Range:="", ConfirmConversions:=False, _
Link:=False, Attachment:=False
.InsertBreak Type:=wdPageBreak ' 改ページ
'
Set myFile = myFso.GetFile(mySelectedItem)
Rem *----*----*
Rem myNewFile = myFso.GetFileName(mySelectedItem)
Rem myFso.DeleteFile myNewFile ' ファイル削除
Rem *----*----*
myNewFile = "Zzz" & myFso.GetFileName(mySelectedItem)
myFile.Name = myNewFile ' ファイル名を「Zzz〜」に変更
Rem *----*----*
End With
Next ' mySelectedItem
'
' 後処理
myExcel.Quit
Set myDlgPick = Nothing
Set myFso = Nothing
Set myFile = Nothing
Set myExcel = Nothing
End Sub ' myTxtInsertU2000
|
|
H. C. Shinopy
- 05/10/1(土) 22:30 -
