I want to show this off

[ClimoC]

Just because I think in an office environment this kind of thing is really crafty and cool.

based on a simple naming convention, you can dynamically move around macros within your company.

Example:
1.Setup (under the Baddress\role macros) folders called 'TIM1' 'BOB2' & 'ALEX'
2.Name your category-specific macros with the same acronyms/labels
(i.e., if the macro is called Sub DataCollection, rename it Sub TIM1DataCollection, etc)
3.Name your modules that contain these subs in the same way
4.Export each group of macros into the right folders
5.Run this

The mode advanced of you will see what this is doing. And I imagine you could've written it yourself, but scouring the net I found nothing similar, so I architectured this from a few functions I found and did the rest.

NB: This was done for MS Project, but the large majority of it is for the VBE and the application itself. Only a few tiny tweaks in the right places, and this should be able to be run for any of the office apps.

Enjoy

Comments?

C

Sub moduletest()

Dim DAddress As String
Dim BAddress As String

BAddress = "\\serverpathto\whereyouhave\keptfolders\containingsetsof\macros"

Dim answer As String
answer = InputBox("Please enter the 4 character acronym for your role" & Chr(10) & _
            "If your role's acronym is fewer than 4 characters, make up the difference with " & Chr(10) & _
            "underscores ('_')." & Chr(10) & _
            "(e.g., If Role acronym is 'SP', enter 'SP__')")

DAddress = BAddress & "\role macros\" & answer & "\"


Dim oFs As Object
Dim oFolder As Object
Dim oFile As Object
Dim mdlnm As VBIDE.VBComponent
Dim CodeMod As VBIDE.CodeModule
Dim ProcKind As VBIDE.vbext_ProcKind
Set oFs = CreateObject("Scripting.FileSystemObject")


If oFs.FolderExists(DAddress) Then
    Set oFolder = oFs.GetFolder(DAddress)
    On Error Resume Next
    For Each oFile In oFolder.Files
        If Left(oFile.Name, 4) = answer Then
            For Each mdlnm In VBE.VBProjects(1).VBComponents
                If Left(mdlnm.Name, 4) = Left(oFile.Name, 4) Then
                    VBE.VBProjects(1).VBComponents.Remove mdlnm
                    Exit For
                Else
                End If
            Next
            VBE.VBProjects(1).VBComponents.Import (oFile)
        Else
        End If
    Next

End If

On Error Resume Next
CBDeleteCommandBar (answer & " Macros")
Err.Clear

On Error Resume Next
CommandBars.Add(Name:=answer & " Macros", Position:=msoBarfixed).Visible = True
Err.Clear

Dim Procname As String

For Each mdlnm In VBE.VBProjects(1).VBComponents
    If Left(mdlnm.Name, 4) = answer Then
        Procname = mdlnm.CodeModule.ProcOfLine(4, 0)
            If Left(Procname, 4) = answer Then
                With CommandBars(answer & " Macros").Controls.Add(Type:=msoControlButton)
                    .Caption = Procname
                    .OnAction = "Macro " & Procname
                    .Style = msoButtonIcon
                    .FaceId = 54
                    
                End With

            Else
            End If
        Else
    End If
Next

        



End Sub

Sub addref()

On Error Resume Next
   ActiveProject.VBProject.References.AddFromGuid _
        GUID:="{0002E157-0000-0000-C000-000000000046}", _
        Major:=5, Minor:=3
Err.Clear

Run "moduletest"
End Sub

Function CBDeleteCommandBar(strCBarName As String) As Boolean
   On Error Resume Next
   Application.CommandBars(strCBarName).Delete
End Function

EDIT - Just to explain what this will do

Based on what you enter into the inputbox, this will:

Go to a folder of that name
remove all macros in the global.mpt (or personal.xls if you tweak it) beginning with that name
import all the macros from the folder that start with that name
add all procedures that start with that name to a commandbar

Oh - and it's best to run it from the sub 'addref' because that will load the right reference library