textboxtaki veri sağ tıklama ile kopyalansın

[harziyan]

öncelikle mevzuyu aradığımı ve bulamadığımı ifade etmek istiyorum.

sorunuma gelince userformdaki herhangi bir texboxdaki verinin sağ tık ile kopyalanmasını istiyorum. veya kes, kopyala, yapıştır üçlüsünün sağ tık ile aktifleşmesini istiyorum.

 

[Seyit Tiken]

Aşağıdaki kod, Text'teki veriyi Sürükle/Bırak için geçerlidir. Hücrelerde olduğu gibi.

Private Sub CommandButton1_Click()
TextBox1.DragBehavior = 1
End Sub

 

[ileriexcel]

'tekboxta sağ tuş yapma kopyala yapıştır gibi özellikler

Set oControl = oForm.ActiveControl


'text kodu

Private Sub txtKod_MouseDown(ByVal Button As Integer, _
ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)

' If right-button clicked
If Button = 2 Then
Call ShowPopup(Me, Me.Caption, X, Y)
End If


End Sub

'modül kodu

Option Explicit

' Required API declarations
Private Declare Function CreatePopupMenu Lib "user32" () As Long
Private Declare Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO) As Long
Private Declare Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As RECT) As Long
Private Declare Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

' Type required by TrackPopupMenu although this is ignored !!
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

' Type required by InsertMenuItem
Private Type MENUITEMINFO
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As String
cch As Long
End Type

' Type required by GetCursorPos
Private Type POINTAPI
X As Long
Y As Long
End Type

' Constants required by TrackPopupMenu
Private Const TPM_LEFTALIGN = &H0&
Private Const TPM_TOPALIGN = &H0
Private Const TPM_RETURNCMD = &H100
Private Const TPM_RIGHTBUTTON = &H2&

' Constants required by MENUITEMINFO type
Private Const MIIM_STATE = &H1
Private Const MIIM_ID = &H2
Private Const MIIM_TYPE = &H10
Private Const MFT_STRING = &H0
Private Const MFT_SEPARATOR = &H800
Private Const MFS_DEFAULT = &H1000
Private Const MFS_ENABLED = &H0
Private Const MFS_GRAYED = &H1

' Contants defined by me for menu item IDs
Private Const ID_Cut = 101
Private Const ID_Copy = 102
Private Const ID_Paste = 103
Private Const ID_Delete = 104
Private Const ID_SelectAll = 105


' Variables declared at module level
Private FormCaption As String
Private Cut_Enabled As Long
Private Copy_Enabled As Long
Private Paste_Enabled As Long
Private Delete_Enabled As Long
Private SelectAll_Enabled As Long



Public Sub ShowPopup(oForm As UserForm, strCaption As String, X As Single, Y As Single)

Dim oControl As MSForms.TextBox
Static click_flag As Long

' The following is required because the MouseDown event
' fires twice when right-clicked !!
click_flag = click_flag + 1

' Do nothing on first firing of MouseDown event
If (click_flag Mod 2 <> 0) Then Exit Sub

' Set object reference to the textboxthat was clicked
Set oControl = oForm.ActiveControl

' If click is outside the textbox, do nothing
If X > oControl.Width Or Y > oControl.Height Or X < 0 Or Y < 0 Then Exit Sub

' Retrieve caption of UserForm for use in FindWindow API
FormCaption = strCaption

' Call routine that sets menu items as enabled/disabled
Call EnableMenuItems(oForm)

' Call function that shows the menu and return the ID
' of the selected menu item. Subsequent action depends
' on the returned ID.
Select Case GetSelection()
Case ID_Cut
oControl.Cut
Case ID_Copy
oControl.Copy
Case ID_Paste
oControl.Paste
Case ID_Delete
oControl.SelText = ""
Case ID_SelectAll
With oControl
.SelStart = 0
.SelLength = Len(oControl.Text)
End With
End Select

End Sub

Private Sub EnableMenuItems(oForm As UserForm)

Dim oControl As MSForms.TextBox
Dim oData As DataObject
Dim testClipBoard As String

On Error Resume Next

' Set object variable to clicked textbox
Set oControl = oForm.ActiveControl

' Create DataObject to access the clipboard
Set oData = New DataObject

' Enable Cut/Copy/Delete menu items if text selected
' in textbox
If oControl.SelLength > 0 Then
Cut_Enabled = MFS_ENABLED
Copy_Enabled = MFS_ENABLED
Delete_Enabled = MFS_ENABLED
Else
Cut_Enabled = MFS_GRAYED
Copy_Enabled = MFS_GRAYED
Delete_Enabled = MFS_GRAYED
End If

' Enable SelectAll menu item if there is any text in textbox
If Len(oControl.Text) > 0 Then
SelectAll_Enabled = MFS_ENABLED
Else
SelectAll_Enabled = MFS_GRAYED
End If

' Get data from clipbaord
oData.GetFromClipboard

' Following line generates an error if there
' is no text in clipboard
testClipBoard = oData.GetText

' If NO error (ie there is text in clipboard) then
' enable Paste menu item. Otherwise, diable it.
If Err.Number = 0 Then
Paste_Enabled = MFS_ENABLED
Else
Paste_Enabled = MFS_GRAYED
End If

' Clear the error object
Err.Clear

' Clean up object references
Set oControl = Nothing
Set oData = Nothing

End Sub

Private Function GetSelection() As Long

Dim menu_hwnd As Long
Dim form_hwnd As Long
Dim oMenuItemInfo1 As MENUITEMINFO
Dim oMenuItemInfo2 As MENUITEMINFO
Dim oMenuItemInfo3 As MENUITEMINFO
Dim oMenuItemInfo4 As MENUITEMINFO
Dim oMenuItemInfo5 As MENUITEMINFO
Dim oMenuItemInfo6 As MENUITEMINFO
Dim oRect As RECT
Dim oPointAPI As POINTAPI

' Find hwnd of UserForm - note different classname
' Word 97 vs Word2000
#If VBA6 Then
form_hwnd = FindWindow("ThunderDFrame", FormCaption)
#Else
form_hwnd = FindWindow("ThunderXFrame", FormCaption)
#End If

' Get current cursor position
' Menu will be drawn at this location
GetCursorPos oPointAPI

' Create new popup menu
menu_hwnd = CreatePopupMenu

' Intitialize MenuItemInfo structures for the 6
' menu items to be added

' Cut
With oMenuItemInfo1
.cbSize = Len(oMenuItemInfo1)
.fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
.fType = MFT_STRING
.fState = Cut_Enabled
.wID = ID_Cut
.dwTypeData = "Cut"
.cch = Len(.dwTypeData)
End With

' Copy
With oMenuItemInfo2
.cbSize = Len(oMenuItemInfo2)
.fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
.fType = MFT_STRING
.fState = Copy_Enabled
.wID = ID_Copy
.dwTypeData = "Copy"
.cch = Len(.dwTypeData)
End With

' Paste
With oMenuItemInfo3
.cbSize = Len(oMenuItemInfo3)
.fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
.fType = MFT_STRING
.fState = Paste_Enabled
.wID = ID_Paste
.dwTypeData = "Paste"
.cch = Len(.dwTypeData)
End With

' Separator
With oMenuItemInfo4
.cbSize = Len(oMenuItemInfo4)
.fMask = MIIM_TYPE
.fType = MFT_SEPARATOR
End With

' Delete
With oMenuItemInfo5
.cbSize = Len(oMenuItemInfo5)
.fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
.fType = MFT_STRING
.fState = Delete_Enabled
.wID = ID_Delete
.dwTypeData = "Delete"
.cch = Len(.dwTypeData)
End With

' SelectAll
With oMenuItemInfo6
.cbSize = Len(oMenuItemInfo6)
.fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
.fType = MFT_STRING
.fState = SelectAll_Enabled
.wID = ID_SelectAll
.dwTypeData = "Select All"
.cch = Len(.dwTypeData)
End With

' Add the 6 menu items
InsertMenuItem menu_hwnd, 1, True, oMenuItemInfo1
InsertMenuItem menu_hwnd, 2, True, oMenuItemInfo2
InsertMenuItem menu_hwnd, 3, True, oMenuItemInfo3
InsertMenuItem menu_hwnd, 4, True, oMenuItemInfo4
InsertMenuItem menu_hwnd, 5, True, oMenuItemInfo5
InsertMenuItem menu_hwnd, 6, True, oMenuItemInfo6

' Return the ID of the item selected by the user
' and set it the return value of the function
GetSelection = TrackPopupMenu _
(menu_hwnd, _
TPM_LEFTALIGN Or TPM_TOPALIGN Or TPM_RETURNCMD Or TPM_RIGHTBUTTON, _
oPointAPI.X, oPointAPI.Y, _
0, form_hwnd, oRect)

' Destroy the menu
DestroyMenu menu_hwnd

End Function

 

[Mahmut Bayram]

Bunu modüle

Option Explicit
Sub MakePopUp()
     'Remove any old instance of MyPopUp
    On Error Resume Next
    CommandBars("MyPopUp").Delete
    On Error GoTo 0
     
    With CommandBars.Add(Name:="MyPopUp", Position:=msoBarPopup)
        .Controls.Add Type:=msoControlButton, ID:=19
        .Controls.Add Type:=msoControlButton, ID:=22
    End With
End Sub
Sub KillPopUp()
    On Error Resume Next
    CommandBars("MyPopUp").Delete
    On Error GoTo 0
End Sub

Bunu da UserFormun kod bölümüne yapıştırınız.

Option Explicit
Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    MakePopUp
    If Button = 2 Then
        Application.CommandBars("MyPopUp").ShowPopup
    End If
End Sub

 

[Ali]

Textbox'ta kes-kopyala-yapıştır ile ilgili API' li bir uygulamada ben ekleyeyim.

 

[harziyan]

ilgilenen herkese candan teşekkürler

 

[Levent Menteşoğlu]

Foruma bug&#252;n ekledi&#287;im APIsiz klasik VBA nesneleri ile yap&#305;lm&#305;&#351; uygulamay&#305;da inceleyebilirsiniz.

Textbox &#220;zerinde Sa&#287;-Klik Kes-Kopyala-Yap&#305;&#351;t&#305;r Men&#252;s&#252; olu&#351;turma

Not: Bu arada Sn Partner'in &#246;nerdi&#287;i kodlarda &#231;ok g&#252;zel, dahada geli&#351;tirilerek farkl&#305; ama&#231;lar i&#231;inde kullan&#305;labilir.

 

[Erdem Akdemir]

Merhaba,

Ali bey'in eklediği API elinde olan varsa, paylaşabilir mi.

 

[Murat OSMA]

Önerebilirim;

 

[Erdem Akdemir]

Murat hocam hızır gibi yetişiyorsun.

Mahmut bayram'ın eklediği kod neden bende çalışmadı. Menü çıktı ama işlevler çalışmıyor, kopyala dediğimde sayfadaki hücreyi kopyalıyor.

1 tane textbox'ta kullanıcam, kod kısa ve güzel geldi gözüme

 

[Murat OSMA]

Rica ederim.

Mahmut Bey'in önerdiği makroda; sayfada bir menü oluşturuluyor ve TextBox üzerindeki sağ tıklamada bu menü çağrılıp görünür hâle getiriliyor ama işlemi sayfa üzerinde yapıyor.

Size ben daha gelişmiş bir örnek göndereyim.

Not: Gizlenmiş sayfaya bakarsanız istediğiniz tarzda örneği geliştirebilirsiniz. Takıldığınız yerlerde yardımcı olurum.