ListBoxCopy.cls #1

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ListBoxCopy"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

' This class provides a right-click Copy menu for use on Forms
' Note that the form needs to provide a Main menu with a Copy submenu
' (Used during standard menu editing for form)

Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalHandle Lib "kernel32" (wMem As Any) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long

Private Const GMEM_MOVEABLE = &H2

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
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)

Private Declare Function FindWindowA Lib "user32" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Private Const CF_TEXT = 1
Private Const CF_UNICODETEXT = 13

Private WithEvents m_Listbox As MSForms.ListBox
Attribute m_Listbox.VB_VarHelpID = -1
Private m_Form As MSForms.UserForm

Public Sub Initialize(f As MSForms.UserForm, l As MSForms.ListBox)
    Set m_Form = f
    Set m_Listbox = l
End Sub


Private Sub m_Listbox_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    ' Trap Ctrl+C and treat as Edit Copy
    On Error GoTo Error_Block
    Dim t As Tracker: Set t = GStackTrace.Enter(TypeName(Me), "m_Listbox_KeyDown")
    Dim ShiftDown As Boolean
    Dim AltDown As Boolean
    Dim CtrlDown As Boolean
    
    ShiftDown = (Shift And vbShiftMask) > 0
    AltDown = (Shift And vbAltMask) > 0
    CtrlDown = (Shift And vbCtrlMask) > 0
   
    If KeyCode = vbKeyC And CtrlDown And Not ShiftDown And Not AltDown Then
        CopyListBoxSelectionsToClipboard m_Listbox
    ElseIf KeyCode = vbKeyA And CtrlDown And Not ShiftDown And Not AltDown Then
        ' Select all items
        Dim i As Integer
        For i = 0 To m_Listbox.ListCount - 1
            m_Listbox.Selected(i) = True
        Next
    End If
    Exit Sub

Error_Block:
    t.Report
End Sub

Private Sub UnicodeCopyToClipBoard(Msg As String)
    Dim t As Tracker: Set t = GStackTrace.Enter(TypeName(Me), "UnicodeCopyToClipBoard")
    Dim Result As Long
    Dim hGlb As Long
    Dim lpps As Long
    Dim hwndForm As Long
    
    hwndForm = FindWindowA("ThunderDframe", m_Form.Caption)

    ' We have to use API routines to ensure Unicode handled OK
    If OpenClipboard(hwndForm) Then
        EmptyClipboard
        
        Msg = Msg & vbNullChar
        hGlb = GlobalAlloc(GMEM_MOVEABLE, Len(Msg) * 2) ' Unicode is 2 bytes per char
        lpps = GlobalLock(hGlb)
        CopyMemory ByVal lpps, ByVal StrPtr(Msg), Len(Msg) * 2
        GlobalUnlock hGlb
        Result = SetClipboardData(CF_UNICODETEXT, hGlb)
        CloseClipboard
        
        'Note Clipboard does GlobalFree on hGlb
        If Result = vbNull Then
            err.Raise vbObjectError + 999, "UnicodeCopyToClipBoard", "Copy to clipboard failed!"
        End If
    End If

End Sub

Private Sub CopyListBoxSelectionsToClipboard(l As MSForms.ListBox)
    Dim x As Long
    Dim AccumulatedText As String
    
    With l
        For x = 0 To .ListCount - 1
            If .Selected(x) = True Then
                AccumulatedText = AccumulatedText & vbNewLine & .list(x)
            End If
        Next
    End With
    AccumulatedText = Mid$(AccumulatedText, Len(vbNewLine) + 1)
    
    If WindowsNTorGreater() Then
        UnicodeCopyToClipBoard AccumulatedText
    Else
        Clipboard.Clear
        Clipboard.SetText AccumulatedText, CF_TEXT
    End If
    
End Sub


Private Sub m_Listbox_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    On Error GoTo Error_Block
    Dim t As Tracker: Set t = GStackTrace.Enter(TypeName(Me), "m_Listbox_MouseUp")
    ' See if right click and display appropriate menu if so
    Dim MenuChosen As Long
    
    If Button = vbRightButton Then
        Dim omenu As PopupMenu
        Set omenu = New PopupMenu
        MenuChosen = omenu.Popup("Copy")
        If MenuChosen = 1 Then
            CopyListBoxSelectionsToClipboard m_Listbox
        End If
    End If
    
    Exit Sub
    
Error_Block:
    t.Report
End Sub