I'm kind of stuck on this code
I need a powerpoint macro which allows me to save all powerpoint files to a particular map with as name "name of presentation" + variable. Anybody a clue whats wrong with code below?
Sub save()
Dim i As Integer
Dim pptcount As Integer
Dim pres As Presentation
Dim var1 As String
Set pres = Application.Presentations(i)
var1 = InputBox("geef hier je maand aan")
pptcount = Application.Presentations.Count
For i = 1 To pptcount
Application.ActivePresentation.SaveAs "X:\SSC_HR\SENS\Bedrijfsbureau\Rapportages\SENS referenten rapportage\Template_Uploaden\" & var1 & ".ppt"
Next
End Sub
Try this code:
Sub save()
Dim pres As Presentation
Dim var1 As String
var1 = InputBox("geef hier je maand aan")
If var1 <> "" Then
For Each pres In Application.Presentations
pres.SaveAs "X:\SSC_HR\SENS\Bedrijfsbureau\Rapportages\SENS referenten rapportage\Template_Uploaden\" & Split(pres.Name, ".")(0) & var1 & ".ppt"
Next
End If
End Sub
Related
I want to scan thorough a slide deck for text boxes containing a search string and leave the active presentation with Active selected slides.
*** I can search ok...>> Creating a list of slides with my text on
Function FindSlidesWithText(ByVal Owner As String) As String
Dim oSl As Slide
Dim oShp As Shape
Dim strSearch As String
Dim i As Integer
Dim slideList As String
If Owner = "" Then
strSearch = InputBox("Enter the text to search for:")
Else
strSearch = Owner
End If
Dim SomeoneSlides As String
SomeoneSlides = ""
SomeoneSlides = ""
For Each oSl In ActivePresentation.Slides
For Each oShp In oSl.Shapes
If oShp.HasTextFrame Then
If InStr(1, oShp.TextFrame.TextRange.Text, strSearch, vbTextCompare) > 0 Then
slideList = slideList & "Slide " & oSl.SlideNumber & ": " & oShp.TextFrame.TextRange.Text & vbCrLf
SomeoneSlides = SomeoneSlides & oSl.SlideNumber & ","
End If
End If
Next
Next
'we now have "search" unique slides.
MsgBox slideList
End Function
*** I note the following works as I want - leaving my in power points seeing highlight boxes around the slides 1,2,5
Dim r1 As SlideRange
Set r1 = ActivePresentation.Slides.Range(Array(1,2, 5)) 'this works
r1.Select
*** However, when i try to create this programmatically i fail (only highlighting the last slide in the array)
'Call SelectSlides("1,2,") '(output from the search)
Sub SelectSlides(YourSlideList As String)
Dim slideArr() As String
'Dim slideNum As Integer
Dim selAry As String
ActiveWindow.ViewType = PpViewType.ppViewNormal
ActiveWindow.Panes(1).Activate
slideArr = Split(YourSlideList, ",")
Dim r1 As SlideRange
For i = 0 To (UBound(slideArr) - 1)
slideNum = CInt(slideArr(i))
selAry = selAry & slideNum
'For all slides selected - modify as needed....
With ActivePresentation.Slides.Range(slideNum)
'Ignore the default background settings.
.FollowMasterBackground = False
'And add a new background color and effect.
.Background.Fill.PresetGradient msoGradientHorizontal, 1, msoGradientDaybreak
End With
Set r1 = ActivePresentation.Slides.Range(Array(slideNum)) 'this works
Next
r1.Select
End Sub
'///this is now working
Sub SelectSlides(YourSlideList As String)
Dim slideArr() As String
'Dim slideNum As Integer
Dim selAry As String
Dim selAry2(99) As Long
ActiveWindow.ViewType = PpViewType.ppViewNormal
ActiveWindow.Panes(1).Activate
slideArr = Split(YourSlideList, ",")
' slideArr2() = Split(YourSlideList, ",")
For i = 0 To (UBound(slideArr) - 1)
slideNum = CInt(slideArr(i))
selAry = selAry & slideNum
selAry2(i) = slideNum
'For all slides selected - modify as needed....
With ActivePresentation.Slides.Range(slideNum)
'Ignore the default background settings.
.FollowMasterBackground = False
'And add a new background color and effect.
.Background.Fill.PresetGradient msoGradientHorizontal, 1, msoGradientDaybreak
End With
Next
Dim r1 As SlideRange
Set r1 = ActivePresentation.Slides.Range(selAry2)
r1.Select
End Sub
I'm investigating how to automatically update a visio file created with one mastershape (v1.0.vssx) to the next version of the mastershape (v1.1.vssx). When updating each master shape, use Master.Name as the key.
With the code below, I was able to open the vsdx file and vssx and open their respective Masters.
vssx_Master = vssxMaster
vsdx_shape.master = vssx_Master
I wondered if I could update the master shape with the code, but unfortunately vssxMaster is the same as vssxMaster.Name and its type is String.
Is there a way to replace the Master of one shape with another?
not work...
Sub Visio_Update(ByRef VISIOpath As String, ByRef except_sheets() As String, ByRef VSSXpath As String)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim vsoApp As Visio.Application
Dim vsoDoc As Visio.Document
Dim vsoPage As Visio.Page
Dim vsoItemsCnt As Long
Dim vsoShape As Visio.Shape
Dim FileName As String
Dim FileText As String
FileName = Dir(VISIOpath)
FileName = Replace(FileName, ".vsdx", "")
ChDir ThisWorkbook.path
Set vsoApp = CreateObject("Visio.Application")
Call vsoApp.Documents.OpenEx(VISIOpath, visOpenRW)
Set vsoDoc = vsoApp.Documents.Item(1)
vsoItemsCnt = vsoApp.Documents.Count
Call vsoApp.Documents.OpenEx(VSSXpath, visOpenRW)
Set vssxDoc = vsoApp.Documents.Item(vsoItemsCnt + 1)
Set vssxMasters = vssxDoc.Masters
For Each vsoPage In vsoDoc.Pages
For Each vsoShape In vsoPage.Shapes
If Not (vsoShape.Master Is Nothing) Then
On Error Resume Next
mastername = vsoShape.Master.Name
vsoShape.ReplaceShape vssxMasters.Item(vsoShape.Master.Name)
If Err.Number = 0 Then
Debug.Print ("Masters.Item")
Debug.Print "updated succeeded : ", mastername
Err.Clear
Else
Debug.Print ("Masters.Item")
Debug.Print Err.Description
Err.Clear
End If
End If
Next
Next
vsoDoc.SaveAs ThisWorkbook.path & "\data\" & FileName & "_updated_.vsdx"
Application.ScreenUpdating = True
End Sub
Sub test()
choosed_path = "C:\Users\11665307\Desktop\data\vs1.vsdx"
Update_Template = "C:\Users\11665307\Documents\test.vssx"
Call Visio_Update(choosed_path, except_sheets, (Update_Template))
End Sub
I wondered if I could update the master shape with the code
You dont need iterate all masters into stencil :)
For Each vsoPage In doc.Pages
For Each vsoShape In vsoPage.Shapes
If Not (vsoShape.Master Is Nothing) Then
vsoShape.ReplaceShape vssxMasters.Item(vsoShape.Master.Name)
End If
Next
Next
You must iterate through all the shapes on the page. If the shape was created based on the master from stencil v.1.0, then replace it with the corresponding master v.1.1. using the ReplaceShape method
Sub ttt()
Dim sh As Shape
For Each sh In ActivePage.Shapes
If sh.Master.NameU = "Circle" Then sh.ReplaceShape Application.Documents.Item("BLOCK_M.vssx").Masters.ItemU("Diamond")
Next
End Sub
I am trying to delete ppt slides using specific keywords.my code is given below:
Private Sub CommandButton1_Click()
Dim strFileName As String
Dim strFolderName As String
Dim PP As Presentation
Dim ppMaster
Dim sText As Variant
strFolderName = "D:\Shaon_Paul\pptss"
strFileName = Dir(strFolderName & "\*.pptx*")
sText = InputBox("Give me some input")
Do While Len(strFileName) > 0
Set PP = Presentations.Open(strFolderName & "\" & strFileName)
Dim oSld As Slide
Dim oShp As Shape
Dim L As Long
For L = ActivePresentation.Slides.Count To 1 Step -1
Set oSld = ActivePresentation.Slides(L)
For Each oShp In oSld.Shapes
On Error Resume Next
If oShp.HasTextFrame Then
If UBound(Split(oShp.TextFrame.TextRange, sText)) > 0 Then
PP.Slides(L).Delete
End If
End If
Next oShp
Next L
Set ppMaster = PP.SlideMaster
With ppMaster
If UBound(Split(.HeadersFooters.Footer.Text, sText)) > 0 Or UBound(Split(.HeadersFooters.Header.Text, sText)) > 0 Then
PP.Slides(L).Delete
End If
End With
PP.Save
PP.Close
strFileName = Dir
Loop
End Sub
Now this code will open a input box where I have to give my keywords and It will delete the slides in a ppt available in the folder where I have mentioned the path name.
Unfortunately while debugging the code
If UBound(Split(oShp.TextFrame.TextRange, sText)) > 0 Then
PP.Slides(L).Delete
End If
it will jump without executing this code above and unable to delete the slide by giving specific keyword name. Need help to resolve this issue.
I am trying to concatenate a URL with many different parts(variables) added to the end of the URL.
I have a button and when you click the button it will takes you to the a specific site using the slide index of the current slide.
When the button is click I want it to go to "google.com/p" + Slide.Index + slide.ID + ActivePresentation.fileName
I know the syntax aren't correct but hopefully you get the GIST.
Currently I have this code:
Private Sub CommandButton21_Click()
Dim projId AS Integer = 617
Dim URL AS String = "www.google.com"
Dim coID = "m01"
Dim coTitle AS String = "New CC Project"
Dim oSl As Slide
Dim pgId
ActivePresentation.FollowHyperlink _
Address:="http://google.com/p" + oSl.SlideID
NewWindow:=True, AddHistory:=True
End Sub
Thanks in advance
This should get you a bit closer:
Private Sub CommandButton21_Click()
' You can't assign values to variables at the same time
' as you DIM them; you CAN do so with Constants:
Const projId As Integer = 617
Const URL As String = "www.google.com"
Const coID As String = "m01"
Const coTitle As String = "New CC Project"
Dim oSl As Slide
'Dim pgId
' You can't just refer to oSl; you have to first tell it WHICH slide
Set oSl = ActivePresentation.Slides(1) ' or whatever slide you want
ActivePresentation.FollowHyperlink _
Address:="http://google.com/p" & oSl.SlideID, _
NewWindow:=True, _
AddHistory:=True
End Sub
& is always evaluated in a string context, while + may not concatenate if one of the operands is no string:
Private Sub CommandButton21_Click()
Dim projId AS Integer
Dim URL AS String = "www.google.com"
Dim coID = "m01"
Dim coTitle AS String = "New CC Project"
Dim oSl As Slide
Dim pgId
projId = 617
ActivePresentation.FollowHyperlink _
Address="http://google.com/p" & oSl.SlideID
NewWindow=True
AddHistory=True
End Sub
I have fixed the issue, view the code below!
Sub CommandButton21_Click()
Dim sl As slide
Dim projId As Integer
Dim coID As String
Dim URL As String
Dim coTitle As String
Dim pgId
URL = "www.google.com"
projId = 617
coID = "m01"
coTitle = "New CC Project"
Set sl = SlideShowWindows(1).View.slide
ActivePresentation.FollowHyperlink _
Address:=URL & projId & "&coIdent=" & coID & "&coTitle=" & coTitle & "&pgIdent=" & sl.slideId & "&pgTitle=" & sl.slideId & "&pageFileName=" & ActivePresentation.FullName & "&pageOrder=" & sl.SlideIndex, _
NewWindow:=True, AddHistory:=True
I have problem with the macro VBA macro. It did work, but now is does not work anymore. Does anybody have a clue what might go wrong?
Sub SaveName()
Dim i As Integer
Dim pptcount As Integer
Dim pptapp As PowerPoint.Presentation
Dim pres As Presentations
Dim var1 As String
Set pptapp = CreateObject("Powerpoint.Application")
pptapp.Visible = True
Set pres = Application.Presentations(i)
var1 = InputBox("geef hier je maand aan")
pptcount = Application.Presentations.Count
For i = 1 To pptcount
Application.ActivePresentation.SaveAs "X:\SSC_HR\SENS\Bedrijfsbureau\Rapportages\SENS referenten rapportage\Template_Uploaden\" & "var1" & ".ppt"
Next
End Sub
Try this instead, see comments:
Sub SaveName()
' VBA will convert this stuff for you
' but internally they're longs
' May as well dim them correctly to start with
Dim i As Long
Dim pptcount As Long
' Dim this as Application, not as presentation:
Dim pptapp As PowerPoint.Application
Dim pres As Presentation
Dim var1 As String
Set pptapp = CreateObject("Powerpoint.Application")
pptapp.Visible = True
Set pres = Application.Presentations(i)
var1 = InputBox("geef hier je maand aan")
pptcount = Application.Presentations.Count
For i = 1 To pptcount
Application.ActivePresentation.SaveAs "X:\SSC_HR\SENS\Bedrijfsbureau\Rapportages\SENS referenten rapportage\Template_Uploaden\" & "var1" & ".ppt"
Next
End Sub
I haven't run it, but at least it compiles now. ;-)
Steve said he didn't RUN it there are several errors and it's not at all clear what it should do.
Not an error but probably not needed
Set pptapp = CreateObject("Powerpoint.Application")
pptapp.Visible = True
ERROR
Set pres = Application.Presentations(i) 'i is zero so it will fail
ERRORS
This is saving the same presentation several times and var1 should NOT be in ""
For i = 1 To pptcount
Application.ActivePresentation.SaveAs "X:\SSC_HR\SENS\Bedrijfsbureau\Rapportages\SENS referenten rapportage\Template_Uploaden\" & "var1" & ".ppt"
Next