I want to add a field via macro to my presentation/slide that automatically shows the current date.
Shape shape = [Find a text shape to edit]
shape.TextFrame.TextRange.Text = "Some Text | " + [Field showing Current date]
I don't want to insert a text that contains the current date:
Shape shape = [Find a text shape to edit]
shape.TextFrame.TextRange.Text = "Some Text | " + DateTime.Now
As I descriped the resulting textshape should contain some constant text + a field showing the current date.
This will insert a time/date field into your text box:
Dim oSh As Shape
Set oSh = ActiveWindow.Selection.ShapeRange(1)
With oSh.TextFrame.TextRange
.Text = "Some text | "
.InsertDateTime ppDateTimeHmm, True
End With
Related
I have 3 text boxes that are created on a slide via vba. this means that they will all start with the name "TextBox" but the numbers behind the name will be different every time. these are the only text boxes on the slide
I want to use vba to group all text boxes together.
no need to change anything, just group them so they move as a group if needed.
I figured it out
I knew I was only going to have 3 text boxes at a time so this worked. basically since the text boxes could end in any number, I renamed them to box1, box2, box3. and then grouped the box shapes
Dim SLD As Slide
Dim D As Long
Dim T As Integer
Set SLD = ActivePresentation.Slides(9)
T = 1
For D = SLD.Shapes.Count To 1 Step -1
If SLD.Shapes(D).Type = msoTextBox Then
SLD.Shapes(D).Name = "Box" & T
T = T + 1
End If
Next
SLD.Shapes.Range(Array("Box1", "Box2", "Box3")).Group
As so see, I wanna add the number from the UP1 textbox (The one shown "10")(ActiveXControl so it can be edited while presenting) to the S1 Textbox (Shown "10")
Here is my code:
Slide1.Shapes("S1").TextFrame.TextRange = Slide1.Shapes("S1").TextFrame.TextRange + UP1
But here is my result:
String values should be cast into numeric values before adding them.
With Slide1.Shapes("S1").TextFrame.TextRange
.Text = Val(.Text) + UP1
End With
I have found the below code (changed to my needs) here
I try to change the titles of many charts automatically, using macro in libre calc 7.3.0.
I Know which cells contain the titles and I want them to add them to charts.
How can I make this VBA vcode to work?
Const SCells = "L8, T8, AA8"
' Set the title of the first Chart to the contents of C1
Sub SetTitle
' Get active sheet
oSheet = ThisComponent.CurrentController.ActiveSheet
aCells = Split(SCells,",")
for i = uBound(aCells) to 0 step -1
' Get the cell containing the chart title, in this case C1
oCell = oSheet.getCellRangeByName(aCells(i))
oCharts = oSheet.getCharts()
' Get the chart with index 0, which is the first chart created
' to get the second you would use 1, the third 2 and so on...
oChart = oCharts.getByIndex(i)
oChartDoc = oChart.getEmbeddedObject()
'Change title
oChartDoc.getTitle().String = oCell.getString()
next i
End Sub
What I was doing wrongly? I had spaces in Const SCells content:
"L11, T11, E11" which was wrong.
I checked the content of aCells using xraytool and I found that the content was parsed as 1) "L11", 2) " T11" and 3) " E11", with spaces.
So you can change automatically the title of your charts in a librecalc sheet using that vba code:
' NOTE: NO SPACES OR OTHER CHARACTERS
Const SCells = "L11,T11,E11"
Sub SetTitle
' Get active sheet
oSheet = ThisComponent.CurrentController.ActiveSheet
' Split SCells content by ","
' see Print aCells for corrent content
aCells = Split(SCells,",")
'enumarate by "1" point increment
for i = uBound(aCells) to 0 step -1
' using aCells Content
oCell = oSheet.getCellRangeByName(aCells(i))
oCharts = oSheet.getCharts()
' Get the chart with index 0, which is the first chart created
' to get the second you would use 1, the third 2 and so on...
oChart = oCharts.getByIndex(i)
oChartDoc = oChart.getEmbeddedObject()
'Change title
oChartDoc.getTitle().String = oCell.getString()
' xray oChart.Name
next i
End Sub
I have PowerPoints that are automatically generated from software. The software puts the content (text) into Text Boxes instead of placeholders. I need to create and run a macro that will add all of the text to the Outline View (for Accessibility purposes).
I have a script that will move the text box content into the placeholder which by default shows up in the outline view. The only problem with this is that it is not retaining the styling (bulleted lists with subbullets are not working). The styling becomes especially problematic when I combine multiple Text Boxes from one slide into a single placeholder.
Any thoughts?
Here is my current script (the important stuff):
For Each sld In ActivePresentation.Slides
With ActivePresentation
sld.CustomLayout = ActivePresentation.Designs(1).SlideMaster.CustomLayouts(2)
Set hypCollection = New hyperColl 'Set the collection of arrays - 1 for each shape
Set shp = sld.Shapes(1)
For j = sld.Shapes.Count To 1 Step -1
Set shp = sld.Shapes(j)
bolCopy = False
If j = 3 Then
sld.Shapes.Placeholders.Item(1).TextFrame.TextRange = shp.TextFrame.TextRange.Characters
sld.Shapes.Placeholders.Item(1).Visible = msoTrue
shp.Delete
ElseIf j > 3 And shp.Type = msoTextBox Then
sld.Shapes.Placeholders.Item(2).TextFrame.TextRange.InsertBefore (shp.TextFrame.TextRange.TrimText) '.ParagraphFormat.Bullet.Type = shp.TextFrame.TextRange.ParagraphFormat.Bullet.Type
If hypCollection.Exists(shp.Name) Then
hypArray = hypCollection.GetArray(shp.Name)
For i = LBound(hypArray) To UBound(hypArray)
Set hypToAdd = hypArray(i)
With sld.Shapes.Placeholders.Item(2).TextFrame.TextRange.Characters(hypToAdd.getchrStart, Len(hypToAdd.getHypText)).ActionSettings.Item(1)
.Action = ppActionHyperlink
.Hyperlink.Address = hypToAdd.getHypAddr
End With
Next i
End If
shp.Delete
End If
Next j
End With
Next sld
Here are some examples:
The First Image is what I start with:
This is what it looks like after running my script:
This is what I want it to look like (simply maintaining formatting):
Would resetting the slide help?
You could add the line:
CommandBars.ExecuteMso ("SlideReset")
Just before:
Next sld
That should set the formatting in the textbox to the way it is on the master.
The fix was to Paste Special into the the new placeholder without replacing all contents. Since I was iterating through the textboxes in reverse order, I simply copied each TextBox and then Pasted Special into the placeholder at position 0 (leaving all current content there).
I converted the code to C#, and this is the full solution:
private void FixPPTDocument()
{
PPT.Application pptApp = new PPT.Application();
PPT.Shape currShp;
PPT.Shape shp2;
if (File.Exists((string)fileLocation))
{
DateTime today = DateTime.Now;
PPT.Presentation pptDoc = pptApp.Presentations.Open(fileLocation, Microsoft.Office.Core.MsoTriState.msoFalse, Microsoft.Office.Core.MsoTriState.msoTrue, Microsoft.Office.Core.MsoTriState.msoFalse);
foreach (PPT.Slide slide in pptDoc.Slides)
{
slide.CustomLayout = pptDoc.Designs[1].SlideMaster.CustomLayouts[2];
for (int jCurr = slide.Shapes.Count; jCurr >= 1; jCurr--)
{
currShp = slide.Shapes[jCurr];
if (jCurr == 3)
{
slide.Shapes.Placeholders[1].TextFrame.TextRange.Text = currShp.TextFrame.TextRange.Text;
slide.Shapes.Placeholders[1].Visible = Microsoft.Office.Core.MsoTriState.msoTrue;
currShp.Delete();
}
else if (jCurr > 3 && currShp.Type == Microsoft.Office.Core.MsoShapeType.msoTextBox)
{
currShp.TextFrame.TextRange.Copy();
slide.Shapes.Placeholders[2].TextFrame.TextRange.Characters(0, 0).PasteSpecial();
currShp.Delete();
}
}
}
pptDoc.SaveAs(fileNewLocation);
pptDoc.Close();
MessageBox.Show("File created!");
}
}
I need to compare two date columns in excel(vba). If the cell values are equal, a message box has to be displayed with "TARGET ACHIEVED", "YES" or "NO" option. Based on the value selected, 2nd column cell color has to be changed
- YES - orange
- NO - blue
Following code will do it.
Dim Date1 As String
Dim Date2 As String
Dim msgResult As VbMsgBoxResult
Date1 = ThisWorkbook.Sheets(1).Cells(1)
Date2 = ThisWorkbook.Sheets(1).Cells(2)
If IsDate(Date1) And IsDate(Date2) Then
If CDate(Date1) = CDate(Date2) Then
msgResult = MsgBox("TARGET ACHIEVED", vbYesNo)
If vbYes = msgResult Then
' code for Yes handling
ThisWorkbook.Sheets(1).Cells(1).Interior.ColorIndex = 46 'orange
Else
' code for NO handling
ThisWorkbook.Sheets(1).Cells(1).Interior.ColorIndex = 5 'blue color
End If
End If
End If
You can get more Excel colour codes here.