I am working on one project. In which i want to find out " Is my textbox going out of slide or not?" . If yes then show error msg.
so my logic is if i found the dimension of the slide then i will use it in IF...Else condition like :
If textbox_position < slide_dimension then
#Error
end if
If you have any other idea then please tell me.
Thanks
The presentation's .PageSetup.SlideWidth and .SlideHeight properties will give you the dimensions of the slide in points.
Your function would need to do something like (off top of head and out of the air ..):
Function IsOffSlide (oSh as Shape) as Boolean
Dim sngHeight as single
Dim sngWidth as Single
Dim bTemp as Boolean
bTemp = False ' by default
With ActivePresentation.PageSetup
sngHeight = .SlideHeight
sngWidth = .SlideWidth
End With
' this could be done more elegantly and in fewer lines
' of code, but in the interest of making it clearer
' I'm doing it as a series of tests.
' If any of them are true, the function will return true
With oSh
If .Left < 0 Then
bTemp = True
End If
If .Top < 0 Then
bTEmp = True
End If
If .Left + .Width > sngWidth Then
bTemp = True
End If
If .Top + .Height > sngHeight Then
bTemp = True
End If
End With
IsOffSlide = bTemp
End Function
Why you not use a placeholders of PowerPoint to make this? for example:
Sub SetText(IndexOfSlide As Integer, txt As String)
'http://officevb.com
ActivePresentation.Slides(IndexOfSlide).Shapes.Placeholders(1).TextFrame.TextRange.Text = txt
End Sub
You can call this sub and pass parameters
IndexOfSlide with a number of slide and txt with a text to create.
Related
I'm trying to explore how do I apply some formatting to only few selected words in a textbox but so far unable to accomplish this myself.
Somehow with the code I created below, I can only use it to select all the words in the textbox instead of just a few words I want.
It would be great if anyone can provide me a simpler/ existing codes that can help me solve this please ?
Thanks in advance
Sub ActiveTextRange()
Dim sld As slide
Dim sh As Shape
Dim wordcount As Long, j As Long, x As Long, y As Long, z As Long
wordcount = ActiveWindow.Selection.ShapeRange(1).textFrame.TextRange.Words.Count
With ActiveWindow.Selection.ShapeRange(1)
.textFrame.TextRange.Words(Start:=1, Length:=wordcount).Font.Color.RGB = RGB(230, 0, 0)
End With
End Sub
The following might help. Key to this is being able to track the location of the specific text you want to change in amongst larger chunks of text; my suggestion is to format each bit of text as you add it to the shape. Cheers.
Option Explicit
Sub ActiveTextRange()
Dim vPresentation As presentation
Dim vSlide As Slide
Dim vShape As Shape
Dim vAddThisText As String
' Create a new presentation, add a slide and a rectangle shape
Set vPresentation = Application.Presentations.Add
Set vSlide = vPresentation.Slides.Add(vPresentation.Slides.Count + 1, ppLayoutBlank)
Set vShape = vSlide.Shapes.AddShape(msoShapeRectangle, 10, 10, 600, 300)
' Make the shape white with a 3pt dark red border
vShape.Fill.ForeColor.RGB = rgbWhite
With vShape.Line
.ForeColor.RGB = rgbDarkRed
.Weight = 3
End With
' Setup the shape to be left aligned, font color, top anchored, etc
With vShape.TextFrame
.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter
.TextRange.Font.Color.RGB = rgbBlack
.VerticalAnchor = msoAnchorMiddle
.TextRange.ParagraphFormat.SpaceAfter = 6
.TextRange.ParagraphFormat.WordWrap = msoCTrue
End With
' And now format the word red, which is the 7th character and is 3 long
vAddThisText = "Hello Red World"
vShape.TextFrame.TextRange.InsertAfter vAddThisText
With vShape.TextFrame.TextRange.Characters(7, 3)
.Font.Color.RGB = rgbRed
' and change other attributes if needed etc
End With
End Sub
And the output is ...
This colors the second and third words red in a Title placeholder. After Words, the first number is the starting position and the second number is the length:
Sub ColorWords()
Dim objSlide As Slide
Dim objShape As Shape
For Each objSlide In ActivePresentation.Slides
For Each objShape In objSlide.Shapes
If objShape.Type = msoPlaceholder Then
If objShape.PlaceholderFormat.Type = ppPlaceholderTitle Or objShape.PlaceholderFormat.Type = ppPlaceholderCenterTitle Then
With objShape.TextFrame2.TextRange.Words(2, 2).Font.Fill
.Solid
.ForeColor.RGB = RGB(255, 0, 0)
End With
End If
End If
Next objShape
Next objSlide
End Sub
To color a word selection, use:
ActiveWindow.Selection.TextRange.Font.Color.RGB = RGB(Red:=255, Green:=0, Blue:=0)
OK. I think I better understand the ask ... but I'm assuming in this response you're selecting text ... rather than just a shape itself. So you're editing the powerpoint, select some text in a shape, and want to run a macro to format(?) It should be as simple as creating the following in a code module (and then I created a custom access toolbar link to run the macro at the top of PowerPoint to make it quick):
Option Explicit
Sub ActiveTextRange()
ActiveWindow.Selection.TextRange.Font.Color.RGB = rgbRed
End Sub
Before:
Select the text "Red" and run macro:
Btw ... if you want to select just the shape and have some logic choose the text, the concept is a mix of this and my first answer.
Hello,
I am trying to set up a form which is a calendar from which the user can select a date (by default the current month appears). The form consists of 42 command buttons (I have left the default name ie. CommandButton1) which I am setting the day number.
At the moment I have a long-winded section of code for each button (I used Excel to generate this rather than type it all out) which locks and hides the button if it is outside of the month in question which looks like this:
NewDate.CommandButton1.Caption = Format(DATlngFirstMonth - DATintDayNumFirst + DATintX, "dd")
If DATintX < DATintDayNumFirst Then
With NewDate.CommandButton1
.Locked = True
.Visible = DATbooShowExtraDays
.ForeColor = RGB(150, 150, 150)
End With
Else
With NewDate.CommandButton1
.Locked = False
.Visible = True
.ForeColor = RGB(0, 0, 0)
End With
End If
I know that I can refer to a command button by:
Dim objCommandButton As Object
Set objCommandButton = NewDate.CommandButton1
..which neatens the code up somewhat. But what I would like to do is refer to the command button as a string so I can loop through all 42, ie.
Dim n as integer
n = 1
Do Until n > 42
Set objCommandButton = NewDate.CommandButton & n
'Some operations
n = n + 1
Loop
Many thanks in advance for assistance.
You can loop through all controls of the form. Try
Sub LoopButtons()
Dim it As Object
For Each it In NewDate.Controls
Debug.Print it.Name
Next it
End Sub
Then you can put conditional expression (if ... then) in place of Debug.Print or whatever. For example
If Instr(it.Name, "CommandButton") Then
'do your code
end if
Here's code which iterates over ActiveX controls on active sheet:
Sub IterateOverActiveXControlsByName()
Dim x As Integer
Dim oleObjs As OLEObjects
Dim ctrl As MSForms.CommandButton
Set oleObjs = ActiveSheet.OLEObjects
For x = 1 To 10
Set ctrl = oleObjs("CommandButton" & x).Object
Next
End Sub
VBA novice and trying to learn as much as I can, so please don't hesitate to over-inform.
Goal: Within a sub, call a function that returns a boolean value of true when two objects overlap. The idea is for the user to be able to drag and drop shapes within each other in order to easily create a hierarchy.
Problem: I am receiving the "Object required" error as stated in the title on the commented line. RecA and RecB are the shapes in question defined in the arguments of the function. The function, named "Overlap", is in Module1.
Public Sub CommandButton1_Click()
Dim Function_Result As Boolean
Function_Result = Overlap(RecA, RecB) '<--------!
If Function_Result = True Then
MsgBox ("swiggity swooty")
End If
End Sub
From research I have only been able to find the solution of using the set modifier preceding Function_Result which I have tried (along with other possible solutions) to no avail.
If the function code is at all helpful, let me know and I can add it to this post.
Excel 2010
Thanks in advance!
You haven't properly defined your shapes. If your function is using object properties to determine the overlap, you'd need to do something like the following in your CommandButton1_Click event:
Private Sub CommandButton1_Click()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets(1) 'Assumed on worksheet index 1
Dim RecA As Shape: Set RecA = ws.Shapes("RecA") 'Assumed RecA is the name of your shape?
Dim RecB As Shape: Set RecB = ws.Shapes("RecB")
Dim Function_Result As Boolean
Function_Result = Overlap(RecA, RecB)
If Function_Result = True Then
MsgBox ("swiggity swooty")
End If
End Sub
This way, you've set your shapes up as objects in VBA and can now reference their object properties.
Code that works:
Private Sub CommandButton1_Click()
Dim Function_Result As Boolean
Dim RecA As Shape
Dim RecB As Shape
Function_Result = Overlap(RecA, RecB)
If Function_Result = True Then
MsgBox "swiggity swooty"
End If
End Sub
I was able to keep it a little more simple than Tyeler's answer since I have set my shapes in my Overlap function itself (seen below).
Function Overlap(RecA As Shape, RecB As Shape) As Boolean
Dim Shp1Left As Single
Dim Shp1Right As Single
Dim Shp1Top As Single
Dim Shp1Bottom As Single
Dim Shp2Left As Single
Dim Shp2Right As Single
Dim Shp2Top As Single
Dim Shp2Bottom As Single
Dim HorOverlap As Boolean
Dim VertOverlap As Boolean
Set RecA = Sheet1.Shapes("RecA")
Set RecB = Sheet1.Shapes("RecB")
With RecA
Shp1Left = .Left
Shp1Right = .Left + .Width
Shp1Top = .Top
Shp1Bottom = .Top + .Height
End With
With RecB
Shp2Left = .Left
Shp2Right = .Left + .Width
Shp2Top = .Top
Shp2Bottom = .Top + .Height
End With
''''''''''''''''''''''''''''''''''''''''''''''
' do they overlap horizontally?
If Shp1Left > Shp2Left Then
If Shp1Left < Shp2Right Then
HorOverlap = True
End If
End If
If Shp1Left < Shp2Left Then
If Shp1Right > Shp2Left Then
HorOverlap = True
End If
End If
' do they overlap vertically?
If Shp1Top > Shp2Top Then
If Shp1Top < Shp2Bottom Then
VertOverlap = True
End If
End If
If Shp1Top < Shp2Top Then
If Shp1Bottom > Shp2Top Then
VertOverlap = True
End If
End If
Overlap = HorOverlap And VertOverlap
End Function
I have VBA code for changing size of shapes, but I want to convert the number to be in cm. Any suggestion for how to convert these numbers?
Another question is that I want to change the same size for multiple selected shapes; can you help me with this as well?
Thank you very much!
Sub test()
Dim objHeigh As Integer
Dim objWidth As Integer
Dim oSh As Shape
On Error GoTo CheckErrors
With ActiveWindow.Selection.ShapeRange
If .Count = 0 Then
MsgBox "You need to select a shape first"
Exit Sub
End If
End With
For Each oSh In ActiveWindow.Selection.ShapeRange
objHeigh = oSh.Height
objWidth = oSh.Width
objHeigh = CInt(InputBox$("Assign a new size of Height", "Heigh", objHeigh))
' give the user a way out
If objHeigh = 0 Then
Exit Sub
End If
If objName <> "" Then
oSh.Name = objName
End If
objWidth = CInt(InputBox$("Assign a new size of Width", "Width", objWidth))
' give the user a way out
If objWidth = 0 Then
Exit Sub
End If
oSh.Height = CInt(objHeigh)
oSh.Width = CInt(objWidth)
Next
Exit Sub
CheckErrors: MsgBox Err.Description
End Sub
According to MSDN, the height / width of the corresponding shape properties are specified in points:
Returns or sets the height of the specified object, in points.
Read/write.
and on that page they specifically show an example and referring to the fact, that 1 inch has 72 points
This example sets the height for row two in the specified table to 100
points (72 points per inch).
Therefore I guess it is safe to rely on that fact and just write a function to convert it yourself:
Function ConvertPointToCm(ByVal pnt As Double) As Double
ConvertPointToCm = pnt * 0.03527778
End Function
Function ConvertCmToPoint(ByVal cm As Double) As Double
ConvertCmToPoint = cm * 28.34646
End Function
As far as your question with sizing multiple objects is concerned, I am not sure if I understand your problem fully. I interpreted it in a way so that moving your prompts to the user out of the For loop should give you the desired result (if that is in fact your desired result :)):
objHeigh = CInt(InputBox$("Assign a new size of Height", "Heigh"))
' give the user a way out
If objHeigh = 0 Then
Exit Sub
End If
objHeigh = ConvertCmToPoint(objHeigh)
objWidth = CInt(InputBox$("Assign a new size of Width", "Width"))
' give the user a way out
If objWidth = 0 Then
Exit Sub
End If
objWidth = ConvertCmToPoint(objWidth)
For Each oSh In ActiveWindow.Selection.ShapeRange
If objName <> "" Then
oSh.Name = objName
End If
oSh.Height = CInt(objHeigh)
oSh.Width = CInt(objWidth)
Next
I have this labels in my project
num1.Hide()
num2.Hide()
num3.Hide()
.
.
.
num20.Hide()
What's the best way to hide/show them? I'm thinking of loop but i can't make it work.
You should put all all your labels in a list, Then to hide or show your elements, just iterate the list in a function to do your action on all elements.
One solution:
Create an array of labels at runtime then you can loop through them to make them invisible:
'define the array
Dim labelArray(5) As Label
Private Sub createLabels
'add them to the form
For i As Integer = 0 To labelArray.GetUpperBound(0)
initLabel(i, New Point(i * 30, i * 30), i.ToString)
Next
'now hide them
For i As Integer = 0 To labelArray.GetUpperBound(0)
labelArray(i).Visible = False
Next
End Sub
Private Sub initLabel(ByVal index As Integer, location As System.Drawing.Point, caption As String)
labelArray(index) = New Label
With labelArray(index)
'set some default properties
.Name = "LabelArray" + index.ToString
.Width = 300
.Height = 100
.Location = location
.Text = caption
End With
Me.Controls.Add(labelArray(index))
End Sub