Hellboy007
Technical User
Hi
With an XLA file that load when Excel open, there is a new button in the vbe standard bar menu that appears. With the click of that button it pops up a userform that contain a TextBox that shows all the code that is present in the vbe XLA file. The problem that I have is that it always shows the code of only that XLA file. But, i would like to be able to see the codes of other vbproject. Meaning, that the one that i am seeing a the screen, is the one that i would like to list when i click on my button.
So my questions are: How, When, Where can I get the information that I need to use the ThisWorkbook.name of the window that I am looking at and pass it some how to my XLA project ?
That is my main problem. there is 2 others.
- The button sometimes only works once
- I cant come back on the same place before i click my button
Any help at all, will be appriciated !
Thank's
Philippe
I am sending you the code that i use.
Regular Module
Option Explicit
Dim MnuEvt As VBECmdHandler
Dim CmdItem As CommandBarControl
Dim EvtHandlers As New Collection
Global strNomWorkbook As String
Public Sub Creer_Bouton()
While EvtHandlers.Count > 0
EvtHandlers.Remove 1
Wend
With Application.VBE.CommandBars("Standard")
.Reset
Set CmdItem = .Controls.Add(msoControlButton)
CmdItem.Caption = "VBA->XLD"
CmdItem.BeginGroup = True
CmdItem.FaceId = 1352
CmdItem.Style = msoButtonIconAndCaption
CmdItem.TooltipText = "Mise en forme de code pour le forum XLD"
CmdItem.OnAction = "'vba_to_xld.xla'" & "!Classeur_Actif"
Dim a As Variant
Set MnuEvt = New VBECmdHandler
Set MnuEvt.EvtHandler = Application.VBE.Events.CommandBarEvents(CmdItem)
EvtHandlers.Add MnuEvt
End With
End Sub
Public Sub Supprimer_Bouton()
On Error Resume Next
Application.VBE.CommandBars("Standard").Controls("VBA->XLD").Delete
On Error GoTo 0
End Sub
Function vb_to_xld()
Dim trouve_commentaire As Integer, intLine As Integer
Dim strTextBox() As String
Dim cell_code As Range, cellule As Range
Dim section As String, fin_normal As String, début_normal As String, _
début_mot As String, fin_mot As String, début_commentaire As String, _
fin_commentaire As String
Dim wkproc As Worksheet
Set wkproc = Workbooks("vba_to_xld.xla").Sheets("procédure")
With wkproc
fin_normal = .Range("f_normal").Cells.Value
début_normal = .Range("d_normal").Cells.Value
début_mot = .Range("d_mot_clé").Cells.Value
fin_mot = .Range("f_mot_clé").Cells.Value
début_commentaire = .Range("d_com").Value
fin_commentaire = .Range("f_com").Value
End With
'UsfListeMacro.TextBox1.SetFocus
strTextBox() = Split(UsfListeMacro.TextBox1.Value, Chr(10))
With WorksheetFunction
For intLine = 0 To UBound(strTextBox())
strTextBox(intLine) = Replace(strTextBox(intLine), "*****************************************************************************************************", Empty)
'commentaires
strTextBox(intLine) = .Substitute(" " & strTextBox(intLine), "'", " " & fin_normal & début_commentaire & "'")
'indentation
strTextBox(intLine) = .Substitute(strTextBox(intLine), " ", " ")
trouve_commentaire = 0
On Error Resume Next
trouve_commentaire = .Find(début_commentaire & "'", strTextBox(intLine))
If trouve_commentaire > 0 Then 'un commentaire sur la ligne
strTextBox(intLine) = strTextBox(intLine) & fin_commentaire & début_normal
strTextBox(intLine) = ligne1(" " & Left(strTextBox(intLine), trouve_commentaire)) & Mid(strTextBox(intLine), trouve_commentaire + 1)
Else
strTextBox(intLine) = ligne1(" " & strTextBox(intLine) & " ")
End If
Next intLine
End With
strTextBox(0) = wkproc.Range("début_m").Value & début_normal & strTextBox(0)
strTextBox(UBound(strTextBox())) = strTextBox(UBound(strTextBox())) & fin_normal & wkproc.Range("f_module").Value
vb_to_xld = strTextBox
End Function
Function ligne1(ligne As String) As String
Dim intLigne As Integer
Dim fin_normal As String, début_normal As String, début_mot As String, _
fin_mot As String, un_mot_clé As String
Dim l_mots As Range
Set l_mots = Workbooks("vba_xld.xla").Sheets("mots").Range("liste_mots")
With Workbooks("vba_xld.xla").Sheets("procédure")
fin_normal = .Range("f_normal").Cells.Value
début_normal = .Range("d_normal").Cells.Value
début_mot = .Range("d_mot_clé").Cells.Value
fin_mot = .Range("f_mot_clé").Cells.Value
End With
With Application.WorksheetFunction
For intLigne = 1 To l_mots.Cells.Count
un_mot_clé = l_mots.Cells(intLigne).Value
ligne = .Substitute(ligne, " " & un_mot_clé & " ", _
" " & fin_normal & début_mot & un_mot_clé & fin_mot & début_normal & " ")
Next intLigne
End With
ligne1 = ligne
End Function
Public Sub UsfShow()
'ActiveWorkbook.VBProject.VBE.ActiveWindow.SetFocus
UsfListeMacro.Show
End Sub
Class Module
Public WithEvents EvtHandler As VBIDE.CommandBarEvents
Private Sub EvtHandler_Click(ByVal CommandBarControl As Object, Handled As Boolean, CancelDefault As Boolean)
On Error Resume Next
'
' Run the code specified in the object's OnAction property.
'
Application.Run CommandBarControl.OnAction
'
' Indicate to the Events object that we've successfully handled the event.
'
Handled = True
CancelDefault = True
End Sub
Userform Module
Private Sub CommandButton1_Click()
Dim strTableauClip() As String
strTableauClip() = vb_to_xld()
PutOnClipboard strTableauClip()
End Sub
Public Sub PutOnClipboard(strTableau() As String) ' Obj As TextBox
Dim MyDataObj As New DataObject
Dim strClipBoard As String
Dim intLine As Integer
For intLine = 0 To UBound(strTableau())
strClipBoard = strClipBoard & strTableau(intLine) ' & Chr(10)
Next intLine
MyDataObj.SetText strClipBoard 'Format(strClipBoard)
MyDataObj.PutInClipboard
End Sub
Public Sub ClearClipboard()
Dim MyDataObj As New DataObject
MyDataObj.SetText ""
MyDataObj.PutInClipboard
End Sub
Private Sub CommandButton2_Click()
ClearClipboard
UsfListeMacro.Hide
Unload UsfListeMacro
strNomWorkbook = Empty
'ActiveWorkbook.VBProject.VBE.ActiveWindow.SetFocus
End Sub
Private Sub ListBox1_Change()
Dim intLine As Integer, intItem As Integer
Dim strTextBox As String
UsfListeMacro.TextBox1.Value = Empty
With UsfListeMacro.ListBox1
For intItem = 0 To .ListCount - 1
If .Selected(intItem) = True Then
intLine = .Column(0, intItem) - 1
With Workbooks(strNomWorkbook).VBProject.VBComponents(.Column(1, intItem)).CodeModule
strTextBox = Empty
Do
intLine = intLine + 1
strTextBox = strTextBox & .Lines(intLine, 1) & Chr(10) 'vbCrLf
Loop Until (InStr(1, .Lines(intLine, 1), "End Sub") > 0 And Len(.Lines(intLine, 1)) = 7) Or _
(InStr(1, .Lines(intLine, 1), "End Function") > 0 And Len(.Lines(intLine, 1)) = 12) Or _
(InStr(1, .Lines(intLine, 1), "End Property") > 0 And Len(.Lines(intLine, 1)) = 12)
End With
With UsfListeMacro.TextBox1
.Value = .Value & strTextBox & "*****************************************************************************************************" & Chr(10)
End With
End If
Next intItem
UsfListeMacro.TextBox1.SetFocus
End With
End Sub
Private Sub UserForm_Initialize()
Dim intLine As Integer
Dim VBCmp As VBComponent
Dim UsfListB As Object
Set UsfListB = UsfListeMacro.ListBox1
UsfListB.ColumnWidths = 0 & ";" & 100 & ";" & 200
With Workbooks(strNomWorkbook).VBProject
For Each VBCmp In .VBComponents
With .VBComponents(VBCmp.Name).CodeModule
If .CountOfLines > 2 Then
intLineRef = 1
For intLine = 1 To .CountOfLines
If (InStr(1, .Lines(intLine, 1), "Sub") > 0 Or _
(InStr(1, .Lines(intLine, 1), "Function") > 0 And InStr(1, .Lines(intLine, 1), "WorksheetFunction") < 1) Or _
InStr(1, .Lines(intLine, 1), "Property") > 0 And InStr(1, .Lines(intLine, 1), " Exit") < 1) Then
UsfListB.AddItem intLineRef
UsfListB.Column(1, UsfListB.ListCount - 1) = .Name
UsfListB.Column(2, UsfListB.ListCount - 1) = .Lines(intLine, 1)
Do
intLine = intLine + 1
Loop Until (InStr(1, .Lines(intLine, 1), "End Sub") > 0 And Len(.Lines(intLine, 1)) = 7) Or _
(InStr(1, .Lines(intLine, 1), "End Function") > 0 And Len(.Lines(intLine, 1)) = 12) Or _
(InStr(1, .Lines(intLine, 1), "End Property") > 0 And Len(.Lines(intLine, 1)) = 12)
intLineRef = intLine + 1
End If
Next intLine
End If
End With
Next VBCmp
End With
Set UsfListB = Nothing
End Sub
_________________
Philippe
With an XLA file that load when Excel open, there is a new button in the vbe standard bar menu that appears. With the click of that button it pops up a userform that contain a TextBox that shows all the code that is present in the vbe XLA file. The problem that I have is that it always shows the code of only that XLA file. But, i would like to be able to see the codes of other vbproject. Meaning, that the one that i am seeing a the screen, is the one that i would like to list when i click on my button.
So my questions are: How, When, Where can I get the information that I need to use the ThisWorkbook.name of the window that I am looking at and pass it some how to my XLA project ?
That is my main problem. there is 2 others.
- The button sometimes only works once
- I cant come back on the same place before i click my button
Any help at all, will be appriciated !
Thank's
Philippe
I am sending you the code that i use.
Regular Module
Option Explicit
Dim MnuEvt As VBECmdHandler
Dim CmdItem As CommandBarControl
Dim EvtHandlers As New Collection
Global strNomWorkbook As String
Public Sub Creer_Bouton()
While EvtHandlers.Count > 0
EvtHandlers.Remove 1
Wend
With Application.VBE.CommandBars("Standard")
.Reset
Set CmdItem = .Controls.Add(msoControlButton)
CmdItem.Caption = "VBA->XLD"
CmdItem.BeginGroup = True
CmdItem.FaceId = 1352
CmdItem.Style = msoButtonIconAndCaption
CmdItem.TooltipText = "Mise en forme de code pour le forum XLD"
CmdItem.OnAction = "'vba_to_xld.xla'" & "!Classeur_Actif"
Dim a As Variant
Set MnuEvt = New VBECmdHandler
Set MnuEvt.EvtHandler = Application.VBE.Events.CommandBarEvents(CmdItem)
EvtHandlers.Add MnuEvt
End With
End Sub
Public Sub Supprimer_Bouton()
On Error Resume Next
Application.VBE.CommandBars("Standard").Controls("VBA->XLD").Delete
On Error GoTo 0
End Sub
Function vb_to_xld()
Dim trouve_commentaire As Integer, intLine As Integer
Dim strTextBox() As String
Dim cell_code As Range, cellule As Range
Dim section As String, fin_normal As String, début_normal As String, _
début_mot As String, fin_mot As String, début_commentaire As String, _
fin_commentaire As String
Dim wkproc As Worksheet
Set wkproc = Workbooks("vba_to_xld.xla").Sheets("procédure")
With wkproc
fin_normal = .Range("f_normal").Cells.Value
début_normal = .Range("d_normal").Cells.Value
début_mot = .Range("d_mot_clé").Cells.Value
fin_mot = .Range("f_mot_clé").Cells.Value
début_commentaire = .Range("d_com").Value
fin_commentaire = .Range("f_com").Value
End With
'UsfListeMacro.TextBox1.SetFocus
strTextBox() = Split(UsfListeMacro.TextBox1.Value, Chr(10))
With WorksheetFunction
For intLine = 0 To UBound(strTextBox())
strTextBox(intLine) = Replace(strTextBox(intLine), "*****************************************************************************************************", Empty)
'commentaires
strTextBox(intLine) = .Substitute(" " & strTextBox(intLine), "'", " " & fin_normal & début_commentaire & "'")
'indentation
strTextBox(intLine) = .Substitute(strTextBox(intLine), " ", " ")
trouve_commentaire = 0
On Error Resume Next
trouve_commentaire = .Find(début_commentaire & "'", strTextBox(intLine))
If trouve_commentaire > 0 Then 'un commentaire sur la ligne
strTextBox(intLine) = strTextBox(intLine) & fin_commentaire & début_normal
strTextBox(intLine) = ligne1(" " & Left(strTextBox(intLine), trouve_commentaire)) & Mid(strTextBox(intLine), trouve_commentaire + 1)
Else
strTextBox(intLine) = ligne1(" " & strTextBox(intLine) & " ")
End If
Next intLine
End With
strTextBox(0) = wkproc.Range("début_m").Value & début_normal & strTextBox(0)
strTextBox(UBound(strTextBox())) = strTextBox(UBound(strTextBox())) & fin_normal & wkproc.Range("f_module").Value
vb_to_xld = strTextBox
End Function
Function ligne1(ligne As String) As String
Dim intLigne As Integer
Dim fin_normal As String, début_normal As String, début_mot As String, _
fin_mot As String, un_mot_clé As String
Dim l_mots As Range
Set l_mots = Workbooks("vba_xld.xla").Sheets("mots").Range("liste_mots")
With Workbooks("vba_xld.xla").Sheets("procédure")
fin_normal = .Range("f_normal").Cells.Value
début_normal = .Range("d_normal").Cells.Value
début_mot = .Range("d_mot_clé").Cells.Value
fin_mot = .Range("f_mot_clé").Cells.Value
End With
With Application.WorksheetFunction
For intLigne = 1 To l_mots.Cells.Count
un_mot_clé = l_mots.Cells(intLigne).Value
ligne = .Substitute(ligne, " " & un_mot_clé & " ", _
" " & fin_normal & début_mot & un_mot_clé & fin_mot & début_normal & " ")
Next intLigne
End With
ligne1 = ligne
End Function
Public Sub UsfShow()
'ActiveWorkbook.VBProject.VBE.ActiveWindow.SetFocus
UsfListeMacro.Show
End Sub
Class Module
Public WithEvents EvtHandler As VBIDE.CommandBarEvents
Private Sub EvtHandler_Click(ByVal CommandBarControl As Object, Handled As Boolean, CancelDefault As Boolean)
On Error Resume Next
'
' Run the code specified in the object's OnAction property.
'
Application.Run CommandBarControl.OnAction
'
' Indicate to the Events object that we've successfully handled the event.
'
Handled = True
CancelDefault = True
End Sub
Userform Module
Private Sub CommandButton1_Click()
Dim strTableauClip() As String
strTableauClip() = vb_to_xld()
PutOnClipboard strTableauClip()
End Sub
Public Sub PutOnClipboard(strTableau() As String) ' Obj As TextBox
Dim MyDataObj As New DataObject
Dim strClipBoard As String
Dim intLine As Integer
For intLine = 0 To UBound(strTableau())
strClipBoard = strClipBoard & strTableau(intLine) ' & Chr(10)
Next intLine
MyDataObj.SetText strClipBoard 'Format(strClipBoard)
MyDataObj.PutInClipboard
End Sub
Public Sub ClearClipboard()
Dim MyDataObj As New DataObject
MyDataObj.SetText ""
MyDataObj.PutInClipboard
End Sub
Private Sub CommandButton2_Click()
ClearClipboard
UsfListeMacro.Hide
Unload UsfListeMacro
strNomWorkbook = Empty
'ActiveWorkbook.VBProject.VBE.ActiveWindow.SetFocus
End Sub
Private Sub ListBox1_Change()
Dim intLine As Integer, intItem As Integer
Dim strTextBox As String
UsfListeMacro.TextBox1.Value = Empty
With UsfListeMacro.ListBox1
For intItem = 0 To .ListCount - 1
If .Selected(intItem) = True Then
intLine = .Column(0, intItem) - 1
With Workbooks(strNomWorkbook).VBProject.VBComponents(.Column(1, intItem)).CodeModule
strTextBox = Empty
Do
intLine = intLine + 1
strTextBox = strTextBox & .Lines(intLine, 1) & Chr(10) 'vbCrLf
Loop Until (InStr(1, .Lines(intLine, 1), "End Sub") > 0 And Len(.Lines(intLine, 1)) = 7) Or _
(InStr(1, .Lines(intLine, 1), "End Function") > 0 And Len(.Lines(intLine, 1)) = 12) Or _
(InStr(1, .Lines(intLine, 1), "End Property") > 0 And Len(.Lines(intLine, 1)) = 12)
End With
With UsfListeMacro.TextBox1
.Value = .Value & strTextBox & "*****************************************************************************************************" & Chr(10)
End With
End If
Next intItem
UsfListeMacro.TextBox1.SetFocus
End With
End Sub
Private Sub UserForm_Initialize()
Dim intLine As Integer
Dim VBCmp As VBComponent
Dim UsfListB As Object
Set UsfListB = UsfListeMacro.ListBox1
UsfListB.ColumnWidths = 0 & ";" & 100 & ";" & 200
With Workbooks(strNomWorkbook).VBProject
For Each VBCmp In .VBComponents
With .VBComponents(VBCmp.Name).CodeModule
If .CountOfLines > 2 Then
intLineRef = 1
For intLine = 1 To .CountOfLines
If (InStr(1, .Lines(intLine, 1), "Sub") > 0 Or _
(InStr(1, .Lines(intLine, 1), "Function") > 0 And InStr(1, .Lines(intLine, 1), "WorksheetFunction") < 1) Or _
InStr(1, .Lines(intLine, 1), "Property") > 0 And InStr(1, .Lines(intLine, 1), " Exit") < 1) Then
UsfListB.AddItem intLineRef
UsfListB.Column(1, UsfListB.ListCount - 1) = .Name
UsfListB.Column(2, UsfListB.ListCount - 1) = .Lines(intLine, 1)
Do
intLine = intLine + 1
Loop Until (InStr(1, .Lines(intLine, 1), "End Sub") > 0 And Len(.Lines(intLine, 1)) = 7) Or _
(InStr(1, .Lines(intLine, 1), "End Function") > 0 And Len(.Lines(intLine, 1)) = 12) Or _
(InStr(1, .Lines(intLine, 1), "End Property") > 0 And Len(.Lines(intLine, 1)) = 12)
intLineRef = intLine + 1
End If
Next intLine
End If
End With
Next VBCmp
End With
Set UsfListB = Nothing
End Sub
_________________
Philippe
