Discussion :

[jurassic pork]

hello,
Le problème consiste à copier du texte formaté (avec couleurs de caractères, caractères gras , soulignés etc...)dans un contrôle de type RichtextBox, ici c'est le contrôle MSREdit Class qui est utilisé.
Pour réaliser cette action en VBA, j'utiliser un copier de la cellule et j'envoie un message de coller au contrôle MSREdit.
Mais voilà, pour l'instant lorsque j'exécute le code suivant :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
 
Private Const WM_COPY = &H301
Private Const WM_PASTE = &H302
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal _
    hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
    lParam As Any) As Long
Sub Bouton2_Cliquer()
ActiveSheet.Range("D1").Copy
SendMessage Sheets("Feuil1").AMSREdit1.hWnd, WM_PASTE, 0, ByVal 0&
End Sub

Les couleurs sont perdues et le texte dans le contrôle MSREdit reste en noir et blanc .

Par contre si je copie la cellule, la colle dans un nouveau document word et copie le texte collé dans word et bien j'ai les couleurs quand je colle dans mon contrôle.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
Sub Bouton2_Cliquer()
Dim oWord As Object
Dim oDoc As Object
ActiveSheet.Range("D1").Copy
Set oWord = CreateObject("word.application")
Set oDoc = oWord.Documents.Add
oWord.Selection.Paste
oWord.Visible = False
oDoc.Range.Select
oWord.Selection.Copy
SendMessage Sheets("Feuil1").AMSREdit1.hWnd, WM_PASTE, 0, ByVal 0&
oDoc.Close SaveChanges:=wdDoNotSaveChanges
oWord.Quit
End Sub

Cela fait comme si le copier Word avait quelque chose de plus que le copier Excel (peut être le format RTF) ?
Si quelqu'un à une solution sans passer par word ce qui fait un peu usine à gaz ?

Ami calmant, J.P

[unparia]

Bonjour
J'ignore comment Word traite.
Il n'est pas impossible que le contenu Excel ne soit pas en réalité en RTF, mais que l'automation (dont tu te sers entre Excel et Word) ait prévu la "transposition" en RTF.
Il n'est d'ailleurs pas non plus impossible que tu obtiendrais un bon résultat en exportant ce contenu vers un fichier RTF "tremplin".
A ta place, je laisserais tomber Copy and Paste et tenterais l'utilisation directe des fonctions SetClipboardData et GetClipboardData de la livrairie User32 de l'Api de Windows. Elle permettent le format RTF (en paramètre).
Il est probable que j'accompagnerais ces deux fonctions des fonctions de mémoire de la librairie Kernel32, dont CopyMemory.

[jurassic pork]

hello,

A ta place, je laisserais tomber Copy and Paste et tenterais l'utilisation directe des fonctions SetClipboardData et GetClipboardData de la livrairie User32 de l'Api de Windows. Elle permettent le format RTF (en paramètre).
Il est probable que j'accompagnerais ces deux fonctions des fonctions de mémoire de la librairie Kernel32, dont CopyMemory.

merci unparia de la piste. Bon j'ai essayé mais en utilisant que le GetClipboardData ( je garde le Copy qui m'a l'air correct puisque j'arrive à coller dans word avec les couleurs). D'autre part j'ai essayé une autre voie qui consiste à utiliser le contrôle WebBrower et à mettre dedans le contenu HTML du presse-papier après le Copy de la cellule.
Mon code :
Déclarations :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Private Const WM_CUT = &H300
Private Const WM_COPY = &H301
Private Const WM_PASTE = &H302
Private Const WM_CLEAR = &H303
Private Const EM_PASTESPECIAL = &H400 + 64
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal _
    hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, _
    lParam As Any) As Long
Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) _
   As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As _
   Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal _
   dwBytes As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _
   As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _
   As Long
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) _
   As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
   ByVal lpString2 As Any) As Long
Public Const GHND = &H42
Public Const MAXSIZE = 4096

La fonction ClipBoard_GetData :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
Function ClipBoard_GetData(ClipFormat As Variant)
   Dim hClipMemory As Long
   Dim lpClipMemory As Long
   Dim MyString As String
   Dim RetVal As Long
   Dim Fmt As Long   ' variable for RTF format clipboard handle
   Fmt = RegisterClipboardFormat(ClipFormat)
   If OpenClipboard(0&) = 0 Then
      MsgBox "Cannot open Clipboard. Another app. may have it open"
      Exit Function
   End If
   ' Obtain the handle to the global memory
   hClipMemory = GetClipboardData(Fmt)
   If IsNull(hClipMemory) Then
      MsgBox "Could not allocate memory"
      GoTo OutOfHere
   End If
   ' Lock Clipboard memory so we can reference
   ' the actual data string.
   lpClipMemory = GlobalLock(hClipMemory)
 
   If Not IsNull(lpClipMemory) Then
      MyString = Space$(MAXSIZE)
      RetVal = lstrcpy(MyString, lpClipMemory)
      RetVal = GlobalUnlock(hClipMemory)
 
      ' Peel off the null terminating character.
      MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)
   Else
      MsgBox "Could not lock memory to copy string from."
   End If
 
OutOfHere:
 
   RetVal = CloseClipboard()
   ClipBoard_GetData = MyString
 
End Function

Le code du copier / coller :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Sub Bouton2_Cliquer()
ActiveSheet.Range("D1").Copy
Sheets("Feuil1").AMSREdit1.TextRTF = ClipBoard_GetData("Rich Text Format")
Sheets("Feuil1").WebBrowser1.Navigate "about:blank" '/// initialize the browser window
 DoEvents
 With Sheets("Feuil1").WebBrowser1.Document
    .write ClipBoard_GetData("HTML Format") '/// write the HTML to your browser window
End With
End Sub

et voici ce que j'obtiens :


Le texte n'a toujours pas de couleurs dans le contrôle MSREdit. Dans le contrôle HTML j'ai un entête en trop et un caractère parasite

Ami calmant, J.P

[unparia]

je garde le Copy qui m'a l'air correct puisque j'arrive à coller dans word avec les couleurs

J'ai coutume de dire que l'air n'est pas toujours la chanson. (relis ce que j'ai exprimé en ce qui concerne une "transposition" possible lors de l'automation Excel/Word)
Le GetClipBoradDate récupère (avec son format) ce qu'à "recueilli" le SetClipBoardData
J'ôterais à ta place toute ambiguïté en utilisant le SetClipBordData (avec l'argument de format RTF)

[jurassic pork]

Le problème c'est que ce n'est pas la fonction setclipboarddata qui fait la conversion en rtf . Pour du RTF il faut fournir à cette fonction une chaîne en format RTF.

[jurassic pork]

hello,
bon finalement je suis arrivé à utiliser le contrôle Microsoft WebBrowser en mettant la propriété DesignMode à "On" (mode edition) pour pouvoir faire un "Coller" dedans.

Code d'ouverture du fichier (pour initialisation du contrôle WebBrowser) :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
Private Sub Workbook_Open()
 Sheets("Feuil1").WebBrowser1.Navigate "about:blank" '/// initialize the browser window
 Sheets("Feuil1").WebBrowser1.Document.DesignMode = "On"
End Sub

et le code qui copie le contenu d'une cellule Excel et le colle dans le contrôle WebBrowser :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Sub Bouton2_Cliquer()
Application.ScreenUpdating = False
ActiveSheet.Range("D1").Copy
With Sheets("Feuil1").WebBrowser1.Document
    .execCommand "SelectAll"
    .execCommand "Paste", False, Nothing
DoEvents
     .body.ScrollTop = 0
End With
Application.ScreenUpdating = True
End Sub

et voici le résultat :


Moralité : Le contenu du presse papier est plus complet en HTML qu'en RTF quand on fait un "Copy" d'une cellule Excel.

Ami calmant, J.P