Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

57549 / 76738

←次へ　｜　前へ→


	【23925】Re:名前を付けて保存

kazu - 05/4/7(木) 18:36 -


	引用なし

	パスワード

こんな感じでどうでしょうか？

On Error GoTo errmsg
Dim Obj As Object
Dim myDir As String
Dim S As String

　　AryNoUse = Array("\", "/", ":", ",", ";", "*", "Print", """", "<", ">", "|")

　　Set Obj = CreateObject("Shell.Application"). _
　　BrowseForFolder(0, "保存したいフォルダを選択して「OK」ボタンをクリックして下さい｡", 0)

　　If Obj Is Nothing Then Exit Sub

　　myDir = Obj.Self.Path
　　
　　If Obj.Title = "マイコンピュータ" Then
　　　　MsgBox "マイコンピュータは選択しないで下さい。", vbExclamation
　　　　Exit Sub
　　End If
　　
　　UserForm1.Show

errmsg:

'-------------------------------------------------------------------------
　　Fnm = UserForm1.TextBox1.Value
　　If Fnm = "" Then
　　 MsgBox "ﾌｧｲﾙ名が指定されていません。"
　　 Exit Sub
　　End If
　　
　　For Each Chk In AryNoUse
　　　　If InStr(1, Fnm, Chk) <> 0 Then
　　　　　　MsgBox "ﾌｧｲﾙ名に不適切な文字が含まれています。" & vbCrLf & "処理を中止します。", vbExclamation
　　　　　　Exit Sub
　　　　End If
　　Next

　　 Application.DisplayAlerts = False
　　 S = myDir & "\" & Fnm & ".xls"
　　　If Dir(S) <> "" Then
　　　　 If MsgBox("既に存在します。上書きしますか", vbQuestion + vbYesNoCancel) = vbYes Then
　　　　　　Kill S
　　　　 Else
　　　　　　MsgBox "Noが選択されたので処理を中止します。"
　　　　　　Exit Sub
　　　　 End If
　　　Else
　　　　 ActiveWorkbook.SaveAs myDir & "\" & UserForm1.TextBox1.Value & ".xls"
　　　　 Application.DisplayAlerts = True
　　　　 Application.Quit
　　　End If

0 hits

▼

【23846】名前を付けて保存 yamazaki 05/4/5(火) 20:06