I have a Word file with approximately 10 pages and 20 tables. Some of these tables have checkboxes. I want to copy these tables into an Excel file.
The following code copies all tables from my Word file into my Excel file:
Sub Import()
Option Explicit
Dim wb As Workbook
Dim sh As Worksheet
Dim sheet As Worksheet
Dim lzeile As Integer
Set wb = ActiveWorkbook
Set sh = wb.ActiveSheet
Set sheet = wb.Worksheets("Tabelle1")
Dim Btxt As Object
Set Btxt = CreateObject("Word.Application")
Btxt.Visible = True
Btxt.documents.Open "C:\Users\*.doc" '*=path
lzeile = 0
For i = 1 To 20
Btxt.ActiveDocument.Tables(i).Range.Copy
Application.Goto sheet.Cells(1 + lzeile, 1)
sheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False
lzeile = sheet.Cells(Rows.Count, 1).End(xlUp).Row
lzeile = lzeile + 1
sheet.Cells(lzeile, 1) = "Tabelle" & i
Next i
Btxt.Quit
Set Btxt = Nothing
Set wb = Nothing
Set sh = Nothing
End Sub
It does not copy checkboxes or the value (0 = not checked / 1 = checked) of the checkbox.
I can write the value of a checkbox into a cell in my excel sheet with this line:
sheet.Cells(j, 10) = Btxt.ActiveDocument.Tables(i).FormFields.Item("Kontrollkästchen" & j).Result
With a loop j over all "Kontrollkästchen" (german translation of contentcontrol or formfield item) so basically the name of all formfield items in this Word file.
How can I get the position of these formfield items or identify which formfield item / ContentControl is in which table?
I tried to go through all rows and columns in each table because none of them are larger than 10x10. But I can´t find a way to check if a checkbox is maybe in table 3 on column 5 row 5 and then read the name of this checkbox to a safe the value (0 / 1) in the Excel cell on the same position in my copied table.
The solution depends on whether they're formfields or content controls.
Assuming they're formfields:
Sub Demo()
Dim i As Long, j As Long, Rng As Range
With ActiveDocument
For i = .FormFields.Count To 1 Step -1
With .FormFields(i)
If .Type = wdFieldFormCheckBox Then
j = Abs(.CheckBox.Value)
Set Rng = .Range
.Delete
Rng.Text = j
End If
End With
Next
End With
End Sub
Assuming they're content controls:
Sub Demo()
Dim i As Long, j As Long, Rng As Range
With ActiveDocument
For i = .ContentControls.Count To 1 Step -1
With .ContentControls(i)
If .Type = wdContentControlCheckBox Then
j = Abs(.Checked)
Set Rng = .Range
.Delete
Rng.Text = j
End If
End With
Next
End With
End Sub
For the sake of simplicity and clarity, the sample code below leaves out the parts having to do with Excel, as well as creating the instance of the Word Application. It shows only how to access the Word document's checkboxes and convert those to static values.
At the end, also, the document is closed without saving changes, which means forms protection and the checkboxes should be left intact - the macro will not have affected them.
Note: You should have Option Explicit at the top of the code page, not inside a "Sub".
How it works
The document to be processed is opened and at that moment set to an object (doc). Use this instead of ActiveDocument as it will be much clearer and, in case the user would try to do something, won't affect macro execution.
If the document has forms protection, this must be turned off in order to delete the checkboxes and insert static values.
Then all the form fields are looped. If they are checkboxes, the value is determined, the checkbox removed and the value assigned to the range the checkbox occupied.
After this has completed comes the code to transfer data to Excel. Then the document is closed without saving changes.
Sub ConvertCheckBoxesToValues()
Dim ff As Object ' Word.FormField
Dim doc As Object ' Word.Document
Dim cbValue As String
Dim rngFF As Object ' Word.Range
Set doc = Btxt.Documents.Open("C:\Users\*.doc") '*=path
If doc.ProtectionType <> -1 Then 'wdNoProtection
doc.Unprotect
End If
For Each ff In doc.FormFields
If ff.Type = 71 Then 'wdFieldFormCheckBox
If ff.CheckBox.value = True Then
cbValue = "1"
Else
cbValue = "0"
End If
Set rngFF = ff.Range
ff.Delete
rngFF = cbValue
End If
Next
'Transfer the information to Excel, then
doc.Close 0 'wdDoNotSaveChanges
End Sub
I'm trying to make an Advanced Search now for weeks in my Userform where it will filter and display the result on the ListBox while typing a value. But somehow my ComboBox that serves as a filter has a dropdown function already.
I have no idea how can I make it like the way I wanted it.
My UserForm contains 8 columns.
Here is the existing code for the ComboBox filter
Private Sub cmbSearch_Change()
'The function of this code below is for the user to click a value from the ComboBox and then the result will be displayed on the TextBoxes and ListBox.
x = Sheets("DATA STOCK").Range("A" & Rows.Count).End(xlUp).Row
For y = 2 To x
If Sheets("DATA STOCK").Cells(y, 1).Text = cmbSearch.Value Then
cmbSchema.Text = Sheets("DATA STOCK").Cells(y, 1)
cmbEnvironment.Text = Sheets("DATA STOCK").Cells(y, 2)
cmbHost.Text = Sheets("DATA STOCK").Cells(y, 3)
cmbIP.Text = Sheets("DATA STOCK").Cells(y, 4)
cmbAccessible.Text = Sheets("DATA STOCK").Cells(y, 5)
cmbLast.Text = Sheets("DATA STOCK").Cells(y, 6)
cmbConfirmation.Text = Sheets("DATA STOCK").Cells(y, 7)
cmbProjects.Text = Sheets("DATA STOCK").Cells(y, 8)
UserForm1.listHeader.RowSource = "A" + CStr(y) + ": H" + CStr(y)
Exit For
End If
Next y
End Sub
Expected Result:
User types word in the ComboBox (I have selected ComboBox as a filter because of its dropdown function)
While the user is typing, it will show the result to the ListBox.
The problem is I don't know how to create that kind of search filter and if it is possible even though I already have a dropdown function in my ComboBox
Saw that you've been working for weeks on this.
I have refactored your form's code and implemented the functionality you've been looking for.
As my other answer to your other question, in my opinion it's easier to work adding and removing items to the listbox, rather than working with excel ranges. (How to fix this bug in my code that doesn't allow me to update other columns in excel userform?)
Important remarks:
- I've converted the data inside the sheet to an Excel Structured Table (Ctrl + T)
- I took one of your previous files, so the information you have inside the table may be out of date
- Testing I also modified some of the data
- I suggest you copy and paste your most recent data and replace it inside the table
Here you can download the file based on your data:
https://github.com/rdiazjimenez/excel-vba-userform-basic-listbox-demo/blob/master/MDM_DB_Checking_09122018_RD.xlsm
I covered basic operations (Create, Read, Update, Delete and Search/Filter) with Excel Data loaded into a Listbox inside a Userform.
This is the code behind the form:
Option Explicit
' Code updated
Private Sub btnDelete_Click()
Application.EnableEvents = False
Call mCode.Delete
Application.EnableEvents = True
End Sub
' Code updated
Private Sub btnView_Click()
Application.EnableEvents = False
Call mCode.Read
Application.EnableEvents = True
End Sub
' Code updated
Private Sub cmbAdd_Click()
Application.EnableEvents = False
Call mCode.Create
Application.EnableEvents = True
End Sub
' Code updated
Private Sub cmbClearFields_Click()
Application.EnableEvents = False
Call mCode.ClearControls
Application.EnableEvents = True
End Sub
' Code updated
Private Sub cmbSearch_Change()
Application.EnableEvents = False
Call FilterList(Me.listHeader, Me.cmbSearch.Text)
Application.EnableEvents = True
End Sub
' Code updated
Private Sub cmbUpdate_Click()
Application.EnableEvents = False
Call mCode.Update
Application.EnableEvents = True
End Sub
' Code updated
Private Sub CommandButton5_Click()
Application.EnableEvents = False
Call mCode.ClearList
Application.EnableEvents = True
End Sub
' Code from this event was removed
Private Sub listHeader_Click()
End Sub
' Code added
Private Sub listHeader_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Application.EnableEvents = False
Call mCode.LoadControls
Application.EnableEvents = True
End Sub
' Code partially updated
Private Sub UserForm_Initialize()
Me.cmbSearch.List = ThisWorkbook.Sheets("PRESTAGE DB").ListObjects("TableData").ListColumns(1).DataBodyRange.Value
Me.cmbEnvironment.AddItem "DEV"
Me.cmbEnvironment.AddItem "UAT"
Me.cmbEnvironment.AddItem "SIT"
Me.cmbEnvironment.AddItem "QA"
Me.cmbEnvironment.AddItem "PROD"
Me.cmbAccessible.AddItem "Y"
Me.cmbAccessible.AddItem "N"
Me.cmbIP.AddItem "1521"
Me.cmbProjects.AddItem "DP - proposed for DEV/SIT"
Me.cmbProjects.AddItem "PH EFUSE SIT"
Me.cmbProjects.AddItem "MyAXA SG DEV/DIT"
End Sub
And this is the code inside a module called mCode:
Option Explicit
' Global variables
Const sheetName As String = "PRESTAGE DB"
Const tableName As String = "TableData"
Public Sub ShowUserForm()
oUserForm.Show
End Sub
Public Sub Read()
' Comments: Loads the data from an excel table (listobject) into a listbox located inside a userform
' Params :
' Notes : Adapt the initialize variables section
' Created : 2019/01/25 RD www.ricardodiaz.co
' Modified:
' Define objects variables
Dim myUserForm As oUserForm ' Note: you're defining the variable as the class of the userform. This gives you access to the userform's controls later
Dim myListObject As Excel.listObject
Dim myRange As Excel.Range
' Define other variables
Dim columnCount As Integer
Dim selectedItem As Integer
Dim rowCounter As Long
Dim columnCounter As Integer
'''''''' Initialize objects ''''''''
' Init the userform
' Note: When you initialize it directly with the name of the form, you can access the controls of the userform too
Set myUserForm = oUserForm
' Load the data from the Excel table into a range variable
' Note: It's safer to refer to thisworkbook
Set myListObject = ThisWorkbook.Worksheets(sheetName).ListObjects(tableName)
'''''''' Initialize variables ''''''''
myUserForm.listHeader.ColumnWidths = "130 pt;60 pt;82 pt;55 pt;70 pt;195 pt;170 pt;130 pt"
' Set the number of columns to the same of the table in the Excel sheet
columnCount = myListObject.ListColumns.Count
' Get the current selected item
selectedItem = myUserForm.listHeader.ListIndex ' this returns -1 if none is selected
' Clear the listbox contents
Call mCode.ClearList
' Set the number of columns to load into the listbox
myUserForm.listHeader.columnCount = columnCount
' Loop through each row and load it into the listbox
' Note: begins with 2 because the first row are the table headers
For rowCounter = 2 To myListObject.Range.Rows.Count
With myUserForm.listHeader
.AddItem
' Load value of each column in the table row
For columnCounter = 0 To columnCount
.List(rowCounter - 2, columnCounter) = myListObject.Range.Cells(rowCounter, columnCounter + 1).Value
Next columnCounter
End With
Next
' Select previously selected row
If selectedItem < myUserForm.listHeader.ListCount Then
myUserForm.listHeader.ListIndex = selectedItem
End If
' Clean up objects
Set myListObject = Nothing
Set myUserForm = Nothing
End Sub
Public Sub Create()
' Comments: Adds a new row with the data entered by the user and reloads the listbox inside the userform
' Params :
' Notes : Adapt the initialize variables section
' Created : 2019/01/25 RD www.ricardodiaz.co
' Modified:
' Define objects variables
Dim myUserForm As oUserForm ' Note: you're defining the variable as the class of the userform. This gives you access to the userform's controls later
Dim myListObject As Excel.listObject
Dim myListRow As Excel.listRow
'''''''' Initialize objects ''''''''
' Init the userform
' Note: When you initialize it directly with the name of the form, you can access the controls of the userform too
Set myUserForm = oUserForm
' Add the information to the Excel table
Set myListObject = ThisWorkbook.Worksheets(sheetName).ListObjects(tableName)
' Validate if all the information is correct
If myUserForm.cmbEnvironment.Text = vbNullString _
Or myUserForm.cmbHost.Text = vbNullString _
Or myUserForm.cmbIP.Text = vbNullString _
Or myUserForm.cmbAccessible.Text = vbNullString _
Or myUserForm.cmbLast.Text = vbNullString Then
MsgBox "Some fields cannot be blank!", vbCritical, "Data Missing"
Exit Sub
End If
' Add a blank row at the end of the Excel table
Set myListRow = myListObject.ListRows.Add
' Set the information into de excel table
With myListRow
.Range(1) = myUserForm.cmbSchema.Text
.Range(2) = myUserForm.cmbEnvironment.Text
.Range(3) = myUserForm.cmbHost.Text
.Range(4) = myUserForm.cmbIP.Text
.Range(5) = myUserForm.cmbAccessible.Text
.Range(6) = myUserForm.cmbLast.Text
.Range(7) = myUserForm.cmbConfirmation.Text
.Range(8) = myUserForm.cmbProjects.Text
End With
MsgBox "Data Added!"
' Reload the data into the listbox
Call mCode.Read
' Select the last item in the listbox
myUserForm.listHeader.ListIndex = myUserForm.listHeader.ListCount - 1
' Clear control's contents
Call ClearControls ' Note that this is a private procedure inside the mCode module
' Clean up objects
Set myListRow = Nothing
Set myListObject = Nothing
Set myUserForm = Nothing
End Sub
Public Sub Update()
' Comments: Updates a row with the data entered by the user and reloads the listbox inside the userform
' Params :
' Notes : Adapt the initialize variables section
' Created : 2019/01/25 RD www.ricardodiaz.co
' Modified:
' Define objects variables
Dim myUserForm As oUserForm ' Note: you're defining the variable as the class of the userform. This gives you access to the userform's controls later
Dim myListObject As Excel.listObject
Dim myListRow As Excel.listRow
' Define variables
Dim selectedItem As Integer
'''''''' Initialize objects ''''''''
' Init the userform
' Note: When you initialize it directly with the name of the form, you can access the controls of the userform too
Set myUserForm = oUserForm
' Add the information to the Excel table
Set myListObject = ThisWorkbook.Worksheets(sheetName).ListObjects(tableName)
' Define selected row number
selectedItem = myUserForm.listHeader.ListIndex + 1
' Exit if there are no other rows
If selectedItem = 0 Then
MsgBox "There are no rows left!"
Exit Sub
End If
' Initialize the row at the end of the Excel table
Set myListRow = myListObject.ListRows(selectedItem)
' the following section is exactly as the Create procedure, so you theorically could make just one procedure for Create and Update
' Set the information into de excel table
With myListRow
.Range(2) = myUserForm.cmbEnvironment.Text
.Range(3) = myUserForm.cmbHost.Text
.Range(4) = myUserForm.cmbIP.Text
.Range(5) = myUserForm.cmbAccessible.Text
.Range(6) = myUserForm.cmbLast.Text
.Range(7) = myUserForm.cmbConfirmation.Text
.Range(8) = myUserForm.cmbProjects.Text
End With
' Reload the data into the listbox
Call mCode.Read
' Select the updated item in the listbox
myUserForm.listHeader.ListIndex = selectedItem - 1
MsgBox "Data Updated!"
' Clear control's contents
Call ClearControls ' Note that this is a private procedure inside the mCode module
' Clean up objects
Set myListRow = Nothing
Set myListObject = Nothing
Set myUserForm = Nothing
End Sub
Public Sub Delete()
' Comments: Deletes a row with the data entered by the user and reloads the listbox inside the userform
' Params :
' Notes : Adapt the initialize variables section
' Created : 2019/01/25 RD www.ricardodiaz.co
' Modified:
' Define objects variables
Dim myUserForm As oUserForm ' Note: you're defining the variable as the class of the userform. This gives you access to the userform's controls later
Dim myListObject As Excel.listObject
Dim myListRow As Excel.listRow
' Define variables
Dim selectedItem As Integer
'''''''' Initialize objects ''''''''
' Init the userform
' Note: When you initialize it directly with the name of the form, you can access the controls of the userform too
Set myUserForm = oUserForm
' Add the information to the Excel table
Set myListObject = ThisWorkbook.Worksheets(sheetName).ListObjects(tableName)
' Define selected row number
selectedItem = myUserForm.listHeader.ListIndex + 1
' Exit if there are no other rows
If selectedItem = 0 Then
MsgBox "There are no rows left or you didn't select a valid row!"
Exit Sub
End If
If MsgBox("Are you sure you want to delete this row?", vbYesNo + vbQuestion, "Yes") = vbNo Then
Exit Sub
End If
' Initialize the row at the end of the Excel table
Set myListRow = myListObject.ListRows(selectedItem)
' Delete the row
myListRow.Delete
' Reload the data into the listbox
Call mCode.Read
' Select the next item in the listbox
myUserForm.listHeader.ListIndex = WorksheetFunction.Min(selectedItem - 1, myUserForm.listHeader.ListCount) - 1
' Clean up objects
Set myListRow = Nothing
Set myListObject = Nothing
Set myUserForm = Nothing
End Sub
Public Sub ClearList()
' Comments: Clear the listbox
' Define objects variables
Dim myUserForm As oUserForm
' Init the userform
' Note: When you initialize it directly with the name of the form, you can access the controls of the userform too
Set myUserForm = oUserForm
myUserForm.listHeader.Clear
End Sub
Public Sub LoadControls()
' Comments: Loads the selected row's data into the controls
' Define objects variables
Dim myUserForm As oUserForm
Dim selectedItem As Integer
' Init the userform
' Note: When you initialize it directly with the name of the form, you can access the controls of the userform too
Set myUserForm = oUserForm
' Get the row of the selected item in the listbox
selectedItem = myUserForm.listHeader.ListIndex
' Set the control's text to each column of the selected item
myUserForm.cmbSchema.Value = myUserForm.listHeader.List(selectedItem, 0)
myUserForm.cmbEnvironment.Value = myUserForm.listHeader.List(selectedItem, 1)
myUserForm.cmbHost.Value = myUserForm.listHeader.List(selectedItem, 2)
myUserForm.cmbIP.Value = myUserForm.listHeader.List(selectedItem, 3)
myUserForm.cmbAccessible.Value = myUserForm.listHeader.List(selectedItem, 4)
myUserForm.cmbLast.Value = myUserForm.listHeader.List(selectedItem, 5)
myUserForm.cmbConfirmation.Value = myUserForm.listHeader.List(selectedItem, 6)
myUserForm.cmbProjects.Value = myUserForm.listHeader.List(selectedItem, 7)
' Clean up objects
Set myUserForm = Nothing
End Sub
Public Sub ClearControls()
' Comments: Reset controls to empty strings
' Define objects variables
Dim myUserForm As oUserForm
' Init the userform
' Note: When you initialize it directly with the name of the form, you can access the controls of the userform too
Set myUserForm = oUserForm
' Clear the controls
myUserForm.cmbSchema.Text = vbNullString
myUserForm.cmbEnvironment.Text = vbNullString
myUserForm.cmbHost.Text = vbNullString
myUserForm.cmbIP.Text = vbNullString
myUserForm.cmbAccessible.Text = vbNullString
myUserForm.cmbLast.Text = vbNullString
myUserForm.cmbConfirmation.Text = vbNullString
myUserForm.cmbProjects.Text = vbNullString
' Clean up objects
Set myUserForm = Nothing
End Sub
Public Sub FilterList(oLb As MSForms.ListBox, strFiltro As String)
Dim columnCounter As Integer
Dim listString As String
Dim rowCounter As Integer
oLb.ListIndex = -1
' Read the whole list
Call mCode.Read
' Remove unmatching items
For rowCounter = oLb.ListCount - 1 To 0 Step -1
listString = vbNullString
' Concat the list columns values in one string
For columnCounter = 0 To oLb.columnCount
listString = listString & oLb.Column(columnCounter, rowCounter)
Next columnCounter
If InStr(1, listString, strFiltro, 1) = 0 Then
' Remove items that don't match
oLb.RemoveItem rowCounter
End If
Next
End Sub
Something like so?
Private Sub TextBox1_Change()
Dim strID As String
Dim lngRow As Long
Dim a As Variant
strID = TextBox1.Text
On Error GoTo eHandle
lngRow = WorksheetFunction.Match(strID, Range("a1:a10"), 0)
On Error GoTo 0
If lngRow > 0 Then
Me.ListBox1.RowSource = ""
Me.ListBox1.ColumnCount = 4
Me.ListBox1.ColumnWidths = "20;20;20;20"
Me.ListBox1.RowSource = "Sheet1!a" & lngRow & ":d" & lngRow
End If
Exit Sub
eHandle:
lngRow = 0
Resume Next
End Sub
Private Sub UserForm_Click()
End Sub
I have a pivotchart that when the selected filter (work center) is changed, it updates the chart title to display that work center name. However, if I check the box to allow multiple selections, the chart title simply shows "All" instead of showing each of the actual selected items. I haven't found a way to get it to show what I'm looking for. Below is the code that I'm using to update the chart title as well as the code for the filter change event that fires it off
Option Explicit
Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)
On Error Resume Next
Application.Run "'Prod_Tools.xlam'!gPTWCChange", Target.PivotFields("WorkCenter").CurrentPage
On Error GoTo 0
End Sub
Sub gPTWCChange(ByVal WC As String)
Dim wb1 As Workbook
Dim CPWB1 As Workbook
For Each wb1 In Workbooks
If InStr(1, wb1.Name, "Capacity Planning Rep", vbTextCompare) > 0 Then
Set CPWB1 = Workbooks(wb1.Name)
Exit For
End If
Next wb1
On Error Resume Next
CPWB1.Charts("Workcenter By Week").ChartTitle.Text = "Work Center: " & WC
On Error GoTo 0
End Sub
What I would like is when multiple items are selected, have the chart title look like "Data for: Workcenter_A, Workcenter_B, Workcenter_F"
Here's your adapted sub. Notice that its parameter has changed.
Public Sub gPTWCChange(ByVal pfWC As Excel.PivotField)
Const sSEPARATOR As String = ", "
Dim sChartTitle As String
Dim oPivotItem As Excel.PivotItem
Dim lVisibleCount As Long
'... Your original code ...
Dim wb1 As Workbook
Dim CPWB1 As Workbook
For Each wb1 In Workbooks
If InStr(1, wb1.Name, "Capacity Planning Rep", vbTextCompare) > 0 Then
Set CPWB1 = Workbooks(wb1.Name)
Exit For
End If
Next wb1
'... New code to compute the chart title ...
If pfWC.EnableMultiplePageItems Then
'Build the chart title from the visible items in the PivotField.
lVisibleCount = 0
For Each oPivotItem In pfWC.PivotItems
If oPivotItem.Visible Then
lVisibleCount = lVisibleCount + 1
sChartTitle = sChartTitle & sSEPARATOR & oPivotItem.Caption
End If
Next
'Drop the leading separator.
sChartTitle = Mid$(sChartTitle, Len(sSEPARATOR) + 1)
'Manage plural.
sChartTitle = "Work Center" & IIf(lVisibleCount > 1, "s", "") & ": " & sChartTitle
Else
sChartTitle = "Work Center: " & pfWC.CurrentPage
End If
'... Your original code ...
On Error Resume Next
CPWB1.Charts("Workcenter By Week").ChartTitle.Text = sChartTitle
On Error GoTo 0
End Sub
And call your sub as follows:
Application.Run "'Prod_Tools.xlam'!gPTWCChange", Target.PivotFields("WorkCenter")
The principle is to send your sub a reference to the PivotField object, and from there, check its EnableMultiplePageItems property.
I've written a routine that deletes checkboxes and labels which are dynamically added to a sheet. However, it doesn't realiably delete all the controls. I need to ensure they are completely removed before adding again.
Here is my routine:
Public Sub removeOLEtypesOfType()
On Error Resume Next
Dim intPass As Integer, objShape As Shape
For intPass = 1 To 2
For Each objShape In ActiveSheet.Shapes
Dim strName As String
strName = objShape.Name
If Mid(strName, 1, Len(CHECKBOX_PREFIX)) = CHECKBOX_PREFIX _
Or Mid(strName, 1, Len(LABEL_PREFIX)) = LABEL_PREFIX _
Or Mid(strName, 1, 5) = "Label" Then
objShape.Delete
End If
Next
Next
End Sub
I only added the two pass for loop to ensure the objects are deleted, but even this doesn't delete the remaining items. The issue I have is that I end up with controls that were not deleted in the workbook.
I'm only trying to delete checkboxes and labels where in the case of checkboxes the name is prefixed with:
Public Const CHECKBOX_PREFIX As String = "chkbx"
Labels are prefixed with:
Public Const LABEL_PREFIX As String = "lbl"
The 3rd search comparing with 'Label' is an attempt to mop up but even this doesn't catch all.
Is there any way to delete all shapes / ole objects within a range?
Fixed, I rewrote the sub-routine after a google search on how to delete shapes within a range:
Public Sub removeOLEtypesOfType()
On Error Resume Next
Dim objTopLeft As Range, objBotRight As Range
Dim objRange As Range, objShape As Shape
Set objRange = Sheet1.Range(COLUMN_HEADINGS)
With objRange
Set objTopLeft = .Cells(1).Address(0, 0)
Set objBotRight = .cell(.Cells.Count).Address(0, 0)
For Each objShape In ActiveSheet.Shapes
If Mid(objShape.Name, 1, Len(CHECKBOX_PREFIX)) = CHECKBOX_PREFIX _
Or Mid(objShape.Name, 1, Len(LABEL_PREFIX)) = LABEL_PREFIX Then
If Not Intersect(objTopLeft, objShape.TopLeftCell) Is Nothing And _
Not Intersect(objBotRight, objShape.BottomRightCell) Is Nothing Then
objShape.Delete
End If
End If
Next
End With
End Sub
Context:
A PowerPoint slide in C# has a property Slide.Name (usually contains an arbitrary string value).
In my C# application I would like to use this property to identify slides (the slide order is to unreliable).
Question:
How can I manually set the Slide.Name property in the PowerPoint Application?
My problem is very like to the: “How to name an object within a PowerPoint slide?” but just on the slide level.
Any help would be appreciated.
There is no built-in functionality in PowerPoint that allows you to edit the name of a slide. As Steve mentioned, you have to do it using VBA code. The slide name will never change due to inserting more slides, and it will stay the same even if you close PowerPoint; the slide name set in VBA code is persistent. Here's some code I wrote to allow you to easily view the name of the currently selected slide and allow you to rename it:
'------------------------------------------------------------------
' NameSlide()
'
' Renames the current slide so you can refer to this slide in
' VBA by name. This is not used as part of the application;
' it is for maintenance and for use only by developers of
' the PowerPoint presentation.
'
' 1. In Normal view, click on the slide you wish to rename
' 2. ALT+F11 to VB Editor
' 3. F5 to run this subroutine
'------------------------------------------------------------------
Sub NameSlide()
Dim curName As String
curName = Application.ActiveWindow.View.Slide.name
Dim newName As String
retry:
newName = InputBox("Enter the new name for slide '" + curName + "', or press Cancel to keep existing name.", "Rename slide")
If Trim(newName) = "" Then Exit Sub
Dim s As Slide
' check if this slide name already exists
On Error GoTo SlideNotFound
Set s = ActivePresentation.Slides(newName)
On Error GoTo 0
MsgBox "Slide with this name already exists!"
GoTo retry
Exit Sub
SlideNotFound:
On Error GoTo 0
Application.ActiveWindow.View.Slide.name = newName
MsgBox "Slide renamed to '" + newName + "'."
End Sub
You can't manually set the slide name, but with a bit of code, it's simple. In VBA, for example:
Sub NameThatSlide()
ActivePresentation.Slides(1).Name = "Whatever You Like Here"
End Sub
You can rename a slide manually or with VBA. Once you know how, the door opens to some interesting possibilities, which I will demonstrate with code below.
Manually renaming slides. This ability is hidden in the VBA Editor's Properties pane, but it does not require coding.
If the Developer ribbon is not visible, enable it: File > Options > Customize Ribbon > check the Developer Main Tab.
From the Developer ribbon, click the Visual Basic menu item to open the Visual Basic Editor.
Press the Ctrl+R keys to navigate to the Project Explorer pane.
Expand "Microsoft PowerPoint Objects"
Click on any slide to select it.
Press the F4 key to navigate to the Properties pane.
Edit the (Name) item, and press Enter to apply the name change.
The slide name change may not appear immediately in the VBA Project Explorer pane. As long as the name is correct in the Properties pane, the name changed successfully.
This VBA code will also do the trick (hide slide number 1):
ActivePresentation.Slides(1).SlideShowTransition.Hidden = msoTrue
This code block covers a few ways to manage slide names and answers the main question.
Option Explicit
Public Function RenameSlide(oldName As String, newName As String)
' RenameSlide finds slide oldName and renames it to newName.
' Arguements:
' oldName: current (old) name of existing slide
' newName: new name for slide.
'
Dim tempBool As Boolean
Dim sld As Slide
Dim RetVal(0 To 1) As String
' Check if oldName can be found.
If SlideExists(oldName) Then
Set sld = Application.ActivePresentation.Slides(oldName)
Else
RetVal(0) = 1 'Error 1
RetVal(1) = "Error 1: slide with name " & oldName & " not found. Aborting."
Exit Function
End If
' Check if this slide name newName already exists.
If SlideExists(newName) Then
RetVal(0) = 2 'Error 1
RetVal(1) = "Error 2: slide with name " & newName & " already exists. Aborting."
Exit Function
End If
' Rename the slide
'Application.ActivePresentation.Slides(oldName) = newName
Application.ActivePresentation.Slides(oldName).Select
Application.ActiveWindow.View.Slide.Name = newName 'current slide
RetVal(0) = 0 'Success
RetVal(1) = "Success: slide renamed from '" & oldName & "' to '" & newName & "'."
End Function
Public Sub SetSlideName()
' Prompt user for new name for active slide.
'
Dim oldName As String
Dim newName As String
Dim sld As Slide
Dim msg As String
' Get current name of active slide.
oldName = Application.ActiveWindow.View.Slide.Name
msg = "Enter the new name for slide '" + oldName + "'."
retry:
newName = ""
' Prompt for new slide name. Loop until a name of at least 1 character is provided.
Do While newName = ""
newName = InputBox(msg, "Rename slide")
newName = Trim(newName)
If Len(newName) = 0 Then
msg = "Try again. You must enter a slide name to continue."
ElseIf newName = oldName Or newName = Str(vbCancel) Then
Exit Sub
End If
Loop
' If an existing slide already has name newName, then
' go back and prompt user again.slide name already exists
If SlideExists(newName) Then
msg = "Slide with this name already exists!"
GoTo retry
End If
' Set the new slide name
Application.ActiveWindow.View.Slide.Name = newName
MsgBox "Slide renamed to '" + newName + "'."
End Sub
Public Function SlideExists(SlideName As String) As Boolean
Dim RetVal As Boolean
Dim sld
' Assume slide does not exist.
SlideExists = False
' Try to find slide by name.
' If we error out, the slide does NOT exist.
On Error GoTo NoSlide
Set sld = ActivePresentation.Slides(SlideName)
' If we got this far, the slide DOES exist.
SlideExists = True
Exit Function
NoSlide:
' Error setting slide objects shows
' that slides does NOT exist.
SlideExists = False
End Function
As an aside, I use the slide naming trick and a little VBA to selectively remove certain slides from printing. I added a few extra VBA macros for the sake of populating the Macros list. From any slide: Developer ribbon > Macros > Select Macro > Run button. Use this method to kick off my PresentSlide, DontPresentSlide, PrintSlide and DontPrintSlide macros. Once you have properly tagged your various slides, simply run the PrepToPresentSlides or PrepToPrintSlides macro before you present or print, respectively.
Play around with these macros a bit and read the comments. You will find that I wrote the code extensibly, so you can modify it easily for your needs.
The code below helps me to manage which slides and objects are printed and which are presented on-screen. This is particularly useful when I want to print reference slides but not cover them. It is even more useful when I have slides with animations. Animations don't usually translate print well. So, I choose not to print some animated objects at all. In fact, I can even add in substitute content for the objects to be used just for printing (hidden when presenting) - though I rarely do this. Instead, I will typically hide the animation from printing or create a slide to present and a non-animated copy of it for print. With these macros, it is easy to manage a mix and match of slides and objects for print and slides and objects for presentation. I hope you enjoy.
Option Explicit
' DontPresentSlide - run macro while on a slide you wish to skip while presenting.
' The slide name will be appended with "NoPresent". You still
' need to run PrepToPresent before presenting to hide slide.
' PresentSlide - "NoPresent" will be removed from the slide. You still
' need to run PrepToPresent before presenting to hide slide.
' PrepToPesentSlides() - Unhide slides and objects you want presented and
' hide slides and objects you do NOT want presented.
' ShowNoPressnt() - show slides and shapes marked "NoPresent"
' HideNoPresent() - hide slides and shapes marked "NoPresent"
' DontPrintSlide - run macro while on a slide you wish to skip while presenting.
' The slide name will be appended with "NoPrint". You still
' need to run PrepToPresent before presenting to hide slide.
' PrintSlide - "NoPrint" will be removed from the slide. You still
' need to run PrepToPresent before presenting to hide slide.
' PrepToPrintSlides() - Unhide slides and objects you want printed and
' hide slides and objects you do NOT want printed.
' ShowNoPrint() - show slides and shapes marked "NoPrint"
' HideNoPrint() - hide slides and shapes marked "NoPrint"
' ShowHideSlides() - Hide or Unhide slides based on slide name.
' ShowHideShapes() - Hide or Unhide shapes based on shapes name.
Public Const cjaHide = False
Public Const cjaShow = True
Public Const cjaToggle = 2
Sub ShowHideSlides(NameContains As String _
, Optional LMR As String = "R" _
, Optional ShowSlide As Integer = False)
' Show or Hide slides based on slide name.
' Arguements:
' NameContains (string):
' slides with this string will be modified.
' LMR (string): enter L, M or R to indicate
' searching the Left, Middle or Right of
' the slide name, respectively.
' ShowSlide (integer):
' Show: True (-1)
' Hide: False (0)
' Toggle: 2
'
' To show or hide slides manually:
' Right-click the slide thumbnail, then click Hide Slide
' To rename slides,
' Use this VBA: ActiveWindow.View.Slide.Name = "NewSlideName"
' Or, edit the (Name) property in the VBA Properties window.
'
Dim sldCurrent As Slide
Dim found As Boolean
found = False
LMR = Trim(UCase(LMR))
If LMR <> "L" And LMR <> "M" Then LMR = "R"
'Loop through each slide in presentation.
For Each sldCurrent In ActivePresentation.Slides
'Match shape name left, right or middle as per LMR arguement.
'ActiveWindow.View.Slide.Name or Slide.SlideNumber
found = False
If LMR = "R" And LCase(right(sldCurrent.Name, Len(NameContains))) = LCase(NameContains) Then
found = True
ElseIf LMR = "L" And LCase(left(sldCurrent.Name, Len(NameContains))) = LCase(NameContains) Then
found = True
ElseIf LMR = "M" And InStr(1, LCase(NameContains), LCase(sldCurrent.Name)) Then
found = True
End If
'If match found, then set shape visibility per ShowShape arguement.
If found Then
If ShowSlide = True Then
ActivePresentation.Slides(sldCurrent.SlideNumber).SlideShowTransition.Hidden = msoFalse
ElseIf ShowSlide = False Then
ActivePresentation.Slides(sldCurrent.SlideNumber).SlideShowTransition.Hidden = msoTrue
Else
ActivePresentation.Slides(sldCurrent.SlideNumber).SlideShowTransition.Hidden = Not ActivePresentation.Slides(sldCurrent.SlideNumber).SlideShowTransition.Hidden
End If
End If
Next 'sldCurrent
End Sub
Sub ShowHideShapes(NameContains As String _
, Optional LMR As String = "R" _
, Optional ShowShape As Integer = False)
' Show or Hide shapes/objects based on object name.
' Arguements:
' NameContains (string):
' shapes with this string will be modified.
' LMR (string): enter L, M or R to indicate
' searching the Left, Middle or Right of
' the slide name, respectively.
' ShowSlide (integer):
' Show: True (-1)
' Hide: False (0)
' Toggle: 2
'
' To show, hide and/or rename objects:
' 1. Turn on Selection Pane via: Home Ribbon >
' Select > Selection Pane.
' 2. Double-click a shape name to rename it.
' 3. Click the eye icon to the far right to show/hide a shape.
Dim shpCurrent As Shape
Dim sldCurrent As Slide
Dim found As Boolean
found = False
LMR = Trim(UCase(LMR))
If LMR <> "L" And LMR <> "M" Then LMR = "R"
'Loop through each slide in presentation.
For Each sldCurrent In ActivePresentation.Slides
With sldCurrent
'Loop through each shape on current slide.
For Each shpCurrent In .Shapes
'Match shape name left, right or middle as per LMR arguement.
found = False
If LMR = "R" And right(shpCurrent.Name, Len(NameContains)) = NameContains Then
found = True
ElseIf LMR = "L" And left(shpCurrent.Name, Len(NameContains)) = NameContains Then
found = True
ElseIf LMR = "M" And InStr(1, NameContains, shpCurrent.Name) Then
found = True
End If
'If match found, then set shape visibility per ShowShape arguement.
If found Then
If ShowShape = True Then
shpCurrent.Visible = True
ElseIf ShowShape = False Then
shpCurrent.Visible = False
Else
shpCurrent.Visible = Not shpCurrent.Visible
End If
End If
Next 'sldCurrent
End With 'sldCurrent
Next 'sldCurrent
End Sub
Sub HideNoPrint()
' Hide slides and shapes you do NOT want printed.
'
' Run this macro to hide all slides and shapes that
' end with the string "NoPrint".
' Usage. Assume you have slides that contain animations that
' make the printed slide difficult or impossible to read.
' Let's further suppose you plan to present certain slides
' but not print them.
' 1. Add the"NoPrint" suffix to any shapes that clutter
' the printed page.
' 2. Add the "NoPrint" suffix to slides you don't want to
' print.
' 3. Run this macro to hide shapes and slides.
' 4. Print the slides.
' 5. Optionally, run the ShowNoPrint() macro in preparation
' for presenting the slides.
ShowHideShapes "NoPrint", "R", False
ShowHideSlides "NoPrint", "R", False
End Sub
Sub ShowNoPrint()
' Unhide slides and shapes that were hidden
' to prevent them from being printed in handouts.
'
ShowHideShapes "NoPrint", "P", True
ShowHideSlides "NoPrint", "P", True
End Sub
Sub HideNoPressent()
' Hide objects you do NOT want to present on screen.
'
' Run this macro to hide all slides and shapes that
' end with the string "NoPresent".
'
' Usage. Assume you have slides that contain supporting material
' that you wish to provide as printed handouts but not show.
' You can manually hide those slides and objects of course. I
' prefer to use these macros.
' 1. Add the"NoPresent" suffix to any shapes that you want
' to print to handouts but not show on-screen.
' 2. Add the "NoPresent" suffix to slides you want to
' print but not display on screen, such as reference slides.
' 3. Run this macro to hide the "NoPresent" shapes and slides.
' 4. Present your slides.
' 5. Optionally, run the ShowNoPresent() macro in preparation
' for printing the slides.
'
ShowHideShapes "NoPressent", "R", False
ShowHideSlides "NoPressent", "R", False
End Sub
Sub ShowNoPresent()
' Unhide objects that were hidden to prevent them from
' being presented on screen.
'
ShowHideShapes "NoPressent", "P", True
ShowHideSlides "NoPressent", "P", True
End Sub
Sub PrepToPrintSlides()
' Unhide objects you want printed and
' hide objects you do NOT want printed.
ShowNoPresent
HideNoPrint
End Sub
Sub PrepToPresentSlides()
' Unhide objects you want presented and
' hide objects you do NOT want presented.
ShowNoPrint
HideNoPresent
End Sub
Sub DontPresentSlide()
Dim RetVal, sldName As String
sldName = Application.ActiveWindow.View.Slide.Name
If InStr(1, sldName, "NoPresent", vbBinaryCompare) = 0 Then
RetVal = RenameSlide(sldName, sldName & "-NoPresent")
End If
HideNoPresent
End Sub
Sub PresentSlide()
Dim RetVal, sldName As String, strStart As String, newName As String
'Remove the NoPresent suffix from the current slide.
'get slide name
sldName = Application.ActiveWindow.View.Slide.Name
'Unhide slide
ActivePresentation.Slides(sldName).SlideShowTransition.Hidden = msoFalse
'remove "-NoPresent" from slide name
Do
strStart = InStr(1, sldName, "-NoPresent")
If InStr(1, sldName, "-NoPresent") Then
newName = left(sldName, strStart - 1) & right(sldName, Len(sldName) - strStart - 9)
RetVal = RenameSlide(sldName, newName)
End If
sldName = Application.ActiveWindow.View.Slide.Name
Loop Until InStr(1, sldName, "-NoPresent") = 0
'remove "NoPresent" from slide name
Do
strStart = InStr(1, sldName, "NoPresent")
If InStr(1, sldName, "NoPresent") Then
newName = left(sldName, strStart - 1) & right(sldName, Len(sldName) - strStart - 8)
RetVal = RenameSlide(sldName, newName)
End If
sldName = Application.ActiveWindow.View.Slide.Name
Loop Until InStr(1, sldName, "NoPresent") = 0
End Sub
Sub DontPrintSlide()
Dim RetVal, sldName As String
sldName = Application.ActiveWindow.View.Slide.Name
If InStr(1, sldName, "NoPrint", vbBinaryCompare) = 0 Then
RetVal = RenameSlide(sldName, sldName & "-NoPrint")
End If
HideNoPrint
End Sub
Sub PrintSlide()
Dim RetVal, sldName As String, strStart As String, newName As String
'Remove the NoPrint suffix from the current slide.
'get slide name
sldName = Application.ActiveWindow.View.Slide.Name
'Unhide slide
ActivePresentation.Slides(sldName).SlideShowTransition.Hidden = msoFalse
'remove "-NoPrint" from slide name
Do
strStart = InStr(1, sldName, "-NoPrint")
If InStr(1, sldName, "-NoPrint") Then
newName = left(sldName, strStart - 1) & right(sldName, Len(sldName) - strStart - 7)
RetVal = RenameSlide(sldName, newName)
End If
sldName = Application.ActiveWindow.View.Slide.Name
Loop Until InStr(1, sldName, "-NoPrint") = 0
'remove "NoPrint" from slide name
Do
strStart = InStr(1, sldName, "NoPrint")
If InStr(1, sldName, "NoPrint") Then
newName = left(sldName, strStart - 1) & right(sldName, Len(sldName) - strStart - 6)
RetVal = RenameSlide(sldName, newName)
End If
sldName = Application.ActiveWindow.View.Slide.Name
Loop Until InStr(1, sldName, "NoPrint") = 0
End Sub
Sub HideAllCovers()
' Run this macro to hide all Covers.
ShowHideShapes "Cover", "L", False
End Sub
Sub ShowAllCovers()
' Run this macro to hide all Covers.
ShowHideShapes "Cover", "L", True
End Sub
Sub HideAllAnswers()
' Run this macro to hide all Covers.
ShowHideShapes "Answer", "L", False
End Sub
Sub ShowAllAnswers()
' Run this macro to hide all Covers.
ShowHideShapes "Answer", "L", True
End Sub
Sub HideAllQuestions()
' Run this macro to hide all Covers.
ShowHideShapes "Question", "L", False
End Sub
Sub ShowAllQuestions()
' Run this macro to hide all Covers.
ShowHideShapes "Question", "L", True
End Sub
Sub ShowAll()
' Run this macro to hide all shapes (Covers and Answers).
ShowAllQuestions
ShowAllAnswers
ShowAllCovers
ShowNoPrint
End Sub
Sub HideAll()
' Run this macro to hide all shapes (Covers and Answers).
HideAllQuestions
HideAllAnswers
HideAllCovers
HideNoPrint
End Sub
Enable the "Developer" tab in "File -> Options -> Customize Ribbon" (Details: https://www.addintools.com/documents/powerpoint/where-is-developer-tab.html)
In the developer tab, follow these steps and see the image below (in Portuguese, sorry)
Enter the developer tab
Select the target slide
If you don't have any active X control (buttons, textboxes, etc.) in the slide, add a dummy button from the developer tab
Select this button on the slide and click "properties" at the developer tab
At the top of the properties window, there is a combo box where you can select the slide instead of the button
Select the slide and see its programming properties, including name
I'm not certain that this will enable you to set the Slide.Name property because I'm not a VBA programmer, but anyway AFAIK the easiest way to name slides in PowerPoint 2010 is using Outline view.
If you position your mouse farthest left on a created slide, you can drag rightwards a kind of vertical slide sorter. At the top of that pane, you'll see two tabs: Slides and Outline.
Select Outline, you'll see each slide numbered and a grey grab button which allows you to reorder your slides. If you click to the right of that, you can type in whatever name you like, say Home.
In the main view pane, the slide will then have Home emblazoned across it. You can then either leave it there, or conceal it by altering the font colour to the background or by moving the text outside the presentation frame.
BTW You can use these names in hyperlinks.
used the Sub SplitFile() function to create individual slides from a deck of >100 slides. All went well!! But can anyone tell me what code do I use to rename the file automatically, assuming that each slide has a title in a text box? I want the slide title to be the file name for the new, individual slide created.
Here's the code I used to create individual slides (as individual files), thanks to whoever posted it online.
Sub SplitFile()
Dim lSlidesPerFile As Long
Dim lTotalSlides As Long
Dim oSourcePres As Presentation
Dim otargetPres As Presentation
Dim sFolder As String
Dim sExt As String
Dim sBaseName As String
Dim lCounter As Long
Dim lPresentationsCount As Long ' how many will we split it into
Dim x As Long
Dim lWindowStart As Long
Dim lWindowEnd As Long
Dim sSplitPresName As String
On Error GoTo ErrorHandler
Set oSourcePres = ActivePresentation
If Not oSourcePres.Saved Then
MsgBox "Please save your presentation then try again"
Exit Sub
End If
lSlidesPerFile = CLng(InputBox("How many slides per file?", "Split Presentation"))
lTotalSlides = oSourcePres.Slides.Count
sFolder = ActivePresentation.Path & "\"
sExt = Mid$(ActivePresentation.Name, InStr(ActivePresentation.Name, ".") + 1)
sBaseName = Mid$(ActivePresentation.Name, 1, InStr(ActivePresentation.Name, ".") - 1)
If (lTotalSlides / lSlidesPerFile) - (lTotalSlides \ lSlidesPerFile) > 0 Then
lPresentationsCount = lTotalSlides \ lSlidesPerFile + 1
Else
lPresentationsCount = lTotalSlides \ lSlidesPerFile
End If
If Not lTotalSlides > lSlidesPerFile Then
MsgBox "There are fewer than " & CStr(lSlidesPerFile) & " slides in this presentation."
Exit Sub
End If
For lCounter = 1 To lPresentationsCount
' which slides will we leave in the presentation?
lWindowEnd = lSlidesPerFile * lCounter
If lWindowEnd > oSourcePres.Slides.Count Then
' odd number of leftover slides in last presentation
lWindowEnd = oSourcePres.Slides.Count
lWindowStart = ((oSourcePres.Slides.Count \ lSlidesPerFile) * lSlidesPerFile) + 1
Else
lWindowStart = lWindowEnd - lSlidesPerFile + 1
End If
' Make a copy of the presentation and open it
For Each oSlide In ActiveWindow.Presentation.Slides
strTitles = strTitles _
& "Slide: " _
& CStr(oSlide.SlideIndex) & vbCrLf _
& oSlide.Shapes.Title.TextFrame.TextRange.Text _
& vbCrLf & vbCrLf
Next oSlide
On Error GoTo ErrorHandler
intFileNum = FreeFile
sSplitPresName = sFolder & sBaseName & _
"_" & CStr(lWindowStart) & "-" & CStr(lWindowEnd) & "." & sExt
oSourcePres.SaveCopyAs sSplitPresName, ppSaveAsDefault
Set otargetPres = Presentations.Open(sSplitPresName, , , True)
With otargetPres
For x = .Slides.Count To lWindowEnd + 1 Step -1
.Slides(x).Delete
Next
For x = lWindowStart - 1 To 1 Step -1
.Slides(x).Delete
Next
.Save
.Close
End With
Next ' lpresentationscount
NormalExit:
Exit Sub
ErrorHandler:
MsgBox "Error encountered"
Resume NormalExit
End Sub