Option Compare Database
Option Explicit

Const VK_SNAPSHOT = &H2C
Private Declare Sub keybd_event Lib "USER32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
'Windows98ではGetLongPathNameでパス名を取得できます。
'Declare Function GetLongPathName Lib "kernel32" Alias "GetLongPathNameA" (ByVal lpszShortPath As String, ByVal lpszLongPath As String, ByVal nBufferLength As Long) As Long
Dim ThisVer As String
Dim ThisMdb As String, ThisMdbName As String, ThisPath As String
Dim dbs As Database

Function ScreenCapture(bScan As Byte)
    'bScan
    '       0:アクティブフォーム全体をキャプチャー
    '       1:スクリーン全体をキャプチャー
    Static ClickFlg As Boolean
    Dim l As Long
    
    If ClickFlg Then Exit Function
    ClickFlg = True
    
    DoCmd.Hourglass True
    
    '新規レコード追加
    DoCmd.GoToRecord , , acNewRec
    
    '画像はクリップボード上にあります。
    keybd_event VK_SNAPSHOT, bScan, 0, 0
    
    Me!obj.SetFocus
    'SetFocusが有効になるまで待ち合わせ(最初のacCmdPasteがエラーになります)
    On Error Resume Next
    '貼り付け
    DoCmd.RunCommand acCmdPaste
    If Err <> 0 Then
        MsgBox "貼り付けエラーです。もう一度ボタンをクリックしてください m(__)m", vbExclamation
        Err.Clear
    End If
    On Error GoTo 0
    
    DoCmd.Hourglass False
    ClickFlg = False
End Function

Private Sub Form_Close()
    Dim rec As String, f As Integer, strTemp As String
    
    If Dir$(ThisPath & "MdbCmpt.mde") = "" Then Exit Sub

    dbs.Execute "delete * from tbl"
    Set dbs = Nothing
    
    rec = ThisMdbName & "の最適化を行ないますか？"
    If ThisVer = "9.0" Then
        rec = rec & vbCr & ThisPath & " にAccess2000用のMdbCmpt.mdeがなければなりません。"
        rec = rec & vbCr & "Access2000用のMdbCmpt.mdeは mdbcmpt2000.lzh を解凍してください。"
    End If
    
    If MsgBox(rec, vbQuestion + vbYesNo) = vbYes Then
        'MdbCmpt.mdeに渡すパラメータファイル名
        strTemp = ThisPath & "\Mdb_Cmpt.dat"
        
        f = FreeFile
        Open strTemp For Output As #f
        
        '処理終了メッセージを出さない
        rec = "/nomsg" & vbCrLf
        
        '処理後パラメータファイルを削除する
        rec = rec & "/kill" & vbCrLf
        
        'MdbCmpt.mdeに表示するメッセージ
        rec = rec & "/name=" & ThisMdbName & "の最適化" & vbCrLf
        
        '処理後に戻るMDB。処理後の戻り先が不必要であれば/returnto=を指定しない。
        'MDB以外のファイルを指定すれば、ファイル拡張子に関連付けされたアプリを起動する。
        rec = rec & "/returnto=" & ThisMdb & vbCrLf
        
        '最適化するMDB(MDE)。先頭に/を付けなければバックアップを行なう（詳細はmdbcmpt.txtを参照）。
        rec = rec & "/" & ThisMdb & vbCrLf
        Print #f, rec
        Close #f
        Shell "msaccess.exe " & ThisPath & "MdbCmpt.mde ;/return /file=" & strTemp, vbMaximizedFocus
        Application.Quit
    
    End If
End Sub

Private Sub Form_Open(Cancel As Integer)
    
    Set dbs = CurrentDb
    'このMdbのフルパス
    ThisMdb = dbs.Name
    
    'このMdbの名前
    ThisMdbName = Dir$(ThisMdb)
    
    'このMdbのパス（最後にが\つく）
    ThisPath = Left$(ThisMdb, Len(ThisMdb) - Len(ThisMdbName))
        
    'このMdbのAccessバージョン
    ThisVer = SysCmd(acSysCmdAccessVer)
    Me!ver = "Access" & IIf(ThisVer = "8.0", "97", IIf(ThisVer = "9.0", "2000", "????"))
    Me!obj.SetFocus
End Sub