AuthorWrite something about yourself. No need to be fancy, just an overview. ArchivesCategories |
Back to Blog
Power utility pack for excel12/17/2023 ![]() OnAction = ThisWorkbook.Name & "!" & MenuSheet.Cells(r, 4). ![]() Set UtilityMenu = Application.CommandBars(MenuBarIndex).Controls.Add(Type:=msoControlPopup, Before:=MenuPos, Temporary:=True) UtilityMenu.Caption = MENUNAME For r = 2 To LASTROW If Not IsEmpty(MenuSheet.Cells(r, 2)) Then ' add menu item If IsEmpty(MenuSheet.Cells(r, 3)) Then Set Level1 = (Type:=msoControlButton, Temporary:=True) With Level1. Set MenuSheet = ThisWorkbook.Sheets(1) For MenuBarIndex = 1 To 2 On Error Resume Next Application.CommandBars(MenuBarIndex).Controls(MENUNAME).Delete MenuPos = 10 MenuPos = Application.CommandBars(MenuBarIndex).FindControl(ID:=30009).Index 'Window menu On Error GoTo 0 Sub MakeMenu() Dim MenuSheet As Worksheet Dim MenuPos As Long, r As Long Dim UtilityMenu As CommandBarControl, Level1 As CommandBarControl, Level2 As CommandBarControl Dim MenuBarIndex As Long Sub RunLastUtility() On Error Resume Next If GetSetting(PUPNAME, "Settings", "cbRememberLastUtility", 1) = 1 Then Application.Run LastUtility On Error GoTo 0 End Sub Cells(r, 8) = True Then LastUtility = ThisUtility If GetSetting(PUPNAME, "Settings", "cbRememberLastUtility", 1) = 1 Then Application.MacroOptions Macro:=ThisWorkbook.Name & "!RunLastUtility", HasShortcutKey:=True, ShortcutKey:="R" Else Application.MacroOptions Macro:=ThisWorkbook.Name & "!RunLastUtility", HasShortcutKey:=False, ShortcutKey:="" End If End If ' Run it On Error Resume Next Application.Run ThisUtility On Error GoTo 0 End With End Sub Cells(r, 12) = Application.Max(MenuSheet.Range("L:L")) + 1 Call CloseExcessUtilities On Error Resume Next ThisUtility = "'" & FName & "'!" & ProcName If. This file should be located in" & ThisWorkbook.Path, vbCritical, PUPNAME Exit Sub End If On Error GoTo 0 If. Cells(r, 1) On Error Resume Next If Not BookOpen(FName) Then Workbooks.Open ThisWorkbook.Path & "\" & FName If Err 0 Then MsgBox UCase(FName) & vbCrLf & "File not found. Sub RunUtility() Dim r As Long, FName As String, ProcName As String Dim MenuSheet As Worksheet, UtilName As String Dim ThisUtility As String Set MenuSheet = ThisWorkbook.Sheets("Sheet1") If phe() = True Then MenuSheet.Range("A1") = "" UserForm2.Show Exit Sub End If r = With MenuSheet FName =. Option Explicit Option Private Module Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long Private Declare Function HtmlHelp Lib "HHCtrl.ocx" Alias "HtmlHelpA" (ByVal hwndCaller As Long, ByVal pszFile As String, ByVal uCommand As Long, ByVal dwData As Long) As Long Declare Function RegOpenKeyA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sSubKey As String, ByRef hkeyResult As Long) As Long Declare Function RegCloseKey Lib "ADVAPI32.DLL" (ByVal hKey As Long) As Long Declare Function RegSetValueExA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sValueName As String, ByVal dwReserved As Long, ByVal dwType As Long, ByVal sValue As String, ByVal dwSize As Long) As Long Declare Function RegCreateKeyA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sSubKey As String, ByRef hkeyResult As Long) As Long Declare Function RegQueryValueExA Lib "ADVAPI32.DLL" (ByVal hKey As Long, ByVal sValueName As String, ByVal dwReserved As Long, ByRef lValueType As Long, ByVal sValue As String, ByRef lResultLen As Long) As Long Public Const PUPNAME As String = "Power Utility Pak" Public Const MENUNAME As String = "&PUP v6" Public Const SCMENUFILE As String = "shortcut menus.pup" Public Const SCMENUITEM As Long = 11 Public Const BMFILE As String = "pup bookmarks.pup" Public Const BMMENUITEM As Long = 12 Public Const LASTROW As Long = 83 Public LastUtility As String
0 Comments
Read More
Leave a Reply. |