名前を付けて保存ダイアログ

Question

開いているフォームのレポートを
名前を付けて保存ダイアログを使ってデスクトップにPDFで保存したいです。

見よう見真似で試しているのですが
キャンセルボタンをクリックしてもメッセージが出ず
ドキュメントにファイルが保存されてしまいます。
また、何も入力されていない時にボタンを押すと
ダイアログが開きなんらかのアクションの後に
実行時エラー’3075’が出るので
ダイアログが出る前にメッセージを出したいです。
(今のコードだと後から出ます）

よろしくお願いいたします。

Function GetFileName(OpenOrSaveFlg As Boolean, strFilter As String, _
strTitle As String, strDefaultPath As String) As String

Dim wScriptHost As Object, strInitDir As String
Dim returnValue As Integer
Dim strFilePath As String
strFilePath = strDefaultPath

If strFilter = "" Then
strFilter = "全てのファイル (*.*)|*.*"
End If

WizHook.Key = 51488399 'WIZHOOK有効
returnValue = WizHook.GetFileName( _
0, "", strTitle, "", strFilePath, "", _
strFilter, _
0, 0, 0, OpenOrSaveFlg _
)
WizHook.Key = 0 ' WizHook 無効
GetFileName = strFilePath

End Function


Private Sub コマンド55_Click()
DoCmd.RunCommand acCmdSaveRecord

Const cstrRptName As String = "受注票"

On Error GoTo Err_Handler


Dim strFileName As String
Dim ExpFileName As String

 Set wScriptHost = CreateObject("WScript.Shell")
    strInitDir = wScriptHost.SpecialFolders("Desktop")

ExpFileName = "受注票_" & Format(Now(), "yyyymmdd_hhnnss")

strFileName = GetFileName(False, "PDFファイル (*.pdf)|*.pdf", "", ExpFileName & ".pdf")
If Len(strFileName) = 0 Then

MsgBox "キャンセルしました。"


Else

Echo False
DoCmd.OpenReport "受注票", acViewPreview, , "受注ID=" & 受注ID
DoCmd.OutputTo acOutputReport, "受注票", acFormatPDF, strFileName, False

End If

OpenAfterPublish = False

Exit_Here:
  On Error Resume Next
  DoCmd.Close acReport, cstrRptName
  Echo True
  Exit Sub

Err_Handler:
  If Err.Number = 3075 Then
  MsgBox "保存できるものがありません" & vbLf
  Else

MsgBox "エラーが起こりました" & vbLf
End If
  Resume Exit_Here:



End Sub

Comments

[Youbun]

strFilePath = strDefaultPath
が入っているため、キャンセルボタンをクリックしたときに保存してしまうのではないでしょうか？
returnValueの値を見て戻り値を変更すればいける気がします

Answer 1

・「キャンセル」を押すと**「strFilePath = strDefaultPath」の値のまま**なので
戻り値を「""」にしないといけない
・一応、ジャンプ後の処理の前で「Exit Sub」で処理を終了させる

この2つの処理を追記しました。
これでエラーはなくなり、想定通りの処理を行うと思います。
▼ 追記の部分は※でコメントしてます

Option Compare Database

Function GetFileName(OpenOrSaveFlg As Boolean, strFilter As String, _
strTitle As String, strDefaultPath As String) As String

Dim wScriptHost As Object, strInitDir As String
Dim returnValue As Integer
Dim strFilePath As String
strFilePath = strDefaultPath

If strFilter = "" Then
strFilter = "全てのファイル (*.*)|*.*"
End If

WizHook.Key = 51488399 'WIZHOOK有効
returnValue = WizHook.GetFileName( _
0, "", strTitle, "", strFilePath, "", _
strFilter, _
0, 0, 0, OpenOrSaveFlg _
)
WizHook.Key = 0 ' WizHook 無効

' ※キャンセル時は戻り値を未記入にする
If returnValue = -302 Then
    GetFileName = ""
Else
    GetFileName = strFilePath
End If

End Function


Private Sub コマンド55_Click()
DoCmd.RunCommand acCmdSaveRecord
Const cstrRptName As String = "受注票"
On Error GoTo Err_Handler
Dim strFileName As String
Dim ExpFileName As String
Set wScriptHost = CreateObject("WScript.Shell")
    strInitDir = wScriptHost.SpecialFolders("Desktop")
ExpFileName = "受注票_" & Format(Now(), "yyyymmdd_hhnnss")
strFileName = GetFileName(False, "PDFファイル (*.pdf)|*.pdf", "", ExpFileName & ".pdf")
If Len(strFileName) = 0 Then
MsgBox "キャンセルしました。"
Else
Echo False
DoCmd.OpenReport "受注票", acViewPreview, , "受注ID=" & 受注ID
DoCmd.OutputTo acOutputReport, "受注票", acFormatPDF, strFileName, False
End If
OpenAfterPublish = False

' ※ジャンプ後の処理の前に終了処理を入れる
Exit Sub

Exit_Here:
  On Error Resume Next
  DoCmd.Close acReport, cstrRptName
  Echo True
  Exit Sub
Err_Handler:
  If Err.Number = 3075 Then
  MsgBox "保存できるものがありません" & vbLf
  Else
  MsgBox "エラーが起こりました" & vbLf
  End If
  Resume Exit_Here:
End Sub

＞＞また、何も入力されていない時にボタンを押すと
ダイアログが開きなんらかのアクションの後に実行時エラー’3075’が出る

未記入の場合は保存ボタンは押せなくなっているはずですが・・・
何のボタンを押してエラーが出たのか分からなかったのでとりあえずスルーしました！

Comments

[techiko]

どうもありがとうございます！！
無事にキャンセル処理できました。

「何も入力されていない」というのはフォームに入力がされていない時に
保存もしくはキャンセルボタンを押した場合のことでした。言葉足らずですみません。
でもこの問題もキャンセルボタンが使えるようになったのでクリアしました。
どもありがとうございました！！

[techiko]

解決済み後にすみません…
実際に保存してみたら、メニューバー部分が印刷プレビューのメニューとなってしまい
閉じるを押すとAccessがフリーズしてしまうようになってしまいました。
プレビューを閉じる設定に問題が生じているのでしょうか…

[Youbun]

https://www.mccoy.jp/chie/zaitaku/access/vba/vba_report1.html
このリンクを見る限り
DoCmd.OpenReport "受注票", acViewPreview, , "受注ID=" & 受注ID　のコードですが、
「acViewPreview＝印刷プレビュ」を表示する処理になってます。

意図がわからないので何とも言えないですが、
そもそもこの行がいらないのではないかと思います。

フォームの処理は問題なく動いています。

Echo False
DoCmd.OpenReport "受注票", acViewPreview, , "受注ID=" & 受注ID
DoCmd.OutputTo acOutputReport, "受注票", acFormatPDF, strFileName, False

エラーの原因はこの部分なので、
自分の意図通りのコードを書いているか確認してみてください。

[techiko]

解決後にもかかわらずご回答ありがとうございます。

＞DoCmd.OpenReport "受注票", acViewPreview, , "受注ID=" & 受注ID

についてご指摘ありがとうございました。
入力フォームよりの開いているものだけをレポート保存したくいろいろ検索してこのコードを入れました。

閉じるコードを追加した　Exit Sub　の前に入れることで解決できました。
どうもありがとうございました。