I want to create custom right click filter menus in Access. I got code that does that, it's below
here's the problem. obviously, a field can be text or numbers. the default Access menu deals with that by creating a group Number Filters or Text Filters.
But my filter doesn't have those groups, and, more importantly, doesn't look at the field type and doesn't hide irrelevant menus like the native one does. In the native one, it seems that they look at the field type, and, based on that, show TEXT FILTERS or NUMBER FILTERS
how do i do that without doing horrible things like program OnClick of every control and reload the menu based on the field type?
like, is there a way to mimic what Access does? Hide irrelevant menus or show a different group based on field type
Public Sub sbFormsShortcutMenu()
Dim cmbRightClick As Office.CommandBar
Dim cmbControl As Office.CommandBarControl
On Error Resume Next
CommandBars("MainRightClick").Delete
Set cmbRightClick = CommandBars.Add("MainRightClick", msoBarPopup, False, True) 'NEW COMMANDBAR
With cmbRightClick
Set cmbControl = .Controls.Add(msoControlButton, 21, , , True) ' Cut
Set cmbControl = .Controls.Add(msoControlButton, 19, , , True) ' Copy
Set cmbControl = .Controls.Add(msoControlButton, 22, , , True) ' Paste
Set cmbControl = .Controls.Add(msoControlButton, 210, , , True) 'Sort AZ 10068
cmbControl.BeginGroup = True
Set cmbControl = .Controls.Add(msoControlButton, 211, , , True) 'Sort ZA 10068
Set cmbControl = .Controls.Add(msoControlButton, 10068, , , True) 'FilterEqualsSelection 10068
cmbControl.BeginGroup = True
Set cmbControl = .Controls.Add(msoControlButton, 10071, , , True) 'FilterNotEqualsSelection 10071
Set cmbControl = .Controls.Add(msoControlButton, 10090, , , True) 'FilterBeginsWithSelection 10090
Set cmbControl = .Controls.Add(msoControlButton, 12265, , , True) 'FilterDoesNotBeginsWithSelection 12265
Set cmbControl = .Controls.Add(msoControlButton, 10076, , , True) 'FilterContainsSelection 10076
Set cmbControl = .Controls.Add(msoControlButton, 10089, , , True) 'FilterDoesNotContainSelection 10089
Set cmbControl = .Controls.Add(msoControlButton, 10091, , , True) 'FilterEndsWithSelection 10091
Set cmbControl = .Controls.Add(msoControlButton, 12266, , , True) 'FilterDoesNotEndWithSelection 12266
Set cmbControl = .Controls.Add(msoControlButton, 10095, , , True) 'FilterSmallerThanSelection 10095
Set cmbControl = .Controls.Add(msoControlButton, 10094, , , True) 'FilterLargerThanSelection 10094
Set cmbControl = .Controls.Add(msoControlButton, 10062, , , True) 'FilterBetween 10062
Set cmbControl = .Controls.Add(msoControlButton, 640, , , True) 'FilterBySelection 640
Set cmbControl = .Controls.Add(msoControlButton, 3017, , , True) 'FilterExcludingSelection 3017
End With
Set cmbControl = Nothing
Set cmbRightClick = Nothing
End Sub
Check the following code
Public Function sbFormsShortcutMenu() 'Make it function not sub
Dim cmbRightClick As Office.CommandBar
Dim cmbControl As Office.CommandBarControl
On Error Resume Next
CommandBars("MainRightClick").Delete
Set cmbRightClick = CommandBars.Add("MainRightClick", msoBarPopup, False, True) 'NEW COMMANDBAR
With cmbRightClick
Set cmbControl = .Controls.Add(msoControlButton, 21, , , True) ' Cut
Set cmbControl = .Controls.Add(msoControlButton, 19, , , True) ' Copy
Set cmbControl = .Controls.Add(msoControlButton, 22, , , True) ' Paste'
Set cmbControl = .Controls.Add(msoControlButton, 210, , , True) 'Sort AZ 10068
cmbControl.BeginGroup = True
Set cmbControl = .Controls.Add(msoControlButton, 211, , , True) 'Sort ZA 10068
Set cmbControl = .Controls.Add(msoControlButton, 10068, , , True) 'FilterEqualsSelection 10068
cmbControl.BeginGroup = True
Set cmbControl = .Controls.Add(msoControlButton, 10071, , , True) 'FilterNotEqualsSelection 10071
If IsNumeric(Screen.ActiveForm.ActiveControl) then 'Check if numeric add numeric options and if not add text options
Set cmbControl = .Controls.Add(msoControlButton, 10095, , , True) 'FilterSmallerThanSelection 10095
Set cmbControl = .Controls.Add(msoControlButton, 10094, , , True) 'FilterLargerThanSelection 10094
Set cmbControl = .Controls.Add(msoControlButton, 10062, , , True) 'FilterBetween 10062
Else
Set cmbControl = .Controls.Add(msoControlButton, 10076, , , True) 'FilterContainsSelection 10076
Set cmbControl = .Controls.Add(msoControlButton, 10089, , , True) 'FilterDoesNotContainSelection 10089
End If
Set cmbControl = .Controls.Add(msoControlButton, 640, , , True) 'FilterBySelection 640
Set cmbControl = .Controls.Add(msoControlButton, 3017, , , True) 'FilterExcludingSelection 3017
End With
Set cmbControl = Nothing
Set cmbRightClick = Nothing
End Function
Then use =sbFormsShortcutMenu() in each "On Mouse Down" event of your controls on the form.
This would make the solution general for any form and any control on it for Numeric and Text type controls.
Of course you could extend it more to check for Date type controls as well and update the menu accordingly :)
Edit: It is not working correctly if the form is used as subform.
I ended up programming every control. I created 2 versions of the above code, here they go
Public Sub sbFormsShortcutMenuNumber()
Dim cmbRightClick As Office.CommandBar
Dim cmbControl As Office.CommandBarControl
On Error Resume Next
CommandBars("MainRightClick").Delete
Set cmbRightClick = CommandBars.Add("MainRightClick", msoBarPopup, False, True) 'NEW COMMANDBAR
With cmbRightClick
Set cmbControl = .Controls.Add(msoControlButton, 21, , , True) ' Cut
Set cmbControl = .Controls.Add(msoControlButton, 19, , , True) ' Copy
Set cmbControl = .Controls.Add(msoControlButton, 22, , , True) ' Paste'
Set cmbControl = .Controls.Add(msoControlButton, 210, , , True) 'Sort AZ 10068
cmbControl.BeginGroup = True
Set cmbControl = .Controls.Add(msoControlButton, 211, , , True) 'Sort ZA 10068
Set cmbControl = .Controls.Add(msoControlButton, 10068, , , True) 'FilterEqualsSelection 10068
cmbControl.BeginGroup = True
Set cmbControl = .Controls.Add(msoControlButton, 10071, , , True) 'FilterNotEqualsSelection 10071
Set cmbControl = .Controls.Add(msoControlButton, 10095, , , True) 'FilterSmallerThanSelection 10095
Set cmbControl = .Controls.Add(msoControlButton, 10094, , , True) 'FilterLargerThanSelection 10094
Set cmbControl = .Controls.Add(msoControlButton, 10062, , , True) 'FilterBetween 10062
Set cmbControl = .Controls.Add(msoControlButton, 640, , , True) 'FilterBySelection 640
Set cmbControl = .Controls.Add(msoControlButton, 3017, , , True) 'FilterExcludingSelection 3017
End With
Set cmbControl = Nothing
Set cmbRightClick = Nothing
End Sub
Public Sub sbFormsShortcutMenuText()
Dim cmbRightClick As Office.CommandBar
Dim cmbControl As Office.CommandBarControl
On Error Resume Next
CommandBars("MainRightClick").Delete
Set cmbRightClick = CommandBars.Add("MainRightClick", msoBarPopup, False, True) 'NEW COMMANDBAR
With cmbRightClick
Set cmbControl = .Controls.Add(msoControlButton, 21, , , True) ' Cut
Set cmbControl = .Controls.Add(msoControlButton, 19, , , True) ' Copy
Set cmbControl = .Controls.Add(msoControlButton, 22, , , True) ' Paste'
Set cmbControl = .Controls.Add(msoControlButton, 210, , , True) 'Sort AZ 10068
cmbControl.BeginGroup = True
Set cmbControl = .Controls.Add(msoControlButton, 211, , , True) 'Sort ZA 10068
Set cmbControl = .Controls.Add(msoControlButton, 10068, , , True) 'FilterEqualsSelection 10068
cmbControl.BeginGroup = True
Set cmbControl = .Controls.Add(msoControlButton, 10071, , , True) 'FilterNotEqualsSelection 10071
Set cmbControl = .Controls.Add(msoControlButton, 10076, , , True) 'FilterContainsSelection 10076
Set cmbControl = .Controls.Add(msoControlButton, 10089, , , True) 'FilterDoesNotContainSelection 10089
Set cmbControl = .Controls.Add(msoControlButton, 640, , , True) 'FilterBySelection 640
Set cmbControl = .Controls.Add(msoControlButton, 3017, , , True) 'FilterExcludingSelection 3017
End With
Set cmbControl = Nothing
Set cmbRightClick = Nothing
End Sub
In case someone is wondering, so far, doesn't seem like performance is affected. on the first right-click when first opening the app - there's a slight lag but after that - instant. But I haven't tested it with the backend being on the server, my backend is on my local drive.
Here's the code used for each control.
So, every form where you want this done has to have the Shortcut Menu set to whatever you named your shortcut bar (in my case it's "MainRightClick") and this can be automated (create a sub that loops through all forms, opens each in design view and sets the shortcut menu to your menu)
To get it to show up in the dropdowns in the Shortcut Menu option in the form - run the above code. It only has to be run once and it will remember it forever. I still have some old test menus saved somewhere somehow which I cant get rid of. No big deal, they just annoy me showing up in the dropdown in design mode :)
Anyway, and then, for each control do this
Private Sub FirstName_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = acRightButton Then
If IsNumeric(Me.FirstName) Then
sbFormsShortcutMenuNumber
Else
sbFormsShortcutMenuText
End If
End If End Sub
I automated this entire process so that I can do this for all my apps and it's not so bad after all
UPDATE:
never mind. this works for regular forms but not with subforms. i'm in the process of trying to figure out if there's a way to easily get parents of a sub but i have a feeling i will be right back where i started: extra lines of code for every MouseDown event
making a change to the #mamadsp answer above
The problem is that me. can't be called in a function. this code isnt tested but should work
so...
Public Function fnFormsShortcutMenu(vrFormName as string, vrFieldName as string)
Dim cmbRightClick As Office.CommandBar
Dim cmbControl As Office.CommandBarControl
On Error Resume Next
CommandBars("MainRightClick").Delete
Set cmbRightClick = CommandBars.Add("MainRightClick", msoBarPopup, False, True) 'NEW COMMANDBAR
With cmbRightClick
Set cmbControl = .Controls.Add(msoControlButton, 21, , , True) ' Cut
Set cmbControl = .Controls.Add(msoControlButton, 19, , , True) ' Copy
Set cmbControl = .Controls.Add(msoControlButton, 22, , , True) ' Paste'
Set cmbControl = .Controls.Add(msoControlButton, 210, , , True) 'Sort AZ 10068
cmbControl.BeginGroup = True
Set cmbControl = .Controls.Add(msoControlButton, 211, , , True) 'Sort ZA 10068
Set cmbControl = .Controls.Add(msoControlButton, 10068, , , True) 'FilterEqualsSelection 10068
cmbControl.BeginGroup = True
Set cmbControl = .Controls.Add(msoControlButton, 10071, , , True) 'FilterNotEqualsSelection 10071
If IsNumeric(forms(vrFormName)(vrFieldName)) then 'Check if numeric add numeric options and if not add text options
Set cmbControl = .Controls.Add(msoControlButton, 10095, , , True) 'FilterSmallerThanSelection 10095
Set cmbControl = .Controls.Add(msoControlButton, 10094, , , True) 'FilterLargerThanSelection 10094
Set cmbControl = .Controls.Add(msoControlButton, 10062, , , True) 'FilterBetween 10062
Else
Set cmbControl = .Controls.Add(msoControlButton, 10076, , , True) 'FilterContainsSelection 10076
Set cmbControl = .Controls.Add(msoControlButton, 10089, , , True) 'FilterDoesNotContainSelection 10089
End If
Set cmbControl = .Controls.Add(msoControlButton, 640, , , True) 'FilterBySelection 640
Set cmbControl = .Controls.Add(msoControlButton, 3017, , , True) 'FilterExcludingSelection 3017
End With
Set cmbControl = Nothing
Set cmbRightClick = Nothing
End Sub
and then each control gets this
Private Sub FirstName_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = acRightButton Then
fnFormsShortcutMenuNumber(me.Name, me.ActiveControl.name)
End If
End Sub
Related
I am trying to create a hyperlink on the newly created shape oSh to the newly created slide oSlide through VBA.
The shape is on a different slide than the newly created slide.
Code to create the shape and the slide.
Private Function GetSectionNumber( _
ByVal sectionName As String, _
Optional ParentPresentation As Presentation = Nothing) As Long
If ParentPresentation Is Nothing Then
Set ParentPresentation = ActivePresentation
End If
GetSectionNumber = -1
With ParentPresentation.SectionProperties
Dim i As Long
For i = 1 To .Count
If .Name(i) = sectionName Then
GetSectionNumber = i
Exit Function
End If
Next i
End With
End Function
Public Function GetLayout( _
LayoutName As String, _
Optional ParentPresentation As Presentation = Nothing) As CustomLayout
If ParentPresentation Is Nothing Then
Set ParentPresentation = ActivePresentation
End If
Dim oLayout As CustomLayout
For Each oLayout In ParentPresentation.SlideMaster.CustomLayouts
If oLayout.Name = LayoutName Then
Set GetLayout = oLayout
Exit For
End If
Next
End Function
Private Sub CommandButton1_Click()
Dim Sld As Slide
Dim Shp As Shape
'ERROR HANDLING
If ActivePresentation.Slides.Count < 5 Then
MsgBox "You do not have any slides in your PowerPoint project."
Exit Sub
End If
Set Sld = Application.ActiveWindow.View.Slide
If Sld.SlideIndex <> 5 Then
MsgBox "You are not on the correct slide."
Exit Sub
End If
Set Sld = Application.ActiveWindow.View.Slide
Call AddCustomSlide
Unload UserForm1
End Sub
Sub AddCustomSlide()
'Create new slide
Dim oSlides As Slides, oSlide As Slide
Dim Shp As Shape
Dim Sld As Slide
Dim SecNum As Integer, SlideCount As Integer, FirstSecSlide As Integer
Set oSlides = ActivePresentation.Slides
Set oSlide = oSlides.AddSlide(oSlides.Count - 2, GetLayout("Processwindow"))
SecNum = GetSectionNumber("Main Process")
With ActivePresentation.SectionProperties
SlideCount = .SlidesCount(SecNum)
FirstSecSlide = .FirstSlide(SecNum)
End With
oSlide.MoveTo toPos:=FirstSecSlide + SlideCount - 1
If oSlide.Shapes.HasTitle = msoTrue Then
oSlide.Shapes.Title.TextFrame.TextRange.Text = TextBox1
End If
'Add SmartArt
'Set Shp = oSlide.Shapes.AddSmartArtApplication.SmartArtLayouts(1)
'Create Flowchart Shape
Dim oSh As Shape
Set oSh = ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeFlowchartPredefinedProcess, 50, 100, 83.52, 41.62)
With oSh
With .TextFrame.TextRange
.Text = TextBox1
With .Font
.Name = "Verdana (Body)"
.Size = 8
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
'.Color.SchemeColor = RGB(255, 255, 255)
End With ' Font
End With ' TextRange
End With ' oSh, the shape itself
End Sub
I'm guessing you want this in the last part that does the font formatting:
Dim URLorLinkLocationText as String
With oSh.TextFrame.TextRange.ActionSettings(ppMouseClick)
.Action = ppActionHyperlink
.Hyperlink.SubAddress = URLorLinkLocationText
End With
I have following code -
Option Explicit
Sub main()
Dim oPPTApp As PowerPoint.Application
Dim oPPTObj As Object
Dim oPPTFile As PowerPoint.Presentation
Dim oPPTShape As PowerPoint.Shape
Dim oPPTSlide As PowerPoint.Slide
Dim oGraph As Graph.Chart
Dim oAxis As Graph.Axis
Dim SlideNum As Integer
Dim strPresPath As String, strNewPresPath As String
strPresPath = "Location.ppt"
strNewPresPath = "Destination.ppt"
'instantiate the powerpoint application and make it visible
Set oPPTObj = CreateObject("PowerPoint.Application")
oPPTObj.Visible = msoCTrue
Set oPPTFile = oPPTObj.Presentations.Open(strPresPath)
SlideNum = 1
Set oPPTSlide = oPPTFile.Slides(SlideNum).Select
Set oPPTShape = oPPTSlide.Add(1, ppLayoutBlank)
oPPTSlide.Shapes.AddTextbox msoTextOrientationHorizontal, 10, 20, 300, 5
With oPPTSlide.Shapes(1).TextFrame.TextRange
.text = "ALL BSE"
.Font.Color = vbWhite
.Font.Underline = msoFalse
End With
End Sub
I get an error
Expected Function or Variable
at the following line:
Set oPPTSlide = oPPTFile.Slides(SlideNum).Select
Any help would be appreciated.
Following my comment above, you can't Set and Select at the same line (also, there's almost never any reason to use Select). Try Set oPPTSlide = oPPTFile.Slides(SlideNum)
However, a few "upgrades" to your code:
Directly set the oPPTShape with the new created Shapes with :
Set oPPTShape = oPPTSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 20, 300, 5)
and afterwards, easily modify the oPPTShape properties, using the With statement below:
With oPPTShape.TextFrame.TextRange
.text = "ALL BSE"
.Font.Color = vbWhite
.Font.Underline = msoFalse
End With
Should be...
Set oPPTSlide = oPPTFile.Slides(SlideNum)
I'm using this macro, to search and replace values in multiple word documents.
The problem is, that I have to many values, that should be changed and it won't run, saying :
Procedure is too large
I tried to find a solution, but nothing worked so far. I would be really grateful, if someone could offer a solution!
Sub DoReplace()
Const Find1 = "FIND TEXT"
Const Replace1 = "REPLACE TEXT"
Const Find2 = "FIND TEXT"
Const Replace2 = "REPLACE TEXT"
Const Find3 = "FIND TEXT"
Const Replace3 = "REPLACE TEXT"
Dim FilePick As FileDialog
Dim FileSelected As FileDialogSelectedItems
Dim WordFile As Variant ' FileName placeholder in selected files loop
Dim FileJob As String ' Filename for processing
Dim WorkDoc As Object
Dim WholeDoc As Range
Dim FooterDoc As Range
On Error GoTo DoReplace_Error
Set FilePick = Application.FileDialog(msoFileDialogFilePicker)
With FilePick
.Title = "Choose Report Template"
.Filters.Clear
.Filters.Add "Word Documents & Templates", "*.do*"
.Filters.Add "Word 2003 Document", "*.doc"
.Filters.Add "Word 2003 Template", "*.dot"
.Filters.Add "Word 2007 Document", "*.docx"
.Filters.Add "Word 2007 Template", "*.dotx"
.Show
End With
Set FileSelected = FilePick.SelectedItems
If FileSelected.Count <> 0 Then
For Each WordFile In FileSelected
FileJob = WordFile
Set WorkDoc = Application.Documents.Open(FileJob, , , , , , , , , , , False)
Set WholeDoc = WorkDoc.Content
Set FooterDoc = WorkDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range
Set FooterPage1 = WorkDoc.Sections(1).Footers(wdHeaderFooterFirstPage).Range
With FooterPage1
.Find.Execute Find1, True, True, , , , True, , , Replace1, wdReplaceAll
.Find.Execute Find2, True, True, , , , True, , , Replace2, wdReplaceAll
.Find.Execute Find3, True, True, , , , True, , , Replace3, wdReplaceAll
End With
With FooterDoc
.Find.Execute Find1, True, True, , , , True, , , Replace1, wdReplaceAll
.Find.Execute Find2, True, True, , , , True, , , Replace2, wdReplaceAll
.Find.Execute Find3, True, True, , , , True, , , Replace3, wdReplaceAll
End With
With WholeDoc.Find
.Execute Find1, True, True, , , , True, , , Replace1, wdReplaceAll
.Execute Find2, True, True, , , , True, , , Replace2, wdReplaceAll
.Execute Find3, True, True, , , , True, , , Replace3, wdReplaceAll
End With
WorkDoc.Save
WorkDoc.Close
Next
End If
MsgBox "Completed"
DoReplace_Exit:
Set WholeDoc = Nothing
Set FilePick = Nothing
Set WorkDoc = Nothing
Set FooterDoc = Nothing
Exit Sub
DoReplace_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure DoReplace of VBA Document ReplaceMulti"
Resume DoReplace_Exit
End Sub
This is a sample of how to approach this situation.
Option Explicit
Sub DoReplace()
Dim FilesSelected As FileDialogSelectedItems
Dim WordFile As Variant ' FileName placeholder in selected files loop
Dim WorkDoc As Document
Dim WholeDoc As Range
Dim FooterDoc As Range
Dim FooterPage1 As Range
Dim arrPair(0 To 2, 0 To 1) As String
On Error GoTo DoReplace_Error
' Load the Array with pairs
arrPair(0, 0) = "FIND TEXT"
arrPair(0, 1) = "REPLACE TEXT"
arrPair(1, 0) = "FIND TEXT"
arrPair(1, 1) = "REPLACE TEXT"
arrPair(2, 0) = "FIND TEXT"
arrPair(2, 1) = "REPLACE TEXT"
' Get all the selected files
Set FilesSelected = GetSelectedFiles
If FilesSelected.Count <> 0 Then
For Each WordFile In FilesSelected
Set WorkDoc = Application.Documents.Open(WordFile, , , , , , , , , , , False)
Set WholeDoc = WorkDoc.Content
Set FooterDoc = WorkDoc.Sections(1).Footers(wdHeaderFooterPrimary).Range
Set FooterPage1 = WorkDoc.Sections(1).Footers(wdHeaderFooterFirstPage).Range
' Replace the values
Call FindAndReplace(arrPair, WholeDoc)
Call FindAndReplace(arrPair, FooterDoc)
Call FindAndReplace(arrPair, FooterPage1)
WorkDoc.Close SaveChanges:=True
Next
End If
MsgBox "Completed"
DoReplace_Exit:
Set WholeDoc = Nothing
Set WorkDoc = Nothing
Set FooterDoc = Nothing
Exit Sub
DoReplace_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure DoReplace of VBA Document ReplaceMulti"
Resume DoReplace_Exit
End Sub
' Procedure to find and replace.
Sub FindAndReplace(ByVal arrValuePair As Variant, ByRef oSection As Object)
Dim i As Long
If UBound(arrValuePair, 2) = 1 Then
With oSection
For i = LBound(arrValuePair, 1) To UBound(arrValuePair, 1)
.Find.Execute arrValuePair(i, 0), True, True, , , , True, , , arrValuePair(i, 1), wdReplaceAll
Next i
End With
End If
End Sub
' Function to get the collection of selected files.
Function GetSelectedFiles() As FileDialogSelectedItems
Dim FilePick As FileDialog
Set FilePick = Application.FileDialog(msoFileDialogFilePicker)
With FilePick
.AllowMultiSelect = True
.Title = "Choose Report Template"
.Filters.Clear
.Filters.Add "Word Documents & Templates", "*.do*"
.Filters.Add "Word 2003 Document", "*.doc"
.Filters.Add "Word 2003 Template", "*.dot"
.Filters.Add "Word 2007 Document", "*.docx"
.Filters.Add "Word 2007 Template", "*.dotx"
.Show
End With
'Return the value
Set GetSelectedFiles = FilePick.SelectedItems
End Function
I hope this helps. :)
I have the following code that builds a custom menu in Excel. Works well. I'm trying to modify it to use sub menus. It will add the menu item for East Options and West Options. I'm trying to modify the East and West # 1 items so they appear as a sub menu. I've tried a number of different things but I haven't got the syntax right. Any help would be appreciated. Thanks.........
Dim cbWsMenuBar As CommandBar
Dim TrCustom As CommandBarControl
Dim iHelpIndex As Long
Dim vFoundMenu As Boolean
Set cbWsMenuBar = Application.CommandBars("Worksheet Menu Bar")
cbWsMenuBar.Visible = True
Dim CCnt As Long
For CCnt = 1 To cbWsMenuBar.Controls.Count
If InStr(1, cbWsMenuBar.Controls(CCnt).Caption, "Translate") > 0 Then vFoundMenu = True
Next CCnt
If vFoundMenu = False Then
Set TrCustom = cbWsMenuBar.Controls.Add(Type:=msoControlPopup) ', before:=iHelpIndex)
With TrCustom
.Caption = "Menu Items”
With .Controls.Add(Type:=msoControlButton)
.Caption = "Business Unit to Group"
.OnAction = "ShowBU2GP"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Group to Business Unit"
.OnAction = "ShowGP2BU"
End With
With .Controls.Add(Type:=msoControlPopup)
.Caption = "East Region Options"
End With
‘ EAST # 1
' With .Controls.Add(Type:=msoControlButton)
' .Caption = "East Branch to DeptID"
' .OnAction = "ShowEastDeptID"
' .BeginGroup = True
' End With
With .Controls.Add(Type:=msoControlPopup)
.Caption = "West Options"
End With
' WEST # 1
' With .Controls.Add(Type:=msoControlButton)
' .Caption = "West Branch to DeptID"
' .OnAction = "ShowWestDeptID"
' .BeginGroup = True
' End With
End With
End If
I will show you a very simple example. Please amend it to suit your needs :)
Private Sub Sample()
Dim cb As CommandBar
Dim cbc As CommandBarControl
Dim newitem As CommandBarControl
Dim newSubItem As CommandBarControl
Set cb = Application.CommandBars(1)
'~~> Delete Existing command bar control
On Error Resume Next
cb.Controls("Menu Items").Delete
On Error GoTo 0
'~~> Re Create the Command Bar Control
Set cbc = cb.Controls.Add(Type:=msoControlPopup, temporary:=False)
With cbc
'~~> Main Heading
.Caption = "Menu Items"
'~~> First Sub Heading
Set newitem = .Controls.Add(Type:=msoControlPopup)
With newitem
.BeginGroup = True
.Caption = "East Region Options"
Set newSubItem = .Controls.Add(Type:=msoControlButton)
With newSubItem
.BeginGroup = True
'~~> Sub Item
.Caption = "Sub Item for East Region Options"
.Style = msoButtonCaption
.OnAction = "SomeMacro"
End With
End With
'~~> Second Sub Heading
Set newitem = .Controls.Add(Type:=msoControlPopup)
With newitem
.BeginGroup = True
.Caption = "West Region Options"
Set newSubItem = .Controls.Add(Type:=msoControlButton)
With newSubItem
.BeginGroup = True
'~~> Sub Item
.Caption = "Sub Item for Est Region Options"
.Style = msoButtonCaption
.OnAction = "SomeMacro"
End With
End With
'
'~~> And So On
'
End With
End Sub
Screenshot
I have a PowerPoint with notes for each slide. For each slide, I want to copy the notes, create a yellow rectangle with black border, and paste the notes into the rectangle.
I started "splicing" a macro together. Here is what I have so far. It works but rectangle is at the top (need at bottom) and not sure how to copy and paste the notes into the rectangle:
Dim oPPT As Presentation
Dim oSlide As Slide
Dim r As Integer
Dim i As Integer
Dim shapectr As Integer
Dim maxshapes As Integer
Dim oShape As Shape
Set oPPT = ActivePresentation
For i = 1 To oPPT.Slides.Count
For shapectr = 1 To oPPT.Slides(i).Shapes.Count
ActiveWindow.View.GotoSlide i
Set oShape = ActiveWindow.Selection.SlideRange.Shapes.AddShape(msoShapeRectangle, 575.5, 9.12, 124.75, 34.12)
oShape.Fill.ForeColor.RGB = RGB(255, 255, 204)
oShape.Fill.BackColor.RGB = RGB(137, 143, 75)
With oShape
With .TextFrame.TextRange
.Text = "TEST"
With .Font
.Name = "Arial"
.Size = 18
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Shadow = msoFalse
.Emboss = msoFalse
.BaselineOffset = 0
.AutoRotateNumbers = msoFalse
.Color.SchemeColor = ppForeground
End With
End With
End With
Next shapectr
Next i
I need to replace "TEST" with the text that is in the notes area of the slide (could be several sentences).
I appreciate your help!
Sub addShp()
Dim osld As Slide
Dim oshp As Shape
Dim oTR As TextRange
For Each osld In ActivePresentation.Slides
On Error Resume Next
osld.Shapes("NOTES").Delete
Set oshp = osld.Shapes.AddShape(msoShapeRectangle, 10, 400, 400, 100)
oshp.Name = "NOTES"
oshp.TextFrame.AutoSize = ppAutoSizeShapeToFitText
oshp.Fill.ForeColor.RGB = RGB(255, 255, 204)
oshp.Line.ForeColor.RGB = RGB(0, 0, 0)
With oshp.TextFrame.TextRange
If Not getNotes(osld) Is Nothing Then .Text = getNotes(osld).Text
.Font.Name = "Arial"
.Font.Size = 10
.Font.Color.RGB = vbBlack
End With
oshp.Top = ActivePresentation.PageSetup.SlideHeight - oshp.Height
Next osld
End Sub
Function getNotes(osld As Slide) As TextRange
' usually shapes(2) but not always
Dim oshp As Shape
For Each oshp In osld.NotesPage.Shapes
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.Type = ppPlaceholderBody Then
If oshp.TextFrame.HasText Then
Set getNotes = oshp.TextFrame.TextRange
End If
End If
End If
Next oshp
End Function
See if this is closer
I figured out the "tweaks" I needed to left justify the text and specify a set height. Here is the final code:
Dim osld As Slide
Dim oshp As Shape
Dim oTR As TextRange
For Each osld In ActivePresentation.Slides
On Error Resume Next
osld.Shapes("NOTES").Delete
Set oshp = osld.Shapes.AddShape(msoShapeRectangle, 20, 400, 400, 300)
oshp.Name = "NOTES"
oshp.TextFrame.AutoSize = ppAutoSizeShapeToFitText
oshp.Fill.ForeColor.RGB = RGB(255, 255, 204)
oshp.Line.ForeColor.RGB = RGB(0, 0, 0)
oshp.Line.Weight = 1.5
With oshp.TextFrame.TextRange
If Not getNotes(osld) Is Nothing Then .Text = getNotes(osld).Text
.Font.Name = "Arial"
.Font.Size = 14
.Font.Color.RGB = vbBlack
.ParagraphFormat.Alignment = msoAlignLeft
End With
oshp.Width = 717
If oshp.Height < 105 Then
oshp.Height = 105
End If
oshp.Left = 1
oshp.Top = ActivePresentation.PageSetup.SlideHeight - oshp.Height
Next osld
End Sub
Function getNotes(osld As Slide) As TextRange
' usually shapes(2) but not always
Dim oshp As Shape
For Each oshp In osld.NotesPage.Shapes
If oshp.Type = msoPlaceholder Then
If oshp.PlaceholderFormat.Type = ppPlaceholderBody Then
If oshp.TextFrame.HasText Then
Set getNotes = oshp.TextFrame.TextRange
End If
End If
End If
Next oshp
End Function
Many thanks for your help!!!