Sub Replace_Personal() ' перенос макросов и настройки видимых панелей на другой компьютер Const NewPath$ = "'C:\Users\MyNewUserName\AppData\Roaming\Microsoft\Excel\XLSTART\PERSONAL.XLS'!" ' если переносить на Vista 'Const NewPath$ = "'C:\Documents and Settings\MyNewUserName\Application Data\Microsoft\Excel\XLSTART\PERSONAL.XLS'!" ' если переносить на XP Dim cmdBar As Object, iBtn As Object, sPath$ For Each cmdBar In Application.CommandBars If cmdBar.Visible Then For Each iBtn In cmdBar.Controls On Error Resume Next sPath = iBtn.OnAction If Len(sPath) > 0 Then If InStr(1, sPath, "'!", 1) > 0 Then iBtn.OnAction = NewPath & Mid(sPath, InStr(1, sPath, "!", 1) + 1) End If Next iBtn End If Next cmdBarEnd Sub
If cmdBar.Visible Then …
For Each cmdBar In Application.CommandBars If cmdBar.Visible Then For Each iBtn In cmdBar.Controls If iBtn.Type <> 1 Then For Each oSubBtn In iBtn sPath = iBtn.OnAction If Len(sPath) > 0 Then If InStr(1, sPath, "'!", 1) > 0 Then iBtn.OnAction = NewPath & Mid(sPath, InStr(1, sPath, "!", 1) + 1) End If Next oSubBtn End If sPath = iBtn.OnAction If Len(sPath) > 0 Then If InStr(1, sPath, "'!", 1) > 0 Then iBtn.OnAction = NewPath & Mid(sPath, InStr(1, sPath, "!", 1) + 1) End If Next iBtn End If Next cmdBar
For Each oSubBtn In iBtn
If iBtn.Type = 1 Then ' msoBarTypeMenuBar
Sub Replace_Personal() ' ïåðåíîñ ìàêðîñîâ è íàñòðîéêè âèäèìûõ ïàíåëåé íà äðóãîé êîìïüþòåð Const NewPath$ = "'C:\Users\MyNewUserName\AppData\Roaming\Microsoft\Excel\XLSTART\PERSONAL.XLS'!" ' åñëè ïåðåíîñèòü íà Vista'Const NewPath$ = "'C:\Documents and Settings\MyNewUserName\Application Data\Microsoft\Excel\XLSTART\PERSONAL.XLS'!" ' åñëè ïåðåíîñèòü íà XP Dim cmdBar As Object, iBtn As Object, sPath$, oSubBtn As Object For Each cmdBar In Application.CommandBars If cmdBar.Visible Then Debug.Print cmdBar.Name For Each iBtn In cmdBar.Controls On Error Resume Next If iBtn.Type = 10 Then For Each oSubBtn In iBtn.Controls sPath = oSubBtn.OnAction If Len(sPath) > 0 Then If InStr(1, sPath, "'!", 1) > 0 Then oSubBtn.OnAction = NewPath & Mid(sPath, InStr(1, sPath, "!", 1) + 1) End If Next oSubBtn Else sPath = iBtn.OnAction If Len(sPath) > 0 Then If InStr(1, sPath, "'!", 1) > 0 Then iBtn.OnAction = NewPath & Mid(sPath, InStr(1, sPath, "!", 1) + 1) End If End If Next iBtn End If Next cmdBarEnd Sub
Option ExplicitConst NewPath$ = "'C:\Users\MyNewUserName\AppData\Roaming\Microsoft\Excel\XLSTART\PERSONAL.XLS'!" ' если переносить на Vista'Const NewPath$ = "'C:\Documents and Settings\MyNewUserName\Application Data\Microsoft\Excel\XLSTART\PERSONAL.XLS'!" ' если переносить на XPDim sPath As StringSub Replace_Personal() ' перенос макросов и настройки видимых панелей на другой компьютер Dim cmdBar As Object, iBtn As Object, oSubBtn As Object For Each cmdBar In Application.CommandBars For Each iBtn In cmdBar.Controls On Error Resume Next If iBtn.Type = 10 Then Call Popup_Btns(iBtn.Controls) Else sPath = iBtn.OnAction If Len(sPath) > 0 Then If InStr(1, sPath, "'!", 1) > 0 Then iBtn.OnAction = NewPath & Mid(sPath, InStr(1, sPath, "!", 1) + 1) End If End If Next iBtn Next cmdBarEnd SubFunction Popup_Btns(oSubPopupBtns As Object) Dim oSubBtn As Object, iBtn As Object For Each oSubBtn In oSubPopupBtns If oSubBtn.Type = 10 Then Call Popup_Btns(oSubBtn.Controls) Else sPath = oSubBtn.OnAction If Len(sPath) > 0 Then If InStr(1, sPath, "'!", 1) > 0 Then iBtn.OnAction = NewPath & Mid(sPath, InStr(1, sPath, "!", 1) + 1) End If End If Next oSubBtnEnd Function
Function Popup_Btns(oSubPopupBtns As Object) Dim oSubBtn As Object For Each oSubBtn In oSubPopupBtns If oSubBtn.Type = 10 Then Call Popup_Btns(oSubBtn.Controls) Else sPath = oSubBtn.OnAction If Len(sPath) > 0 Then If InStr(1, sPath, "'!", 1) > 0 Then oSubBtn.OnAction = NewPath & Mid(sPath, InStr(1, sPath, "!", 1) + 1) End If End If Next oSubBtnEnd Function