2013-09-08 Convertir un tableau Excel au format HTML
Le code suivant convertit un tableau Excel au format HTML puis stocke le résultat dans le presse-papier (il suffit donc de faire CTRC+V pour le coller où on veut). La macro convertit la zone sélectionnée au format HTML. Voici ce qu'elle donne :
| objectif | Python | VBA |
| test | if / else | if .. Then / else / end if |
| boucle | for .. in .. | for .. = .. to .. / next |
| fonction | def | fonction / end function |
Le code de la fonction doit être copié/collé dans un module (ALT+F11 pour voir le code VBA associé à la feuille). Je n'ai pas implémenté beaucoup de styles mais la fonction est facilement modifiable.
' code à copier dans la feuille Excel
Function ColorToHtml(ByVal value As String) As String
Dim scolor As String
scolor = Trim(Hex(value))
While Len(scolor) < 6
scolor = "0" + scolor
Wend
scolor = Mid(scolor, 3, 4) + Mid(scolor, 1, 2)
ColorToHtml = "#" + scolor
End Function
Sub range_html_to_cliboard()
Set rge = Selection
Dim res, line, ce As String
res = "<table>" + Chr(10)
For i = 1 To rge.Rows.Count
line = "<tr>"
For j = 1 To rge.Columns.Count
ce = "<td style="""
If rge(i, j).Interior.color Then
ce = ce + "background-color:" + ColorToHtml(rge(i, j).Interior.color) + ";"
End If
If rge(i, j).Font.color Then
ce = ce + "color:" + ColorToHtml(rge(i, j).Font.color) + ";"
End If
If rge(i, j).Font.Bold Then
ce = ce + "font-weight:bold;"
End If
ce = ce + """>"
ce = ce + rge(i, j).Text + "</td>"
line = line + ce
Next
line = line + "</tr>"
res = res + line + Chr(10)
Next
res = res + "</table>" + Chr(10)
ClipBoard_SetData (res)
End Sub
La fonction ne marche pas tel quel sur les tableaux créés avec des styles, ni même avec une liste filtrée. Pour cela, il faut copier la zone désirée puis faire deux collages spéciaux, le formatting et les valeurs, au même endroit. On sélectionne ensuite la zone collée puis on appelle la macro décrite ci-dessus.
Le code précédent utilise une fonction ClipBoard_SetData dont le code suit et qu'il faut recopier dans un module.
' code à copier dans un module (existant ou nouveau)
' from http://stackoverflow.com/questions/14219455/excel-vba-code-to-copy-a-specific-string-to-clipboard
Option Explicit
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Const GHND = &H42
Const CF_TEXT = 1
Const MAXSIZE = 4096
Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
' Allocate moveable global memory.
'-------------------------------------------
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
' Lock the block to get a far pointer
' to this memory.
lpGlobalMemory = GlobalLock(hGlobalMemory)
' Copy the string to this global memory.
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
' Unlock the memory.
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
' Open the Clipboard to copy data to.
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
' Clear the Clipboard.
X = EmptyClipboard()
' Copy the data to the Clipboard.
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
2015/03/14 modification du premier code pour gérer des valeurs nulles
| <-- --> |
Xavier Dupré
|
