ACCESS エクスポート ダイアログ ファイル名取得

質問

ACCESS2003で作成したデータをダイアログで指定したファイル名でエクスポートしたいのですが、上手くできません。

ダイアログが開きその指定したフォルダーにあるエクセルファイルを選択すれば、正常にエキスポートできるのですが、
開いたダイアログにファイル名を入力すると、それ以降動かなくなります。

基本的なことが間違っているのでしょうか？？
詳しい方教えてください。下記にコードした内容を書きました。
よろしくお願いします。

Private Sub cmbTransExcel_Click()
On Error GoTo Err_cmbTransExcel_Click
Dim fileSaveName As Variant
Set dlg = Application.FileDialog(msoFileDialogOpen)
With dlg
.Title = "チェック"
.ButtonName = "エキスポート"
.InitialFileName = "C:\Program Files\DATA\"
.InitialView = msoFileDialogViewList
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "xls", "*.xls"
End With
With dlg
If .Show = -1 Then
For Each vntPath In dlg.SelectedItems
strPath = vntPath
Next
Else
Set dlg = Nothing
Exit Sub
End If
End With
Set dlg = Nothing

Dim strac As String
Dim varxls As Variant
Dim strmsg As String

strac = "Q_チェック" 'Accessファイルを指定します。
varxls = strPath 'エクセルファイルを指定します。
strmsg = strac & " を、Excelファイルへ出力します。" & Chr(13) & _
"出力先は" & varxls & "、 シート名は" & strac & "です。" & _
Chr(13) & "よろしければ、OKをクリックして下さい。"

If MsgBox(strmsg, vbOKCancel) = vbOK Then

'最初のデータをフィールド名として使います。
DoCmd.TransferSpreadsheet acExport, _
acSpreadsheetTypeExcel9, strac, varxls, True

MsgBox "ＥＸＣＥＬの出力が正常終了しました。", vbInformation, "処理終了"

End If

Exit_cmbTransExcel_click:
Exit Sub

Err_cmbTransExcel_Click:
MsgBox "ＥＸＣＥＬの出力が異常終了しました。", vbCritical, "エラー！"

Resume Exit_cmbTransExcel_click
End Sub

回答No.1

bonaron

> Set dlg = Application.FileDialog(msoFileDialogOpen)
「ファイルを開く」 ですから
存在しないファイルは開けませんので、
無いものを指定することはできませんね。

回避策として
(1) msoFileDialogSaveAs を使用する。
　　この場合、フィルタが指定できませんので
　　拡張子の制御はご自身でやることになります。

(2) FileDialog 以外の方法にする。
　　お勧めはこちら。
http://www.f3.dion.ne.jp/~element/msaccess/AcTipsGetFileName.html
中ほどにある wh_GetFileName 関数 を「クリップボードにコピー」を
クリックしてコピー、
標準モジュールに貼り付け。

クリックイベントで wh_GetFileName 関数を呼び出すように変更。

Sub cmbTransExcelClick()
　　On Error GoTo Err_cmbTransExcel_Click
　　Const DLG_TITLE = "チェック"
　　Const OPEN_TITLE = "エキスポート"
　　Const INITIAL_DIR = "C:\Program Files\DATA"
　　Const FILTER_ = "xls (*.xls)|*.xls"
　　Const FILTER_INDEX = 0 ' 0 行目を既定で選択する。
　　Dim strPath As String
　　Dim strac As String
　　Dim varxls As Variant
　　Dim strmsg As String

　　' 保存先ファイル名を取得します。
　　strPath = wh_GetFileName(, , _
　　　　　　　　DLG_TITLE, OPEN_TITLE, , INITIAL_DIR, FILTER_, _
　　　　　　　　FILTER_INDEX, , gfnFlagsOverWritePrompt, _
　　　　　　　　gfnFOpenSaveAs)
　　If strPath = "" Then
　　　　Exit Sub
　　End If
　　strac = "TableList" 'Accessファイルを指定します。
　　varxls = strPath 'エクセルファイルを指定します。
　　strmsg = strac & " を、Excelファイルへ出力します。" & Chr(13) & _
　　"出力先は" & varxls & "、 シート名は" & strac & "です。" & _
　　Chr(13) & "よろしければ、OKをクリックして下さい。"

　　If MsgBox(strmsg, vbOKCancel) = vbOK Then

　　　　'最初のデータをフィールド名として使います。
　　　　DoCmd.TransferSpreadsheet acExport, _
　　　　acSpreadsheetTypeExcel9, strac, varxls, True

　　　　MsgBox "ＥＸＣＥＬの出力が正常終了しました。", vbInformation, "処理終了"

　　End If

Exit_cmbTransExcel_click:
　　Exit Sub

Err_cmbTransExcel_Click:
　　MsgBox "ＥＸＣＥＬの出力が異常終了しました。", vbCritical, "エラー！"

　　Resume Exit_cmbTransExcel_click
End Sub

お礼

早々のご回等ありがとうございます。
ご指摘の通りコードしたら、やりたいと思っていたことができました。
でも、正直内容のほうはよくわかりません。
ご紹介して頂いたサイト等を参考に勉強していきたいと思います。
本当にありがとうございました。