Discussion :

[wouebmaster]

J'ai travaillé sur une macro de conversion des tableaux en HTML, avec une grande aide de "bbil", mais il me reste un petit détail que je n'arrive pas a implémenter, je vous explique :

J'utilise cette macro de conversion vers HTML (pour les tableaux):

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
39
40
41
42
43
44
45
 
Private Sub Mes_Tableaux(T, tMes() As Single)
'
' Calcule emplacement des colonnes..
'
'
    Dim r As Row
    Dim c As Cell
    Dim sLargeur As Single
    Dim bTrouve As Boolean
    Dim i As Integer
    Dim j As Integer
    ReDim Preserve tMes(0)
    tMes(0) = 0
    For Each r In T.Range.Rows
        sLargeur = 0
 
        For Each c In r.Range.Cells
         sLargeur = sLargeur + c.PreferredWidth
         i = 0
         bTrouve = False
         While i <= UBound(tMes) And Not bTrouve
            If tMes(i) < sLargeur Then
             i = i + 1
             Else
              bTrouve = True
            End If
           Wend
           If Not bTrouve Then
              If tMes(i - 1) < sLargeur - 0.01 Then
                ReDim Preserve tMes(i)
                tMes(i) = sLargeur
              End If
           Else
            If tMes(i) - sLargeur > 0.1 Then
               For j = UBound(tMes) To i + 1 Step -1
                 tMes(j) = tMes(j - 1)
                Next
                 tMes(i) = sLargeur
            End If
           End If
        Next
    Next
 
End Sub

et

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
 
Private Function iNbCol(c As Cell, sDepart As Single, tMes() As Single) As Integer
'
' Calcul Nombre de Colonnes
'
'
 Dim iDeb As Integer
 Dim iFin As Integer
 Dim i As Integer
 Dim bTrouver As Boolean
 iDeb = 0
 iFin = 0
 bTrouve = False
 While i <= UBound(tMes) And Not bTrouve
   If tMes(i) < sDepart + 0.01 Then iDeb = i
   iFin = i
   If tMes(i) >= c.PreferredWidth + sDepart - 0.05 Then bTrouve = True
 
   i = i + 1
  Wend
 iNbCol = iFin - iDeb
End Function

et

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
39
40
41
42
43
44
45
46
47
48
49
 
Private Sub Conv_Tableaux_OK_Click()
'
' Conversion des Tableaux Standards
'
'
    Dim T As Table ' T c'est mon tableau
    Dim r As Row
    Dim stTexte As String
    Dim sDepart As Single
    Dim stColSpan As String 'colonne fusionee
    Dim iCol As Integer
    Dim c As Cell
    Dim tMes() As Single 'Tableau emplacement des colonnes...
    Dim nbrTable As Long
    Dim Toto As Long
    nbrTable = ActiveDocument.Tables.Count
    If nbrTable = 0 Then Exit Sub
 
    Toto = 1
While Toto <= nbrTable
    StatusBar = "Traitement du tableau n° " & Toto & "/" & nbrTable
    Set T = ActiveDocument.Tables(1) ' Je prend le tableau atif
    Mes_Tableaux T, tMes
    stTexte = "<center><table width=100% border=1>"
    For Each r In T.Range.Rows
       sDepart = 0
       stTexte = stTexte & "<TR>"
       For Each c In r.Range.Cells
         stColSpan = ""
         iCol = iNbCol(c, sDepart, tMes)
         If iCol > 1 Then stColSpan = " colspan=" & iCol & " "
 
         stTexte = stTexte & "<TD" & stColSpan & "><div align=center>" & NetCellule(c.Range.Text) & "</div></TD>"
         sDepart = sDepart + c.PreferredWidth
       Next
       stTexte = stTexte & "</TR>" & Chr(13)
    Next
     stTexte = stTexte & "</TABLE></center>"
 
          stTexte = stTexte & "</TABLE>"
     Debug.Print stTexte
     T.Select
     T.Delete
     Selection.TypeText Text:=stTexte
     Toto = Toto + 1
Wend
 
End Sub

Je voudrais insérer un code <br> a chaque "saut de ligne" trouvé dans les tableaux, car dans l'état actuel, lorsque le texte est séparé par un saut de ligne (dans la même cellule), le texte est convertit en se mettant a la suite, sans espace...

Merci de m'Helper please [/code]

[SfJ5Rpw8]

en fait les modifications à effectuer sont à faire dans NetCellule ...
..

Code :

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

1
2
3
4
5
6
7
8
9
10
11
Function NetCellule(st As String) As String
 Dim i As Integer
 Dim st2 As String
 st2 = st
  i = Len(st)
 
  If Asc(Mid(st, i - 1, 1) = 13 And Asc(Right(st, 1) = 7)) Then
    st2 = Left(st, i - 2)
  End If
    NetCellule = Replace(st2, vbCr, "<br>")
End Function

[wouebmaster]

Merci, ca a l'air de bien fonctionner.... En revanche, mon netcellule etait comme ceci :

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
Function NetCellule(st As String) As String
'
' Permet d'enlever les tabulation des cellule
'
 Dim i As Integer
 Dim st2 As String
 st2 = ""
 st3 = " "
 
 For i = 1 To Len(st)
    If Asc(Mid(st, i, 1)) >= 32 Then
     st2 = st2 & Mid(st, i, 1)
    End If
 
 Next
 
    If Len(st2) = 0 Then st2 = st3
  NetCellule = st2
 
 End Function

Ca me parait bizzarre de me retrouvé avec moins de code...


Merci a toi :-)

[SfJ5Rpw8]

ben je n'avais pas le dernier netCellule... par contre sais-tu à quoi sert :

Code :

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

st3 = " "

à priori c'est utilisé pour le cas ou cellule vide... à remettre dans le code.. je ne sais pas ce que cela fait en html.. ?

[wouebmaster]

Oui, c'est pour mettre un espace dans les cellules vides., sinon, j'ai une cellule sans cadre.

[wouebmaster]

Merci beaucoup, cela fonctionne maintenant :

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
 
Function NetCellule(st As String) As String
'
' Permet de préparer les cellules d'un tableau et d'ajouter un retour dans les cellule ou il y a des sauts de lignes
'
Dim i As Integer
 Dim st2 As String
 st2 = st
 st3 = " "
 i = Len(st)
 
  If Asc(Mid(st, i - 1, 1) = 13 And Asc(Right(st, 1) = 7)) Then
    st2 = Left(st, i - 2)
  End If
 
  If Len(st2) = 0 Then st2 = st3
    NetCellule = Replace(st2, vbCr, "<br>")
End Function