صفحه 2 از 2 نخستنخست 12
نمایش نتایج: از شماره 11 تا 11 , از مجموع 11

موضوع: Right Click در TextBox

  1. #11

    آخرین بازدید
    2023/01/01
    تاریخ عضویت
    January 2016
    نوشته ها
    1
    امتیاز
    10
    سپاس
    0
    سپاس شده
    0 در 0 پست
    تعیین سطح نشده است

    نقل قول نوشته اصلی توسط shamsololama نمایش پست ها
    با درود فراوان
    البته راه های که گفتم راحت بود و برای رسیدن به آن چیزی که شما دقیقا همون منظور شماست نیاز به نوشتن تابع هست که من آن را برای شما می نویسم که اگر برای استفاده از آن مشکلی بود بگو و یا تماس بگیر
    اول این تابه را در تکست باکس مورد نظر بگذارید و سپس تابع بعدی هم در یک ماژول بنویسد (کپی کنید)
    کد:
    Private Sub TextBox1_MouseDown(ByVal Button As Integer, _
    ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    If Button = 2 Then
    Call ShowPopup(Me, Me.Caption, X, Y)
    End If
    End Sub

    -تابع--------------------------------------------------------------------------------------

    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

    Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
    End Type

    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

    Private Type POINTAPI
    X As Long
    Y As Long
    End Type

    Private Const TPM_LEFTALIGN = &H0&
    Private Const TPM_TOPALIGN = &H0
    Private Const TPM_RETURNCMD = &H100
    Private Const TPM_RIGHTBUTTON = &H2&

    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

    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

    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

    click_flag = click_flag + 1

    If (click_flag Mod 2 <> 0) Then Exit Sub

    Set oControl = oForm.ActiveControl

    If X > oControl.Width Or Y > oControl.Height Or X < 0 Or Y < 0 Then Exit Sub

    FormCaption = strCaption


    Call EnableMenuItems(oForm)

    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 oControl = oForm.ActiveControl


    Set oData = New DataObject


    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


    If Len(oControl.Text) > 0 Then
    SelectAll_Enabled = MFS_ENABLED
    Else
    SelectAll_Enabled = MFS_GRAYED
    End If


    oData.GetFromClipboard


    testClipBoard = oData.GetText

    If Err.Number = 0 Then
    Paste_Enabled = MFS_ENABLED
    Else
    Paste_Enabled = MFS_GRAYED
    End If


    Err.Clear


    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


    #If VBA6 Then
    form_hwnd = FindWindow("ThunderDFrame", FormCaption)
    #Else
    form_hwnd = FindWindow("ThunderXFrame", FormCaption)
    #End If

    GetCursorPos oPointAPI


    menu_hwnd = CreatePopupMenu

    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


    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


    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


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


    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


    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


    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

    GetSelection = TrackPopupMenu _
    (menu_hwnd, _
    TPM_LEFTALIGN Or TPM_TOPALIGN Or TPM_RETURNCMD Or TPM_RIGHTBUTTON, _
    oPointAPI.X, oPointAPI.Y, _
    0, form_hwnd, oRect)


    DestroyMenu menu_hwnd
    End Function
    با سلام
    متاسفانه این کد برای من ارور میده میشه راهنمایی کنید؟
    ممنون میشم

  2.  


صفحه 2 از 2 نخستنخست 12

اطلاعات موضوع

کاربرانی که در حال مشاهده این موضوع هستند

در حال حاضر 1 کاربر در حال مشاهده این موضوع است. (0 کاربران و 1 مهمان ها)

موضوعات مشابه

  1. ثبت تاريخ در textbox فرم اکسل
    توسط bakhshism در انجمن سوالات پیرامون ويژوال بيسيك - VBA Questions
    پاسخ ها: 4
    آخرين نوشته: 2012/11/15, 14:59
  2. Auto filter in vba with a textbox
    توسط safaei.mehdi@mapnablade.com در انجمن سوالات پیرامون ويژوال بيسيك - VBA Questions
    پاسخ ها: 6
    آخرين نوشته: 2012/09/03, 15:09
  3. نمایش خودکار تاریخ شمسی در textbox
    توسط sohrabahmadi در انجمن سوالات پیرامون ويژوال بيسيك - VBA Questions
    پاسخ ها: 2
    آخرين نوشته: 2012/06/09, 17:43
  4. textbox
    توسط sonbol در انجمن سوالات پیرامون ويژوال بيسيك - VBA Questions
    پاسخ ها: 1
    آخرين نوشته: 2012/03/13, 15:19
  5. استفاده از حلقه در TextBox
    توسط hpcompaq6720s در انجمن سوالات پیرامون ويژوال بيسيك - VBA Questions
    پاسخ ها: 2
    آخرين نوشته: 2011/07/12, 13:22

بازدید کنندگان با جستجو های زیر این صفحه را پیدا کرده اند

انجمن اكسل ايران , اكسل , اكسس , سوال و جواب اكسل , سوال اكسس , انجمن اكسل ايران , توابع اكسل, آموزش اكسل, آموزش اكسس, VBA, ويژوال بيسيك

علاقه مندی ها (Bookmarks)

مجوز های ارسال و ویرایش

  • شما نمیتوانید موضوع جدیدی ارسال کنید
  • شما امکان ارسال پاسخ را ندارید
  • شما نمیتوانید فایل پیوست کنید.
  • شما نمیتوانید پست های خود را ویرایش کنید
  •  
  • BB code ها فعال هستند
  • شکلک ها فعال هستند
  • کد [IMG] فعال است
  • کد [VIDEO] فعال است
  • کد HTML غیر فعال است
با ما در تماس باشيد