Copier du code dans le forum

[Sylvain]

Bonjour,

suite à la dernière newsletter de Gaëtan Mourmant : <http://www.polykromy.com/nl/nl53/>

J'ai téléchargé l'utilitaire de conversion de code vba en html en passant directement par le presse papier sur :
<http://www.mrexcel.com/vbaddin.shtml>

et j'ai regardé l'option de conversion pour les forums mais ça n'a pas donné grand chose sur xld voir fil :
<http://www.excel-downloads.com/html/French/forum/messages/1_139890_139890.htm>

Alors j'ai regardé le code et je me suis aperçu que si l'on changeait la procédure :

'Converts the specified text with the VBE Color (Black, Blue or Green) using BB code
Private Function cBBColor(ByVal Color As Long, ByVal Text As String) As String
Dim Msg As String
Msg = "[color="
Msg = Msg & Choose(Color, "black", "darkblue", "green") & "]"
Msg = Msg & Text
Msg = Msg & "[/color]"
BBColor = Msg
End Function

en :


'convertis le texte pour le forum xld
Private Function BBColor(ByVal Color As Long, ByVal Text As String) As String
Select Case Color
Case BLACK
BBColor = Text
Case BLUE
BBColor = "" & Text & ""
Case GREEN
BBColor = "" & Text & ""
End Select
End Function
'Converts the specified text with the VBE Color (Black, Blue or Green) using BB code

On obtient quelque chose de sympa avec les commentaires en itallique et les mots clés en gras.
Il reste juste à effacer la balise face en début et fin de procédure pour le coller dans un post

Je ne mets pas le classeur à télécharger car il n'est pas de moi, mais vous avez les clés pour le modifier facilement.

A+

 

[Sylvain]

c'est pas facile d'avoir des balises [ dans le code :

j'espère que ça ira :

'convertis le texte pour le forum xld
Private Function BBColor(ByVal Color As Long, ByVal Text As String) As String
Select Case Color
Case BLACK
BBColor = Text
Case BLUE
BBColor = " [ b ] " & Text & " [ / b ]"
Case GREEN
BBColor = " [ i ] " & Text & " [ / i] "
End Select
End Function
'Converts the specified text with the VBE Color (Black, Blue or Green) using BB code

 

[Sylvain]

bien sûr il faudra enlever les espaces dans les " aux lignes :

BBColor = " [ b ] " & Text & " [ / b ]"
et
BBColor = " [ i ] " & Text & " [ / i] "

A+

 

[Sylvain]

essai indentation

Sub init_fenetre()
Set newItem = CommandBars("window").Controls.Add(Type:=msoControlButton)
With newItem
    .BeginGroup = False
    .Caption = "zone active"
    .FaceId = 10
    .OnAction = "restreint"
    .Move Before:=7
End With
End Sub

A+

 

[Sylvain]

résultat avec indentation et suppression des balise [face]


Sub init_fenetre()
Set newItem = CommandBars("window").Controls.Add(Type:=msoControlButton)
With newItem
    .BeginGroup = False
    .Caption = "zone active"
    .FaceId = 10
    .OnAction = "restreint"
    .Move Before:=7
End With
End Sub
Sub DelMenu_restreint()

code à rajouter dans la procédure

Sub CreateBB(Optional ByVal Procedure As Long = 0)
    Dim Txt As String, MyDO As New DataObject
    On Error GoTo err_h
    Init True
    If Not Init(True) Then GoTo err_h
    Convertor False, Txt, Procedure > 0
    'If there's something there, copy it to the clipboard
    If Len(Txt) > 0 Then
    'indentation      
Txt = Replace(Txt, "  ", Chr(160) & Chr(160))
      Txt = Replace(Txt, "[face=Courier New]", "")
      Txt = Replace(Txt, "[/face]", "")
        MyDO.SetText Txt
        MyDO.PutInClipboard
        MsgBox "The BB code has been copied to the clipboard", vbInformation, AppName
    End If
err_h:
    Init False
End Sub

A+

 

[Sylvain]

essai idiot

t t
t t

 

[Sylvain]

autre essai :

&nbsp;&nbsp;A+

 

[Sylvain]

essai 3

Sub vb_to_xld()
Dim cell_code As Range
Dim cellule As Range
Dim trouve_commentaire
For Each cell_code In Selection
&nbsp;&nbsp; 'indentation
&nbsp;&nbsp;&nbsp;&nbsp;'cell_code.Value = Replace(cell_code.Value, "&nbsp;&nbsp;", Chr(160) & Chr(160))
&nbsp;&nbsp;&nbsp;&nbsp;cell_code.Value = WorksheetFunction.Substitute(cell_code.Value, "&nbsp;&nbsp;", "&nbsp;&nbsp;")
&nbsp;&nbsp;&nbsp;&nbsp;'commentaires
&nbsp;&nbsp;&nbsp;&nbsp;cell_code.Value = WorksheetFunction.Substitute(cell_code.Value, "'", "'")
&nbsp;&nbsp;&nbsp;&nbsp;trouve_commentaire = 0
&nbsp;&nbsp;&nbsp;&nbsp;On Error Resume Next
&nbsp;&nbsp;&nbsp;&nbsp;trouve_commentaire = Application.WorksheetFunction.Find("'", cell_code.Value)
&nbsp;&nbsp;&nbsp;&nbsp;If trouve_commentaire > 0 Then 'un commentaire sur la ligne
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;cell_code.Value = cell_code.Value & ""
&nbsp;&nbsp;&nbsp;&nbsp;End If
&nbsp;&nbsp;&nbsp;&nbsp;cell_code.Value = ligne1(" " & cell_code.Value & "&nbsp;&nbsp;")
Next
Selection.Copy
On Error GoTo 0
End Sub

 

[Sylvain]

essai 4

Sub vb_to_xld()
Dim cell_code As Range
Dim cellule As Range
Dim trouve_commentaire
For Each cell_code In Selection
&nbsp;&nbsp; 'indentation
&nbsp;&nbsp; &nbsp;&nbsp; 'cell_code.Value = Replace(cell_code.Value, "&nbsp;&nbsp; ", Chr(160) & Chr(160))
&nbsp;&nbsp; &nbsp;&nbsp; cell_code.Value = WorksheetFunction.Substitute(cell_code.Value, "&nbsp;&nbsp; ", "&nbsp;&nbsp; ")
&nbsp;&nbsp; &nbsp;&nbsp; 'commentaires
&nbsp;&nbsp; &nbsp;&nbsp; cell_code.Value = WorksheetFunction.Substitute(cell_code.Value, "'", "'")
&nbsp;&nbsp; &nbsp;&nbsp; trouve_commentaire = 0
&nbsp;&nbsp; &nbsp;&nbsp; On Error Resume Next
&nbsp;&nbsp; &nbsp;&nbsp; trouve_commentaire = Application.WorksheetFunction.Find("'", cell_code.Value)
&nbsp;&nbsp; &nbsp;&nbsp; If trouve_commentaire > 0 Then 'un commentaire sur la ligne
&nbsp;&nbsp; &nbsp;&nbsp; &nbsp;&nbsp; cell_code.Value = cell_code.Value & ""
&nbsp;&nbsp; &nbsp;&nbsp; End If
&nbsp;&nbsp; &nbsp;&nbsp; cell_code.Value = ligne1(" " & cell_code.Value & "&nbsp;&nbsp; ")
Next
Selection.Copy
On Error GoTo 0
End Sub

 

[Sylvain]

essai 5

Sub vb_to_xld()
Dim cell_code As Range
Dim cellule As Range
Dim trouve_commentaire
For Each cell_code In Selection
&nbsp; 'indentation
&nbsp; &nbsp; cell_code.Value = WorksheetFunction.Substitute(cell_code.Value, "&nbsp; ", "&nbsp; ")
&nbsp; &nbsp; 'commentaires
&nbsp; &nbsp; cell_code.Value = WorksheetFunction.Substitute(cell_code.Value, "'", "'")
&nbsp; &nbsp; trouve_commentaire = 0
&nbsp; &nbsp; On Error Resume Next
&nbsp; &nbsp; trouve_commentaire = Application.WorksheetFunction.Find("'", cell_code.Value)
&nbsp; &nbsp; If trouve_commentaire > 0 Then 'un commentaire sur la ligne
&nbsp; &nbsp; &nbsp; cell_code.Value = cell_code.Value & ""
&nbsp; &nbsp; End If
&nbsp; &nbsp; cell_code.Value = ligne1(" " & cell_code.Value & "&nbsp; ")
Next
Selection.Copy
On Error GoTo 0
End Sub

 

[Sylvain]

essai 6

 

[Sylvain]

essai 7
Sub restreint()
macro réalisée par Sylvain
http://sn1.chez.tiscali.fr
Dim zone_active As String
zone_active = Selection.Address()
ActiveSheet.UsedRange.Select
Range(zone_active).Select
If Selection.Cells.Count = 1 Then
ActiveSheet.ScrollArea = ""
Else
On Error Resume Next
ActiveSheet.ScrollArea = Selection.Address()
End If
Application.OnUndo "autoriser toute la feuille", "nerestreintpas"
End Sub
Sub nerestreintpas()
ActiveSheet.ScrollArea = ""
End Sub
Sub init_fenetre()
Set newItem = CommandBars("window").Controls.Add(Type:=msoControlButton)
With newItem
&nbsp; &nbsp; .BeginGroup = False
&nbsp; &nbsp; .Caption = "zone active"
&nbsp; &nbsp; .FaceId = 10
&nbsp; &nbsp; .OnAction = "restreint"
&nbsp; &nbsp; .Move Before:=7
End With
End Sub
Sub DelMenu_restreint()

On Error Resume Next
Application.CommandBars("window").Controls("zone active").Delete
End Sub

 

[Sylvain]

essai 8


&nbsp; Sub restreint()&nbsp;
'macro réalisée par Sylvain
'http://sn1.chez.tiscali.fr
Dim zone_active As String
zone_active = Selection.Address()
ActiveSheet.UsedRange.Select
Range(zone_active).Select
If Selection.Cells.Count = 1 Then
&nbsp; &nbsp; cell_code.Value = WorksheetFunction.Substitute(cell_code.Value, "&nbsp; ", "&nbsp; ")
&nbsp; &nbsp; trouve_commentaire = 0
&nbsp; &nbsp; On Error Resume Next
&nbsp; &nbsp; trouve_commentaire = Application.WorksheetFunction.Find("'", cell_code.Value)
&nbsp; &nbsp; If trouve_commentaire > 0 Then 'un commentaire sur la ligne
&nbsp; &nbsp; &nbsp; cell_code.Value = cell_code.Value & ""
&nbsp; &nbsp; End If
&nbsp; &nbsp; cell_code.Value = ligne1(" " & cell_code.Value & "&nbsp; ")

 

[Sylvain]

essai pas vieux

Sub restreint()
'macro réalisée par Sylvain
'http://sn1.chez.tiscali.fr
Dim zone_active As String
zone_active = Selection.Address()
ActiveSheet.UsedRange.Select
Range(zone_active).Select
If Selection.Cells.Count = 1 Then
&nbsp; ActiveSheet.ScrollArea = "" ' essai 9
Else
On Error Resume Next
&nbsp; ActiveSheet.ScrollArea = Selection.Address()
End If
&nbsp; Application.OnUndo "autoriser toute la feuille", "nerestreintpas"
End Sub