I am still beginner in VBA. I have an existing ppt presentation.
I would like to load a Template and to match automatically the slide with the appropriate layaout depending on what it contains (image and/or text and/or title).
I am doing it manually right now.
Sub test21()
Call LoadDesign
ActivePresentation.Slides(1).CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(3)
ActivePresentation.Slides(2).CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(7)
ActivePresentation.Slides(3).CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(3)
End Sub
Sub LoadDesign()
ActivePresentation.Designs.Load TemplateName:="C:\myTemplateFile.pot", Index:=1
End Sub
I am using VS2008 and mso2010.
Thanks in advance for your help.
I assume you can use this snippet to start with and add more conditions based on your needs:
Sub SelectSlideLayout(ByVal slideNumber As Integer)
Dim hasTitle As Boolean
Dim hasPicture As Boolean
Dim hasSubtitle As Boolean
Dim sh As Shape
hasTitle = False
hasPicture = False
hasSubtitle = False
With ActivePresentation.Slides(slideNumber)
For Each sh In .Shapes
If sh.PlaceholderFormat.Type = ppPlaceholderCenterTitle Then
hasTitle = True
ElseIf sh.PlaceholderFormat.Type = ppPlaceholderTitle Then
hasTitle = True
ElseIf sh.PlaceholderFormat.Type = ppPlaceholderSubtitle Then
hasSubtitle = True
ElseIf sh.PlaceholderFormat.Type = ppPlaceholderPicture Then
hasPicture = True
ElseIf sh.PlaceholderFormat.Type = ppPlaceholderBitmap Then
hasPicture = True
ElseIf sh.PlaceholderFormat.Type = ppPlaceholderObject Then
hasPicture = True
Else
'' TODO: Specify more cases
End If
Next sh
End With
If hasTitle And hasSubtitle Then
ActivePresentation.Slides(slideNumber).CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(1)
ElseIf hasTitle And hasPicture Then
ActivePresentation.Slides(slideNumber).CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)
Else
'' TODO: Specify more cases
'Default layout
ActivePresentation.Slides(slideNumber).CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(1)
End If
End Sub
Related
I have some vsto add-in to PowerPoint.
I need to know which part of chart is selected by user (series, title, charta area, plot area, legend etc.). Is it possible to get such information?
I know, of course, how to get selected chart.
My add-in is written in VBA, but I think the below will help you. The PPT object model doesn't support this, so my hacky solution was to apply Strikethrough font as an ExecuteMSO command (i.e., Strikethrough is applied to whatever is selected), then I go through every element of the chart and look for Strikethrough. When we find it, we can tell what the user had selected, apply whatever rules we want, and remove the Strikethrough.
In my case, I wanted to rewrite the Bold command so that we could apply a different font weight to the user's selection, rather than using the native faux-bolding. Here is part of my solution:
First, this is the sub that's called when the selection contains shapes. Note how we handle the chart scenario:
Private Sub commandBoldSelectedShapes(mySelection As Selection)
Debug.Print "IN_commandBoldSelectedShapes"
Dim oShp As Shape
Dim oSmrtArt As SmartArt
Dim oTable As Table
Dim oChart As Chart
Dim oCell As Cell
Dim i As Long
Dim j As Long
Dim ctr As Long
Dim oFont As Font
For ctr = 1 To mySelection.ShapeRange.Count
Set oShp = mySelection.ShapeRange(ctr)
If oShp.Type = msoGroup Then
RefontTypoGroup oShp, mySelection
ElseIf oShp.HasSmartArt Then
Set oSmrtArt = oShp.SmartArt
DoEvents
Application.CommandBars.ExecuteMso ("Strikethrough")
DoEvents
RefontTypoSmartArt oSmrtArt
ElseIf oShp.HasTable Then
Debug.Print "Seeing a table!"
Set oTable = oShp.Table
If ctr = 1 And mySelection.ShapeRange.Count = 1 Then
With oTable
For i = 1 To oTable.Rows.Count
For j = 1 To oTable.Columns.Count
Set oCell = oTable.Rows(i).Cells(j)
If oCell.Selected Then
Set oFont = oCell.Shape.TextFrame.TextRange.Font
checkBoldsNoStrikethrough oFont
End If
Next
Next
End With
Else
For i = 1 To oTable.Rows.Count
For j = 1 To oTable.Columns.Count
Set oCell = oTable.Rows(i).Cells(j)
Set oFont = oCell.Shape.TextFrame.TextRange.Font
checkBoldsNoStrikethrough oFont
Next
Next
End If
' Charts are highly problematic because the VBA Selection object
' doesn't allow you to figure out which element(s) in a chart the user
' may have selected. You can only see that the full shape containing a chart
' has been selected. So my solution was to run an
' ExecuteMso - Strikethrough command. Then, separate macros
' go through the whole chart looking for strikethoughs and replace them
' with bolded/unbolded text and the correct font weight.
ElseIf oShp.HasChart Then
Debug.Print "Seeing a chart!"
Set oChart = oShp.Chart
If ctr = 1 And mySelection.ShapeRange.Count = 1 Then
DoEvents
Application.CommandBars.ExecuteMso ("Strikethrough")
DoEvents
RefontTypoChart oChart
Exit Sub
' If there is more than one shape selected, including a chart,
' and that chart is not the first shape selected, we know that
' the whole chart has been selected. As a result, we can simply
' apply bolding to the whole chart.
Else
With oChart.ChartArea.Format.TextFrame2.TextRange.Font
If GlobalSettings.IsBoldPressed = False Then
.Bold = False
.Name = FontsSettings.ActiveFonts.bodyFont
Else
.Bold = True
.Name = FontsSettings.ActiveFonts.headingFont
End If
End With
End If
ElseIf oShp.HasTextFrame Then
If oShp.TextFrame.HasText Then
Set oFont = oShp.TextFrame.TextRange.Font
checkBoldsNoStrikethrough oFont
End If
End If
Next
End Sub
And there is the sub that starts going through the chart elements. Most checks are outsourcing the Strikethrough hunt to yet another sub:
Sub RefontTypoChart(chrt As Chart)
On Error GoTo Errhandler
' Dim s As Series
Dim A As axis
' Dim scnt As Integer
Dim i As Integer
Dim oShp As Shape
Dim oTxtRange2 As TextRange2
Dim oTickLabels As TickLabels
Dim oLegendEntries As LegendEntries
Set oTxtRange2 = chrt.Format.TextFrame2.TextRange
If oTxtRange2.Font.Strikethrough = msoTrue Then
RefontTypoChartShapeRange oTxtRange2
Exit Sub
End If
If chrt.HasLegend Then
Set oLegendEntries = chrt.Legend.LegendEntries
For i = 1 To oLegendEntries.Count
With oLegendEntries(i).Font
If GlobalSettings.IsBoldPressed = False Then
If .Strikethrough = True Then
.Bold = False
.Name = FontsSettings.ActiveFonts.bodyFont
.Strikethrough = False
End If
Else
If .Strikethrough = True Then
.Bold = True
.Name = FontsSettings.ActiveFonts.headingFont
.Strikethrough = False
End If
End If
End With
Next
With chrt.Legend.Format.TextFrame2.TextRange.Font
If GlobalSettings.IsBoldPressed = False Then
If .Strikethrough = True Then
.Bold = False
.Name = FontsSettings.ActiveFonts.bodyFont
.Strikethrough = False
End If
Else
If .Strikethrough = True Then
.Bold = True
.Name = FontsSettings.ActiveFonts.headingFont
.Strikethrough = False
End If
End If
End With
End If
If chrt.HasTitle Then
Set oTxtRange2 = chrt.ChartTitle.Format.TextFrame2.TextRange
RefontTypoShapeRange oTxtRange2
End If
If chrt.HasAxis(xlCategory, xlPrimary) Then
Set A = chrt.Axes(xlCategory, xlPrimary)
If A.HasTitle = True Then
Set oTxtRange2 = A.AxisTitle.Format.TextFrame2.TextRange
RefontTypoShapeRange oTxtRange2
End If
Set oTickLabels = A.TickLabels
RefontTypoTickLabels oTickLabels
End If
If chrt.HasAxis(xlCategory, xlSecondary) Then
Set A = chrt.Axes(xlCategory, xlSecondary)
If A.HasTitle = True Then
Set oTxtRange2 = A.AxisTitle.Format.TextFrame2.TextRange
RefontTypoShapeRange oTxtRange2
End If
Set oTickLabels = A.TickLabels
RefontTypoTickLabels oTickLabels
End If
If chrt.HasAxis(xlValue, xlPrimary) Then
Set A = chrt.Axes(xlValue, xlPrimary)
If A.HasTitle = True Then
Set oTxtRange2 = A.AxisTitle.Format.TextFrame2.TextRange
RefontTypoShapeRange oTxtRange2
End If
Set oTickLabels = A.TickLabels
RefontTypoTickLabels oTickLabels
End If
If chrt.HasAxis(xlValue, xlSecondary) Then
Set A = chrt.Axes(xlValue, xlSecondary)
If A.HasTitle = True Then
Set oTxtRange2 = A.AxisTitle.Format.TextFrame2.TextRange
RefontTypoShapeRange oTxtRange2
End If
Set oTickLabels = A.TickLabels
RefontTypoTickLabels oTickLabels
End If
RefontTypoChartLabels chrt
If chrt.Shapes.Count > 0 Then
For Each oShp In chrt.Shapes
If oShp.HasTextFrame Then
If oShp.TextFrame.HasText Then
Set oTxtRange2 = oShp.TextFrame2.TextRange
RefontTypoShapeRange oTxtRange2
End If
End If
Next
End If
Exit Sub
Errhandler:
Debug.Print "Error: " & Err.Description
End Sub
Here is the sub that looks for most of the Strikethroughs:
Public Sub RefontTypoShapeRange(oTxtRange2 As TextRange2)
Dim i As Long
With oTxtRange2
For i = .Runs.Count To 1 Step -1
With .Runs(i).Font
If GlobalSettings.IsBoldPressed = False Then
If .Strikethrough = True Then
.Bold = False
.Name = FontsSettings.ActiveFonts.bodyFont
End If
Else
If .Strikethrough = True Then
.Bold = True
.Name = FontsSettings.ActiveFonts.headingFont
End If
End If
End With
Next
.Font.Strikethrough = False
End With
End Sub
You may notice that in the second sub posted, there are references to a few different subs that are specialized for certain chart elements. This is because TickLabels don't have a TextRange2 object and therefore need their own checker sub (one which passes along a TickLabels object). Also, there's a distinction made between chart elements that can have more than one formatting Run, and those that can't -- looking for Runs in the TextRange2 object of chart elements that don't support more than 1 run will cause a crash.
Public Sub RefontTypoChartShapeRange(oTxtRange2 As TextRange2)
Debug.Print "IN_RefontTypoChartShapeRange"
With oTxtRange2.Font
If GlobalSettings.IsBoldPressed = False Then
If .Strikethrough <> msoFalse Then
.Bold = False
.Name = FontsSettings.ActiveFonts.bodyFont
End If
Else
If .Strikethrough <> msoFalse Then
.Bold = True
.Name = FontsSettings.ActiveFonts.headingFont
End If
End If
.Strikethrough = False
End With
End Sub
Chart data labels are a small nightmare too, as they will become disconnected from the data if we don't massage the .Autotext property as seen below.
Sub RefontTypoChartLabels(oChrt As Chart)
Dim i As Integer
Dim j As Integer
Dim seriesVar As Series
Dim dataLabelsVar As DataLabels
Dim dataLabelVar As DataLabel
Dim pointVar As Point
Dim oTxtRange2 As TextRange2
Dim isAutoText As Boolean
For i = 1 To oChrt.SeriesCollection.Count
Set seriesVar = oChrt.SeriesCollection(i)
If seriesVar.HasDataLabels = True Then
Set dataLabelsVar = seriesVar.DataLabels
If dataLabelsVar.Format.TextFrame2.TextRange.Font.Strikethrough <> msoFalse Then
Set oTxtRange2 = dataLabelsVar.Format.TextFrame2.TextRange
RefontTypoChartShapeRange oTxtRange2
Else
For j = 1 To seriesVar.Points.Count
Set pointVar = seriesVar.Points(j)
If pointVar.HasDataLabel = True Then
Set dataLabelVar = seriesVar.DataLabels(j)
isAutoText = dataLabelVar.AutoText
Set oTxtRange2 = dataLabelVar.Format.TextFrame2.TextRange
RefontTypoChartShapeRange oTxtRange2
dataLabelVar.AutoText = isAutoText
End If
Next
End If
End If
Next
End Sub
Hopefully you're able to adapt some of this to your needs and avoid pulling out your hair. You can also use Shadow instead of Strikethrough if you think someone somewhere might need to use Strikethrough font inside a chart.
The PowerPoint object model doesn't provide any property or method for that.
I am new to macros and I right this macro to lock and unlock specific cells according to values from others:
Private Sub Worksheet_Change(ByVal Target As range)
If [$A1] = "Yes" Then
ActiveSheet.Unprotect ("")
[$E:$E].locked = True
[$F:$F].locked = True
[$N:$N].locked = True
[$O:$O].locked = True
[$P:$P].locked = True
[$X:$X].locked = True
[$Y:$Y].locked = True
[$Z:$Z].locked = True
[$AA:$AA].locked = True
[$AB:$AB].locked = True
[$AC:$AC].locked = True
ActiveSheet.Protect ("")
Else
ActiveSheet.Unprotect ("PASSWORD")
[$E:$E].locked = False
[$F:$F].locked = False
[$N:$N].locked = False
[$O:$O].locked = False
[$P:$P].locked = False
[$X:$X].locked = False
[$Y:$Y].locked = False
[$Z:$Z].locked = False
[$AA:$AA].locked = False
[$AB:$AB].locked = False
[$AC:$AC].locked = False
ActiveSheet.Protect ("")
End If
If [$A1] = "No" Then
ActiveSheet.Unprotect ("")
[$B:$B].locked = True
ActiveSheet.Protect ("")
Else
ActiveSheet.Unprotect ("")
[$B:$B].locked = False
ActiveSheet.Protect ("")
End If
End Sub
By $A1 I mean to run the macro on all cells in column A and lock range of columns.
I don't know how to run and test and see if there any errors.
EDIT: i tried this and still can't test it or see how to work with it
Private Sub Worksheet_Change(ByVal Target As range)
If range("A1") = "Yes" Then
range("B1:B4").locked = True
ElseIf range("A1") = "No" Then
range("B1:B4").locked = False
End If
End Sub
Firstly the routine only makes sense if the cell that has changed is A1 - we should ignore this for any other cell.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Dim LockCells As Boolean
LockCells = (UCase(ActiveSheet.Range("A1")) = "YES")
Dim ColsToLock
ColsToLock = Split("E,F,N,O,P,X,Y,Z,AA,AB,AC", ",")
Dim r As Range
Dim x As Integer
ActiveSheet.Unprotect ""
For x = 0 To UBound(ColsToLock) - 1
Set r = ActiveSheet.Columns(ColsToLock(x) & ":" & ColsToLock(x))
r.Locked = LockCells
Next x
ActiveSheet.Protect ""
End If
End Sub
Secondly don't forget to unprotect all cells before you start
I keep getting this error, but can't figure out why. It looks like all rules are followed.
The structure as I read is the following - If -> ElseIf -> End If. But here I get an error though it's all the same.
Sub hide()
Application.ScreenUpdating = False
Dim wRange As Range
Set wRange = Range("A5:B10")
Dim mergedRows As Integer
Dim mergedColumns As Integer
Dim cellFirst As Range
For Each cell In wRange
If IsEmpty(cell) Then
cell.EntireRow.Hidden = True
ElseIf cell.MergeCells Then
mergeRows = cell.MergeArea.Rows.Count
mergeColumns = cell.MergeArea.Columns.Count
With cell.MergeArea
Set cellFirst = cell.MergeArea(Cells(1, 1))
If IsEmpty(cellFirst) Then
cellFirst.EntireRow.Hidden = True
End If
End If
Next
End Sub
You need to also close your With statement.
With cell.MergeArea
Set cellFirst = cell.MergeArea(Cells(1, 1))
If IsEmpty(cellFirst) Then
cellFirst.EntireRow.Hidden = True
End If
End With
At the moment, I have created four different graphs that appear only if they are called in my drop-down box on cell D5. However, I am trying to create a single dynamic graph that populates its data depending on what is in cell D5.
Is this possible?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
' The variable KeyCells contains the cells that will cause an alert when they are changed.
Set KeyCells = Range("D5")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
If Range("D5") = "Tremont" Then
ActiveSheet.ChartObjects("Tremont").Visible = True
ActiveSheet.ChartObjects("SaybrookPointe").Visible = False
ActiveSheet.ChartObjects("21Fitzsimons").Visible = False
ActiveSheet.ChartObjects("Mezzo").Visible = False
ElseIf Range("D5") = "Saybrook Pointe" Then
ActiveSheet.ChartObjects("Tremont").Visible = False
ActiveSheet.ChartObjects("SaybrookPointe").Visible = True
ActiveSheet.ChartObjects("21Fitzsimons").Visible = False
ActiveSheet.ChartObjects("Mezzo").Visible = False
ElseIf Range("D5") = "21 Fitzsimons" Then
ActiveSheet.ChartObjects("Tremont").Visible = False
ActiveSheet.ChartObjects("SaybrookPointe").Visible = False
ActiveSheet.ChartObjects("21Fitzsimons").Visible = True
ActiveSheet.ChartObjects("Mezzo").Visible = False
ElseIf Range("D5") = "Mezzo" Then
ActiveSheet.ChartObjects("Tremont").Visible = False
ActiveSheet.ChartObjects("SaybrookPointe").Visible = False
ActiveSheet.ChartObjects("21Fitzsimons").Visible = False
ActiveSheet.ChartObjects("Mezzo").Visible = True
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
' The variable KeyCells contains the cells that will cause an alert when they are changed.
Set KeyCells = Range("D5")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
If Range("D5") = "Tremont" Then
Activesheet.Chartobjects("Single_Dynamic_Chart").FullSeriesCollection(1).XValues = Range(X_axis_values)
Activesheet.Chartobjects("Single_Dynamic_Chart").FullSeriesCollection(1).Name = "Tremont"
Activesheet.Chartobjects("Single_Dynamic_Chart").FullSeriesCollection(1).Values = Range(Y_axis_values)
'If a bar graph,
with Selection.Format.Fill
.Visible = msoTrue
.ForeColor.RGB= RGB(0,0,0)
.Transparency = 0
.Solid
End With
ElseIf Range("D5") = "Saybrook Pointe" Then
Activesheet.Chartobjects("Single_Dynamic_Chart").FullSeriesCollection(1).XValues = Range(X_axis_values)
Activesheet.Chartobjects("Single_Dynamic_Chart").FullSeriesCollection(1).Name = "Saybrook Pointe"
Activesheet.Chartobjects("Single_Dynamic_Chart").FullSeriesCollection(1).Values = Range(Y_axis_values)
'If a bar graph,
with Selection.Format.Fill
.Visible = msoTrue
.ForeColor.RGB= RGB(0,0,0)
.Transparency = 0
.Solid
End With
ElseIf Range("D5") = "21 Fitzsimons" Then
'Similarly like above cases, define the X-axis,the series name and the values.
ElseIf Range("D5") = "Mezzo" Then
'Similarly like above cases, define the X-axis,the series name and the values.
End If
End If
End Sub
Following these links would give you more information on how to work more on charts
Intoduction to charts
Chart series elements
I see no problem with this. But you can make it simpler and avoid hardcoding the names, and you can save some inc as well:
Dim ch As ChartObject
For Each ch in ActiveSheet.ChartObjects
ch.Visible = ch.Name = Range("D5").Value
Next
But, well, you need to remove the spaces from the names in the D5 list, letting them be exactly equal to the charts' names.
I am not new to programming, but I am new to using macros in Excel. I am using Excel 2010, trying to run the following macro:
Sub HideUnhideCells(ByVal Target As Range)
Dim keyCell As Range
Set keyCell = Range("C9")
Dim Cells1 As Range
Dim Cells2 As Range
'Call the function on C9 cell change
If Target.Address = "$C$9" Then
'Make Data Source available for for DRG and UCR
If keyCell.Value = "DRG" Or keyCell.Value = "UCR" Then
Set Cells1 = Range("C33")
Cells1.EntireRow.Hidden = False
Else
Set Cells1 = Range("C33")
Cells1.EntireRow.Hidden = True
End If
'Make MSA special cells available if MSA is selected
If keyCell.Value = "MSA" Then
Set Cells1 = Range("B34:C35")
Cells1.EntireRow.Hidden = False
Else
Set Cells1 = Range("B34:C35")
Cells1.EntireRow.Hidden = True
End If
'Make UCR cells available if UCR is selected
If keyCell.Value = "UCR" Then
Set Cells1 = Range("B36:C39")
Cells1.EntireRow.Hidden = False
Else
Set Cells1 = Range("B36:C39")
Cells1.EntireRow.Hidden = True
End If
'Remove extra name cells for 1-file and 2-file values
If keyCell.Value = "DRG" Or keyCell.Value = "ICD-9" Or keyCell.Value = "NCCI_Edits" Or keyCell.Value = "UB04" Then
Set Cells1 = Range("B21:C25")
Set Cells2 = Range("B28:C32")
Cells1.EntireRow.Hidden = True
Cells2.EntireRow.Hidden = True
ElseIf keyCell.Value = "ICD-10" Or keyCell.Value = "NDC" Then
Set Cells1 = Range("B22:C25")
Set Cells2 = Range("B29:C32")
Cells1.EntireRow.Hidden = True
Cells2.EntireRow.Hidden = True
Else
Set Cells1 = Range("B21:C25")
Set Cells2 = Range("B28:C32")
Cells1.EntireRow.Hidden = False
Cells2.EntireRow.Hidden = False
End If
End If
End Sub
I have seen several postings and tutorials that talk about this, but I can't understand why this won't work. Cell C9 is a dropdown list, and I want this macro to run so that cells are shown / not shown based on what is selected in the list. However, if I give it parameters (as shown above) I can't run it in the UI, and if I don't give it parameters, I can only run it manually, which doesn't help me much.
Right now, when I select something from that C9 dropdown list, nothing happens. Can anyone help me figure out why?
Your code looked ripe for a Select Case treatment and there were several things to add about the Worksheet_Change event macro (too many for a comment) so I went ahead and wrote up a draft of the Sub Worksheet_Change. I'm not sure if I have interpreted all of the If ElseIf Else End If but perhaps you can see what I'm trying to do with this.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$C$9" Then
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo Whoa
Rows("21:25").EntireRow.Hidden = False
Rows("28:32").EntireRow.Hidden = False
Rows("33:39").EntireRow.Hidden = True
Select Case Target.Value
Case "DRG"
Rows("33").EntireRow.Hidden = False
Case "MSA"
Rows("34:35").EntireRow.Hidden = False
Case "UCR"
Rows("33").EntireRow.Hidden = False
Rows("36:39").EntireRow.Hidden = False
Case "DRG", "ICD-9", "NCCI_Edits", "UB04"
Rows("21:25").EntireRow.Hidden = True
Rows("28:32").EntireRow.Hidden = True
Case "ICD-10", "NDC"
Rows("22:25").EntireRow.Hidden = True
Rows("29:32").EntireRow.Hidden = True
Case Else
'do nothing
End Select
End If
FallThrough:
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume FallThrough
End Sub
Post back into Comments with any problem you have transcribing this for your own purposes and I'll try to assist.