XL 2010 Coller Presse-Papier dans module

'-------------------------------------------------
'Placer une chaine de caractères dans le Clipboard
'-------------------------------------------------
'Pour utiliser le type DataObject il faut avoir la référence de "Microsoft Forms 2.0 Object Library"
'dans les références du Projet VBA (VBA / Outils / References [/ Parcourir si besoin]).
'S'il faut parcourir, aller dans C:\Windows\SysWOW64\FM20.DLL pour trouver cette référence !
'-------------------------------------------------
Sub PutInClipBoard(Chaine As String)
    Dim DataObject As New MSForms.DataObject
    
    With DataObject
        .SetText Chaine
        .PutInClipBoard
    End With
    
    Set DataObject = Nothing
End Sub

'---------------------------
'Check the Clipboard content
'---------------------------
Function GetFromClipBoard() As String
    Dim DataObject As New MSForms.DataObject
    
    With DataObject
        .GetFromClipBoard
        On Error Resume Next
        GetFromClipBoard = .GetText
        On Error GoTo 0
    End With
    
    Set DataObject = Nothing
End Function

'---------------------------
'Effacement du presse-papier
'---------------------------
Sub ClearClipboard()
    Dim DataObject As New MSForms.DataObject
    
    With DataObject
        .SetText ""
        .PutInClipBoard
    End With
    
    Set DataObject = Nothing
End Sub

Sub MaListBoxEnClipBoard()
    Call CopierListBoxEnClipBoard(ActiveSheet.ListBox1)
    'Call CopierListBoxEnClipBoard(ActiveSheet.ComboBox1)
 
    'UserForm1.Show vbModeless
    'Call CopierListBoxEnClipBoard(UserForm1.ListBox1)
    'Call CopierListBoxEnClipBoard(UserForm1.ComboBox1)
End Sub

'-------------------------------------------------------
'Copie le contenu d'une ListBox ou ComboBox en ClipBoard
'-------------------------------------------------------
Sub CopierListBoxEnClipBoard(ListBoxOuComboBox As Object, _
                             Optional SéparateurLigne As String = vbCrLf, _
                             Optional SéparateurColonne As String = ", ")
    Dim ObjBox As Object
    Dim Texte As String
    Dim i As Integer
    Dim j As Integer
 
    'Contrôle ListBox ou ComboBox
    If Not (TypeOf ListBoxOuComboBox Is MSForms.ListBox Or TypeOf ListBoxOuComboBox Is MSForms.ComboBox) Then
        MsgBox "Erreur fonction CopierListBoxEnClipBoard()" & vbCrLf & _
               "L'argument n'est pas une ListBox ou une ComboBox."
        Exit Sub
    End If
 
    'Initialisation
    Texte = ""

    'Le Parent est une feuille => OLEObject
    If TypeOf ListBoxOuComboBox.Parent Is Worksheet Then
        Set ObjBox = Workbooks(ListBoxOuComboBox.Parent.Parent.Name) _
                    .Worksheets(ListBoxOuComboBox.Parent.Name) _
                    .OLEObjects(ListBoxOuComboBox.Name).Object
    
    'Le Parent n'est pas une feuille => UserForm Control
    Else
        Set ObjBox = ListBoxOuComboBox
    End If
 
    'Scan des lignes de la ListBox
    For i = 0 To ObjBox.ListCount - 1
        Texte = Texte & IIf(Len(Texte), SéparateurLigne, "")
    
        'Scan des colonnes de la ListBox
        For j = 0 To ObjBox.ColumnCount - 1
           Texte = Texte & IIf(j > 0, SéparateurColonne, "") & ObjBox.List(i, j)
        Next j
    Next i
 
    'Mise en ClipBoard
    Call PutInClipBoard(Texte)
End Sub

Dim repertoire$, Tb$()

Private Sub CbCopier_Click()
    If ListBox2.ListIndex = -1 Then MsgBox "Une ligne doit être sélectionnée dans ListBox2...": Exit Sub
    With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' DataObject en late binding
        .SetText ListBox2
        .PutInClipboard
    End With
    [D3].Select
    ActiveSheet.Paste 'pour tester, colle le contenu du presse-papiers en D3
End Sub

Private Sub TextBox1_Change()
    If Tb(0) <> "" Then ListBox1.List = Filter(Tb, TextBox1, True, vbTextCompare)
End Sub

Private Sub UserForm_Initialize() 'Sylvanu
    Dim MyFile$, n&
    repertoire = ThisWorkbook.Path & "\1MesMacros\"
    MyFile = Dir(repertoire)
    ListBox1.Clear
    ReDim Tb(0)
    While MyFile <> ""
        If InStr("/.bas/.txt/.cls/.frm/", "/" & Right(MyFile, 4) & "/") Then
            ReDim Preserve Tb(n)
            Tb(n) = MyFile
            n = n + 1
        End If
        MyFile = Dir
    Wend
    If n Then ListBox1.List = Tb
End Sub

Private Sub ListBox1_Click()
    Dim IdFile%, TextLine$, a$(), n&
    ListBox2.Clear
    IdFile = FreeFile
    Open repertoire & "\" & ListBox1 For Input As #IdFile
    While Not EOF(IdFile)
        Line Input #IdFile, TextLine
        ReDim Preserve a(n): a(n) = TextLine: n = n + 1
    Wend
    If n Then ListBox2.List = a
    Close #IdFile
End Sub

Private Sub CbCopier_Click()
    If ListBox2.ListCount = 0 Then Exit Sub
    Dim a, i&, x$
    a = ListBox2.List
    For i = 0 To UBound(a)
        x = x & vbLf & a(i, 0) 'concaténation avec renvoi à la ligne
    Next
    With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' DataObject en late binding
        .SetText Mid(x, 2)
        .PutInClipboard
    End With
    With [D3]
        .Select
        .Parent.Paste 'pour tester, colle le contenu du presse-papiers en D3 et cellules suivantes
        .Offset(UBound(a) + 1).Resize(Rows.Count - UBound(a) - .Row).ClearContents 'RAZ en dessous
    End With
End Sub

With CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}") ' DataObject en late binding

Private Sub CbCopier_Click()
    If ListBox2.ListCount = 0 Then Exit Sub
    With Application
        CreateObject("htmlfile").parentWindow.clipboardData.setData "Text", Join(.Transpose(.Index(ListBox2.List, 0, 1)), vbCrLf)
    End With

    With [D3]
        .Select
        .Parent.Paste    'pour tester, colle le contenu du presse-papiers en D3 et cellules suivantes
        .Offset(ListBox2.ListCount + 1).Resize(Rows.Count - ListBox2.ListCount - .Row).ClearContents    'RAZ en dessous
    End With
End Sub

Private Sub UserForm_Initialize()
    Dim n&, Dossier As Object, Fichier As Object, chemin As String
    ListBox1.Clear
    ReDim Tb(0)
    'Chemin du dossier à analyser (à adapter au besoin)
    chemin = ThisWorkbook.Path & "\1MesMacros"
    'Définition de la variable
    Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(chemin)
    ' Boucle sur les fichiers
    For Each Fichier In Dossier.Files
        If InStr("/.bas/.txt/.cls/.frm/", "/" & Right(Fichier, 4) & "/") Then
            ReDim Preserve Tb(n)
            Tb(n) = Fichier.Name
            n = n + 1
        End If
        If n Then ListBox1.List = Tb
    Next
End Sub