ざっくり説明
①ユーザーに起動用VBSを配布(ショートカットの方が何かと楽かも)
②起動用VBSからデータベースを実行→デスクトップに本体がコピーされる
③データベースを閉じる時に削除用VBSが実行され、コピーされた本体が削除される
作り方
①サーバーからローカルへ本体をコピーするVBSを作成
↓のコードをメモ帳(.txt)に入れて拡張子を.vbsにして、文字コードを「UTF-16 LE」にして保存。
データベースが開かれているかどうか確認し(laccdbの有無)、開かれていたら二重起動しないように処理終了。開かれていなければ起動する。
強制終了でロックファイルが残った場合でも開けるように対応。
On Error Resume Next Dim WS, FSO, CopyPath, CopyFileName, PastePath, objAcc, lac Set WS = CreateObject("WScript.Shell") Set FSO = WScript.CreateObject("Scripting.FileSystemObject") CopyPath = "データベースを置いている場所のフルパス" & "\" 'エクスプローラで拾えるパスに\が付いてないので後付け CopyFileName = "コピーするデータベース本体の名前.accde" PastePath = WS.SpecialFolders("Desktop") & "\" 'コピー先 DialogTitle = "データベース名" 'Msgboxのタイトルで使う '①データベースの名前から拡張子を除く→laccdbを付ける lac = Left(CopyFileName, Len(CopyFileName) - 5) & "laccdb" '②デスクトップにあるlaccdbの状態(データベースが開かれているか、強制終了したものが残っているだけか)確認 'データベースが開かれてlaccdbが存在する場合はリネーム処理でエラー70が出るのでそれを拾う 'laccdbがない場合はエラー53が出るが拾わずに無視 FSO.GetFile(PastePath & lac).Name = "1" & lac '「1データベース名.laccdb」にする If Err.Number = 70 Then '貼り付け先で開かれていたらコピーしない MsgBox "システムが開かれているためコピーできません。" & vbCrLf & "システムを終了してからやり直してください。", , DialogTitle WScript.Quit Else FSO.GetFile(PastePath & "1" & lac).Delete 'リネームした居残りlaccdbを削除 'コピー FSO.CopyFile CopyPath & CopyFileName, PastePath '起動 'CreateObjectでAccessを作成して開こうとするとエラーが出る端末があるのでWS.Runを使用 Return = WS.Run("MSACCESS.EXE " & PastePath & CopyFileName, 3, False) 'Accessを最大化して開く End If
②ローカルにコピーした本体を削除するVBSを作成
自分で設置したコマンドボタンのClickか、フォームのUnloadでVBSを呼び出す。
↓のコードをメモ帳(.txt)に入れて拡張子を.vbsにして、文字コードを「UTF-16 LE」にして保存
データベースを終了させてコピー先から削除する。
laccdbが消える時間は一定ではないので、消えるまで待機→消えたらデータベース削除。
Dim WS, FSO, CopyFileName, PastePath, objAcc Set WS = CreateObject("WScript.Shell") Set FSO = WScript.CreateObject("Scripting.FileSystemObject") CopyFileName = "コピーしたデータベース本体の名前.accde" PastePath = WS.SpecialFolders("Desktop") & "\" 'データベースのコピー先 '★Unload内で呼び出す場合はここから下を消す★ 'PastePathにデータベースが存在することを確認する If FSO.FileExists(PastePath & CopyFileName) = True Then 'データベースを開いているか確認し、開いていたら閉じる 'データベース名から拡張子を除く→代わりにlaccdbを付けてデータベースが開かれているかチェック If FSO.FileExists(PastePath & Left(CopyFileName, Len(CopyFileName) - 5) & "laccdb") = True Then Set objAcc = GetObject(PastePath & CopyFileName) objAcc.Quit '閉じる End If Else 'PastePathに存在しなければ処理しない WScript.Quit End If '★Unload内で呼び出す場合はここまでを消す★ '削除処理 'Quit後にlaccdbが消えるまでにラグがあるため、Quit直後にDeleteFileが実行されるとエラー(70:書き込みできません)が出る 'laccdbが存在しなくなるまで1秒ずつ処理を休ませる Do Until FSO.FileExists(PastePath & Left(CopyFileName, Len(CopyFileName) - 5) & "laccdb") = False WScript.Sleep 1000 Loop FSO.DeleteFile PastePath & CopyFileName Set objAcc = Nothing Set FSO = Nothing Set WS = Nothing
③本体にコードを入れる
以下のコードを自分で設置したコマンドボタン(閉じる処理)かUnloadに入れる。
Shell "WScript.exe VBSのフルパス"
ボタンを押した時の処理に入れた場合、タスクバーを右クリックしてデータベースを閉じるとVBSの処理を行わない。
Unloadから呼び出す場合は、削除用VBSの「★Unload内で~」の間を消さないとデータベースが再起動→終了という変な動きをする。