I want to replicate an selected object in powerpoint using VBA code. I have a following code mention below
Sub CopySizeAndPosition()
' Usage: Select two shapes. The size and position of
' the first shape selected will be copied to the second.
Dim w As Double
Dim h As Double
Dim l As Double
Dim t As Double
With ActiveWindow.Selection.ShapeRange(1)
w = .Width
h = .Height
l = .Left
t = .Top
End With
With ActiveWindow.Selection.ShapeRange(2)
.Width = w
.Height = h
.Left = l
.Top = t
End With
End Sub
But I want to specify my value instead of getting object value. So, please help and thanx in advance!
Assuming you have selected a single shape, you can set your values like this:
' Sets the size and position of the first shape in a selection
Sub SetShapeSizeAndPosition()
With ActiveWindow.Selection.ShapeRange(1)
.Width = 100
.Height = 100
.Left = 100
.Top = 100
End With
End Sub
Related
From a previous post I learned a way to populate a userform with a grid of textboxes:
Dim Grid(1 To 10, 1 To 5) As MSForms.TextBox
Private Sub UserForm_Initialize()
Dim x As Long
Dim y As Long
For x = 1 To 10
For y = 1 To 5
Set Grid(x, y) = Me.Controls.Add("Forms.Textbox.1")
With Grid(x, y)
.Name = "TextBox_" & x & "_" & y
.Width = 50
.Height = 20
.Left = y * .Width
.Top = x * .Height
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleSingle
End With
Next y
Next x
End Sub
Now, I need to run certain code when I change the contents of any textbox in columns 5 and 6. But since the textbox won't exist until after Initialize is run, their Change events don't exist either.
So I need to either:
Write the change events in advance, since I know the names of the textboxes in advance.
Use an event that will trigger whenever I click any textbox, and be able to identify the textbox in question.
If the only way to do this is by using a class module, please explain it carefully, since I've never actually used one.
EDIT: The answers from #TinMan and #Storax work a little too well. The code reacts to every keystroke in the textbox, but I really need to wait until the user is finished typing. There's no "Exit" event for the textbox when it's in the class module. Any thoughts?
You'll need to create a class to listen for the changes.
Class: TextBoxListener
Public WithEvents TextBox As MSForms.TextBox
Public UserForm As Object
Private Sub TextBox_Change()
UserForm.TextBoxGridChange TextBox
End Sub
Userform
With a few modifications you can use the Grid() to hold the TextBoxListeners references.
Option Explicit
Private Grid(1 To 10, 1 To 5) As New TextBoxListener
Public Sub TextBoxGridChange(TextBox As MSForms.TextBox)
Debug.Print TextBox.Value
End Sub
Private Sub UserForm_Initialize()
Dim x As Long
Dim y As Long
For x = 1 To 10
For y = 1 To 5
With Grid(x, y)
Set .TextBox = Me.Controls.Add("Forms.Textbox.1")
Set .UserForm = Me
With .TextBox
.Name = "TextBox_" & x & "_" & y
.Width = 50
.Height = 20
.Left = y * .Width
.Top = x * .Height
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleSingle
End With
End With
Next y
Next x
End Sub
Just a simple example how the class could look like for the textboxes. I named the class clsTextBoxes
Option Explicit
Public WithEvents tb As MSForms.TextBox
' just to keep track of the box in the grid
Public x As Long
Public y As Long
' Just a simple example for the change event.
' you could use x and y to tell the different textboxes apart
Private Sub tb_Change()
Debug.Print tb.Text, x, y
End Sub
You have to adjust your code in the userform like that
Option Explicit
Dim Grid(1 To 10, 1 To 5) As MSForms.TextBox
' Collection to save all the textboxes in the grid
Dim colTxt As New Collection
Private Sub UserForm_Initialize()
Dim x As Long
Dim y As Long
Dim cTxt As clsTextBoxes
For x = 1 To 10
For y = 1 To 5
Set Grid(x, y) = Me.Controls.Add("Forms.Textbox.1")
' create an new clsTextBoxes
Set cTxt = New clsTextBoxes
' save a pointer to the just created textbox
Set cTxt.tb = Grid(x, y)
' store the postion
cTxt.x = x
cTxt.y = y
' add it to the collection
colTxt.Add cTxt
With Grid(x, y)
.Name = "TextBox_" & x & "_" & y
.Width = 50
.Height = 20
.Left = y * .Width
.Top = x * .Height
.SpecialEffect = fmSpecialEffectFlat
.BorderStyle = fmBorderStyleSingle
End With
Next y
Next x
End Sub
Look at the comments for a short explanation
With myPresentation.Slides(index).Shapes(1).TextFrame.TextRange.Text
.Left = (ActivePresentation.PageSetup.SlideWidth - .Width) / 2
.Top = (ActivePresentation.PageSetup.SlideHeight - .Height) / 2
End With
So basically I have a slide with a 1 title object and I am trying to format it to be centered,
.Left = (ActivePresentation.PageSetup.SlideWidth - .Width) / 2
but this line throws an object required error. Any help is appreciated
The Shape object has Left, Top, Width, and Height properties. TextFrame, TextRange, and Text are irrelevant in this case.
Option Explicit
Sub CenterTitle()
Dim myPresentation As Presentation: Set myPresentation = ActivePresentation
With myPresentation.Slides(1).Shapes(1)
.Left = (myPresentation.PageSetup.SlideWidth - .Width) / 2
.Top = (myPresentation.PageSetup.SlideHeight - .Height) / 2
End With
End Sub
I'd like to have the comment box fit the comments just right (no extra space at the bottom).
I know there is the .AutoSize but I want the maximum width to be 300.
Here is the code I have,
For Each mycell In myRng.Cells
If Not (mycell.Comment Is Nothing) Then
With mycell.Comment.Shape
.TextFrame.AutoSize = True
If .width > 300 Then
lArea = .width * .height
.width = 300
.height = (lArea / 300)
End If
End With
End If
Next mycell
mycell and myRng are Range datatypes, lArea is Long.
Now, this works relatively well but leaves extra space at the bottom of a number of comments because the area the AutoSized text takes up is different from the area of the AutoSized comment box.
Is there a way to check for blank space inside a comment and then trim it? Or is what I have the best it is going to be?
try this ... test comment has been placed in cell E4
discovered by putting Range("e4").Comment.Shape.TextFrame in the Watch window
Sub testComment()
With Range("e4").Comment.Shape
.TextFrame.AutoSize = True
lArea = .Width * .Height
.Width = 300
.Height = (lArea / .Width) ' used .width so that it is less work to change final width
.TextFrame.AutoMargins = False
.TextFrame.MarginBottom = 0 ' margins need to be tweaked
.TextFrame.MarginTop = 0
.TextFrame.MarginLeft = 0
.TextFrame.MarginRight = 0
End With
End Sub
I've changed the code in the previous comment to only resize the box if width is above 300 because otherwise the final size of small boxes were messed up. Also changed to go through all comment box on activesheet
Sub reset_box_size()
Dim pComment As Comment
For Each pComment In Application.ActiveSheet.Comments
With pComment.Shape
.TextFrame.AutoSize = True
lArea = .Width * .Height
'only resize the autosize if width is above 300
If .Width > 300 Then .Height = (lArea / .Width) ' used .width so that it is less work to change final width
.TextFrame.AutoMargins = False
.TextFrame.MarginBottom = 0 ' margins need to be tweaked
.TextFrame.MarginTop = 0
.TextFrame.MarginLeft = 0
.TextFrame.MarginRight = 0
End With
Next
End Sub
there is an autosizefunction.
here is a small code to show how to use:
Dim Rg_Com as Range , Rg_Value as Range
Set Rg_Com = Cells(1,1)
Set Rg_Value = Cells(1,2)
'Comment in A1 will be same as Text in B1:
With Rg_Com
.ClearComments
.AddComment
With .Comment
.Text Text:=Rg_Value.Value2
.Shape.TextFrame.AutoSize = True '<<< just to make all text visible in one comment, all chars having the basic size
End With
End With
I'm struggling with a userform (called Label_Select) that I created.
I'm initializing the userform with some text boxes and check boxes and assigning some values in them.
Then I have a OK button on the userform that was created at design mode (I can create this button at runtime if that helps).
I need to use the text boxes and check boxes values in the code of the OK_Click, refer below.
Currently I get a "Sub or Function not defined" for the OK_Click sub.
How can I pass the text boxes and check boxes values between the userform initialize code and other click events of the userform?
Thank you for your responses
Private Sub UserForm_Initialize()
Dim LotBox(500) As MSForms.TextBox
Dim SensorCheckBox(500) As MSForms.CheckBox
For i = 1 To 4
For j = 1 To 4
k = i + (4 * j)
Set LotBox(k - 4) = Label_Select.Controls.Add("Forms.TextBox.1")
Set SensorCheckBox(k - 4) = Label_Select.Controls.Add("Forms.CheckBox.1")
With LotBox(k - 4)
.Top = 250 + i * 25
.Left = (j * 80) - 50
.Width = 40
.Height = 30
.Font.Size = 14
.Font.Name = "Calibri"
.SpecialEffect = fmSpecialEffectSunken
.Value = k
.AutoSize = True
End With
With SensorCheckBox(k - 4)
.Top = 246 + i * 25
.Left = (j * 80) - 8
.Height = 30
End With
If LotBox(k - 4).Value = " " Then
Label_Select.Controls.Remove LotBox(k - 4).Name
Label_Select.Controls.Remove SensorCheckBox(k - 4).Name
End If
Next j
Next i
End Sub
Private Sub OK_Click()
Worksheets("Sheet1").Cells(1,1)=LotBox(1).Value
Worksheets("Sheet1").Cells(2,1)=SensorCheckBox(1).Value
End Sub
Try making LotBox and SensorCheckBox public variables
You've declared LotBox and SensorCheckBox within UserForm_Initialize, so as soon as that sub ends they will both go out of scope.
Move them up to the top of the module as Global variables.
Hoping you can help. Below is a quick sub that should create a new powerpoint shape based on the shape sent to the procedure x many times. I'm getting a Type Mismatch error the second time through when I try to duplicate the original shape.
Private Sub CreateOneEachPerDP(DPNumber As Integer, OneEach As Powerpoint.Shape)
Dim Count As Integer
Dim NewShape As Powerpoint.Shape
Dim TopOfFirstShape As Integer
Dim SpaceBtwShapes As Integer
For Count = 0 To DPNumber
If Count = 0 Then ' position first shape
'create new shape = OneEach type
Set NewShape = OneEach
With NewShape
.Top = TopOfFirstShape
.Left = 250
End With
Else ' position further shapes
Set NewShape = OneEach.Duplicate ' GIVES AN ERROR OF TYPE MISMATCH - WHY?
With NewShape
.Top = TopOfFirstShape + (Count * SpaceBtwShapes)
.Left = 250
End With
End If
'need to size according to text
With NewShape
.Width = 25
.Height = 20
End With
'load shape with text (if necessary)
Next Count
pwEnd Sub
You can try the following code modification in the Else block (it takes the first and only shape from the Duplicated Range object):
Else ' position further shapes
With OneEach.Duplicate(1)
.Top = TopOfFirstShape + (Count * SpaceBtwShapes)
.Left = 250
End With
End If
Hope this will help.