MErhaba arkadaşlar,
Ekteki veritabanımda faturaesle formunda bulunan listekutusundaki seçili herhangi bir alanı (örneğin faturano sütununda 3. satırı) fonksiyon tuşları yardımıyla kopyalamak istiyorum. Yani yapmak istediğim ilgili tabloda kopyalamak istediğim alanı bulup, sağ tuşa tıklayıp kopyala seçeneğini tıklama işlemini kısaltmak. Özetle üzeri seçili kaydın ilk sütununa CTRL+c yi bir fonksiyon tuşuna atamak istiyorum.

Örnekle izah edecek olursam; diyelim ki 3. satır seçili. Ben F5 tuşuna bastığımda, "deneme1" verisinin kopyalanmış olmasını istiyorum.
excel, outlook veya herhangi bir office uygulamasına sağ tuş tıklayıp yapıştır dediğimde bu verinin gelmesini istiyorum.


yardımlarınız için şimdiden teşekkürler.

Merhaba, 

1-) Formun "Tuş Önizleme" Özelliğini Evet olarak değiştir.

2-) Aşağıdaki kodları modüle kopyala ve modülü kaydet

Option Compare Database

Option Explicit



Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long

Private Declare Function EmptyClipboard Lib "user32.dll" () As Long

Private Declare Function CloseClipboard Lib "user32.dll" () As Long

Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long

Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long

Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long

Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long

Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long

Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long

Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long

Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long



Public Sub SetClipboard(sUniText As String)

    Dim iStrPtr As Long

    Dim iLen As Long

    Dim iLock As Long

    Const GMEM_MOVEABLE As Long = &H2

    Const GMEM_ZEROINIT As Long = &H40

    Const CF_UNICODETEXT As Long = &HD

    OpenClipboard 0&

    EmptyClipboard

    iLen = LenB(sUniText) + 2&

    iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen)

    iLock = GlobalLock(iStrPtr)

    lstrcpy iLock, StrPtr(sUniText)

    GlobalUnlock iStrPtr

    SetClipboardData CF_UNICODETEXT, iStrPtr

    CloseClipboard

End Sub



Public Function GetClipboard() As String

    Dim iStrPtr As Long

    Dim iLen As Long

    Dim iLock As Long

    Dim sUniText As String

    Const CF_UNICODETEXT As Long = 13&

    OpenClipboard 0&

    If IsClipboardFormatAvailable(CF_UNICODETEXT) Then

        iStrPtr = GetClipboardData(CF_UNICODETEXT)

        If iStrPtr Then

            iLock = GlobalLock(iStrPtr)

            iLen = GlobalSize(iStrPtr)

            sUniText = String$(iLen \ 2& - 1&, vbNullChar)

            lstrcpy StrPtr(sUniText), iLock

            GlobalUnlock iStrPtr

        End If

        GetClipboard = sUniText

    End If

    CloseClipboard

End Function

3-) Listeesle isimli liste kutusunun Tuşa Basılırken olayına aşağıdaki kodu ekle

   If KeyCode = vbKeyF5 Then

    

    For i = 0 To Listeesle.ListCount - 1

        If Listeesle.Selected(i) = True Then

        

            SetClipboard (Listeesle.Column(1, i))

            MsgBox (Listeesle.Column(1, i))



        End If

    Next

    

    End If

liste kutusunda satır seçip f5'e bastığında veriyi kopyalar.

f5 e bastığımda modülde Openclipboard'un üzeri seçili biçimde "sub of function not defined" uyarısı veriyor.

Modüldeki kodları aşağıdaki ile değiştirerek deneyiniz.

Option Compare Database

Option Explicit



Private Declare Function OpenClipboard Lib "user32" (ByVal Hwnd As Long) As Long

Private Declare Function CloseClipboard Lib "user32.dll" () As Long

Private Declare Function EmptyClipboard Lib "user32" () As Long

Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long

Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long

Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long

Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long

Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long

Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long

Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long

Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long



Public Sub SetClipboard(sUniText As String)

    Dim iStrPtr As Long

    Dim iLen As Long

    Dim iLock As Long

    Const GMEM_MOVEABLE As Long = &H2

    Const GMEM_ZEROINIT As Long = &H40

    Const CF_UNICODETEXT As Long = &HD

    OpenClipboard 0&

    EmptyClipboard

    iLen = LenB(sUniText) + 2&

    iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen)

    iLock = GlobalLock(iStrPtr)

    lstrcpy iLock, StrPtr(sUniText)

    GlobalUnlock iStrPtr

    SetClipboardData CF_UNICODETEXT, iStrPtr

    CloseClipboard

End Sub



Public Function GetClipboard() As String

    Dim iStrPtr As Long

    Dim iLen As Long

    Dim iLock As Long

    Dim sUniText As String

    Const CF_UNICODETEXT As Long = 13&

    OpenClipboard 0&

    If IsClipboardFormatAvailable(CF_UNICODETEXT) Then

        iStrPtr = GetClipboardData(CF_UNICODETEXT)

        If iStrPtr Then

            iLock = GlobalLock(iStrPtr)

            iLen = GlobalSize(iStrPtr)

            sUniText = String$(iLen \ 2& - 1&, vbNullChar)

            lstrcpy StrPtr(sUniText), iLock

            GlobalUnlock iStrPtr

        End If

        GetClipboard = sUniText

    End If

    CloseClipboard

End Function

Olmadı Ozan Bey, bin tane hata veriyor. Zaten çok elzem bir şey değil. Kalsın böyle. Tşkler ilginiz için.

Alıntı:bin tane hata veriyor

Hatalardan birini yazarsanız çözüm arayabiliriz. 135 konunuza çözüm bulduk.