Option Compare Database
Option Explicit

Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
'API で Windowsの描画を停止する。Application.Echo,Paintingプロパティを使っても表示がちらつく場合に有効です。
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long

Dim cdbs As Database
Dim rst As Recordset
Dim intMouseY '現在のマウスY座標（レコードセレクタクリック時に設定）

Private Sub LsClipboardClear()
    'ClipboardをClear
    Dim rtn As Long
    
    rtn = OpenClipboard(0&)
    rtn = EmptyClipboard()
    rtn = CloseClipboard()
End Sub

Private Sub LsLockWindowUpdate(ShowFlg As Boolean)
   'API で Windowsの描画を停止する
   'Application.Echo,Paintingプロパティを使っても表示がちらつく場合に有効です。
   If ShowFlg Then
      LockWindowUpdate 0 '再描画
   Else
      LockWindowUpdate Application.hWndAccessApp '描画停止
   End If
End Sub

Private Sub cmdCopy_Click()
    Dim ErrMsg As String
    
    ErrMsg = RecCopy
    If ErrMsg > "" Then MsgBox ErrMsg, vbCritical
End Sub

Private Sub cmdLockWindowUpdate_Click()
    Dim ErrMsg As String
    
    LsLockWindowUpdate False
    ErrMsg = RecCopy
    LsLockWindowUpdate True
    If ErrMsg > "" Then MsgBox ErrMsg, vbCritical
End Sub

Private Sub cmdEcho_Click()
    Dim ErrMsg As String
    
    Application.Echo False
    ErrMsg = RecCopy
    Application.Echo True
    If ErrMsg > "" Then MsgBox ErrMsg, vbCritical
End Sub

Private Sub cmdPainting_Click()
    Dim ErrMsg As String
    
    Me.Painting = False
    ErrMsg = RecCopy
    Me.Painting = True
    If ErrMsg > "" Then MsgBox ErrMsg, vbCritical
End Sub

Private Function RecCopy() As String
    Dim wid As Long
    Dim rst As Recordset
    Dim BookMk As Variant
    Dim r As Integer
    On Error GoTo Err_RecCopy_Click
    
    'カレントレコードの上にレコードを挿入しカレントレコードを複製します。
    'クエリーに式が含まれる場合は
    With DoCmd
        .RunCommand acCmdSelectRecord
        .RunCommand acCmdCopy
        .RunCommand acCmdRecordsGoToNew
        .RunCommand acCmdSelectRecord
        .RunCommand acCmdPaste  'クエリーに式が含まれる場合はacCmdPasteできません。
    End With
    
    With Me
        !f7 = f1 * CLng(Rnd * 1000)
        !f8 = f2 * CLng(Rnd * 1000)
        !f9 = f3 * CLng(Rnd * 1000)
        !f10 = f4 * CLng(Rnd * 1000)
        !f11 = f5 * CLng(Rnd * 1000)
        !f12 = f6 * CLng(Rnd * 1000)
        !f13 = f7 * CLng(Rnd * 1000)
        !f14 = f8 * CLng(Rnd * 1000)
        !f15 = f9 * CLng(Rnd * 1000)
        !f16 = f10 * CLng(Rnd * 1000)
        !f17 = f11 * CLng(Rnd * 1000)
        !f18 = f12 * CLng(Rnd * 1000)
        !seq = !seq - 0.00001 'ソートキーseqを設定します。
        wid = !id
        .Requery            '並べ替えます。
        !id.SetFocus       'idにフォーカスを移し、（実用ではこの項目はコントロールの後ろに隠します）
        DoCmd.FindRecord wid, acStart, acDown   '複製したレコードに移動します。このままではフォームの最初のレコードになってしまいます。
        
        'どのレコードセレクタがクリックされたか（フォームの何番目のレコードか）
        r = (intMouseY - Me.Section(acHeader).Height) \ Me.Section(acDetail).Height
        BookMk = Me.Bookmark
        Set rst = Me.RecordsetClone
        On Error Resume Next
        rst.Move -r, BookMk '上にスクロールさせます。
        Me.Bookmark = rst.Bookmark
        If Err = 0 Then
            rst.Move r, rst.Bookmark ''複製したレコード位置に移動します。
            Me.Bookmark = rst.Bookmark
        End If
        Err.Clear
        Set rst = Nothing
    End With
Exit_RecCopy_Click:
    LsClipboardClear        'ClipboardをクリアしないとAccessのメッセージが出ます。
                            'SetWarnings メソッドでメッセージが出なくなりますがメモリの浪費は避けられません。
Exit Function

Err_RecCopy_Click:
    RecCopy = Error
    Resume Exit_RecCopy_Click
End Function

Private Sub Form_AfterUpdate()
    If Me!seq = 0 Then
        Application.Echo False
        Set rst = cdbs.OpenRecordset("select max(seq) as mx from Dat")
        Me!seq = Nz(rst!mx) + 1
        rst.Close
        Set rst = Nothing
        Application.Echo True
    End If
End Sub

Private Sub Form_Close()
    Set cdbs = Nothing
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    'フォームヘッダー,フォームフッターをクリックしたら複製はできません。
    If Me.Section(acHeader).Height < Y And Y < (Me.InsideHeight - Me.Section(acFooter).Height) Then
        intMouseY = Y
        Me!cmdLockWindowUpdate.Enabled = True
        Me!cmdEcho.Enabled = True
        Me!cmdPainting.Enabled = True
        Me!cmdCopy.Enabled = True
    Else
        BtnNotUse
    End If
End Sub

Function BtnNotUse()
    '複製ボタンを使えなくします。
    'すべてのコントロールの「GotFocus イベント」または「Click イベント」から呼ばれます。
    intMouseY = 0
    Me!cmdLockWindowUpdate.Enabled = False
    Me!cmdEcho.Enabled = False
    Me!cmdPainting.Enabled = False
    Me!cmdCopy.Enabled = False
End Function

Private Sub Form_Open(Cancel As Integer)
    Set cdbs = CurrentDb
End Sub