I'm looking for a way to center a userform on developer winow, not application.
What I have is that:
'''
Private Sub UserForm_Initialize()
With Me
.StartUpPosition = 0
.Left = Application.VBE.MainWindow.Left '+ (0.25 * Application.VBE.MainWindow.Width) - (0.5 * .Width)
.Top = Application.VBE.MainWindow.Top + (0.25 * Application.VBE.MainWindow.Height) - (0.5 * .Height)
End With
End Sub
'''
But this is not working.
Related
I've been working through a YouTube tutorial for creating a Drag and Drop game in PowerPoint using VBA, and have got the VBA code working as expected, but I'm wondering if anyone could give me some advice on how to add to the code in order to do something that I'm trying to do. I have some programming experience in Python, but no experience scripting PPT files or VBA. Any help you can give here would be appreciated!
What I'm trying to do is apply the code to multiple slides in the same presentation. For example, I want to have some items on one slide be affected by the Drag and Drop code, and then move on to the next slide and do the same with other items. From looking at the code, and from my understanding, it's the sections that have
ActivePresentation.Slides(2)
that are what needs changing. Now, I know that the (2) refers to the slide number, but could you advise what to change this to in order for it to work on ANY slide number (I'm guessing this would need to refer to the current slide somehow). I've tried various commands that I've found online, but none seem to do what I want - anything I enter in the brackets that looks like it should affect the current slide results in the drag and drop not working at all on any slide, including the original slide that was working before the change to the code.
The relevant code is below:
Sub DragAndDrop(selectedShape As Shape)
obj_end = selectedShape.Name + "_end"
dragMode = Not dragMode
DoEvents
' If the shape has text and we're starting to drag, copy it with its formatting to the clipboard
If selectedShape.HasTextFrame And dragMode Then selectedShape.TextFrame.TextRange.Copy
dx = GetSystemMetrics(SM_SCREENX)
dy = GetSystemMetrics(SM_SCREENY)
' Shirt start position
objStart.X = selectedShape.left
objStart.Y = selectedShape.top
objEnd.X = ActivePresentation.Slides(ActivePresentation.View.Slide.SlideNumber).Shapes(obj_end).left
objEnd.Y = ActivePresentation.Slides(ActivePresentation.View.Slide.SlideNumber).Shapes(obj_end).top
'objEnd.X = ActivePresentation.Slides(2).Shapes(obj_end).left
'objEnd.Y = ActivePresentation.Slides(2).Shapes(obj_end).top
Drag selectedShape
' Paste the original text while maintaining its formatting, back to the shape
If selectedShape.HasTextFrame Then selectedShape.TextFrame.TextRange.Paste
DoEvents
End Sub
Private Sub Drag(selectedShape As Shape)
#If VBA7 Then
Dim mWnd As LongPtr
#Else
Dim mWnd As Long
#End If
Dim sx As Long, sy As Long
Dim WR As RECT ' Slide Show Window rectangle
Dim StartTime As Single
' Change this value to change the timer to automatically drop the shape (can by integer or decimal)
Const DropInSeconds = 2
' Get the system cursor coordinates
GetCursorPos mPoint
' Find a handle to the window that the cursor is over
mWnd = WindowFromPoint(mPoint.X, mPoint.Y)
' Get the dimensions of the window
GetWindowRect mWnd, WR
sx = WR.lLeft
sy = WR.lTop
Debug.Print sx, sy
With ActivePresentation.PageSetup
dx = (WR.lRight - WR.lLeft) / .SlideWidth
dy = (WR.lBottom - WR.lTop) / .SlideHeight
Select Case True
Case dx > dy
sx = sx + (dx - dy) * .SlideWidth / 2
dx = dy
Case dy > dx
sy = sy + (dy - dx) * .SlideHeight / 2
dy = dx
End Select
End With
StartTime = Timer
While dragMode
GetCursorPos mPoint
selectedShape.left = (mPoint.X - sx) / dx - selectedShape.Width / 2
selectedShape.top = (mPoint.Y - sy) / dy - selectedShape.Height / 2
Dim left As Integer
Dim top As Integer
left = selectedShape.left
top = selectedShape.top
' Comment out the next line if you do NOT want to show the countdown text within the shape
If selectedShape.HasTextFrame Then selectedShape.TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))
ActivePresentation.Slides(ActivePresentation.View.Slide.SlideNumber).Shapes("lblInfo").TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))
'ActivePresentation.Slides(2).Shapes("lblInfo").TextFrame.TextRange.Text = CInt(DropInSeconds - (Timer - StartTime))
DoEvents
If Timer > StartTime + DropInSeconds Then
dragMode = False
With ActivePresentation.Slides(ActivePresentation.View.Slide.SlideNumber).Shapes(obj_end) ' EXAMPLE:square_end is where you want the square to land
If selectedShape.left >= .left And selectedShape.top >= .top And (selectedShape.left + selectedShape.Width) <= (.left + .Width) And (selectedShape.top + selectedShape.Height) <= (.top + .Height) Then
ActivePresentation.Slides(ActivePresentation.View.Slide.SlideNumber).Shapes("talk").TextFrame.TextRange = "Got it! Great job!"
'totalPoints = totalPoints + 1
Else
' Try again
selectedShape.left = objStart.X
selectedShape.top = objStart.Y
ActivePresentation.Slides(ActivePresentation.View.Slide.SlideNumber).Shapes("talk").TextFrame.TextRange = "Sorry! Try again!"
End If
End With
End If
Wend
DoEvents
End Sub
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 have written VBA code for Dynamically creating textboxes and buttons. The following is the code when I hit an "Add" button on the userform.
Dim oTxtBox As Control
Dim oBrwsBtn As Control
Dim oCaption As Control
Dim oTxtLen As Integer
oTxtLen1 = TextBox1.Width
oTxtBrth1 = TextBox1.Height
oTxtPos1 = TextBox1.Left
oButLen = CommandButton1.Width
oButBrth = CommandButton1.Height
oTxtLen2 = TextBox2.Width
oTxtBrth2 = TextBox2.Height
If i = Empty Then
i = 1
End If
Set oTxtBox = Me.Controls.Add("Forms.TextBox.1")
Set oBrwsBtn = Me.Controls.Add("Forms.CommandButton.1")
Set oCaption = Me.Controls.Add("Forms.TextBox.1")
With oTxtBox
.Left = oTxtPos1
.Top = oTxtBrth1 + 18 + (oTxtBrth + 18) * (i - 1)
.Width = oTxtLen1
.Height = oTxtBrth1
End With
With oBrwsBtn
.Left = oTxtPos1 + oTxtLen1 + 18
.Top = oTxtBrth1 + 18 + (oTxtBrth + 18) * (i - 1)
.Width = oButLen
.Height = oButBrth
End With
With oCaption
.Left = oTxtPos1 + oTxtLen1 + 18 + oButLen + 18
.Top = oTxtBrth1 + 18 + (oTxtBrth + 18) * (i - 1)
.Width = oTxtLen2
.Height = oTxtBrth2
End With
i = i + 1
Q1 Now How to Edit the caption of the browse Button which I create dynamically No method .Caption with oBrWsBtn
And Q2: How to get the value when the focus is changed
For example When I click on 'TextBox1' Object. A variable should assign itself with the name (i. e. var(str) = focus object name)
Thanks in advance
Q1: Why don't you try defining the control type more specifically and see if that permits you to use the .Caption method. Don't understand why it's not working now, but maybe the Control object type doesn't have the .Caption method because not all controls have captions.
Try:
'at the top of the sub:
Dim oBrwsBtn as CommandButton
'then later
Set oBrwsBtn = Me.Controls.Add("Forms.CommandButton.1")
Another option to consider would be to create these buttons and just have them be invisible until needed. But that assumes you don't actually have a good reason to create them dynamically, which you may have.
Q2: Use a control_AfterUpdate sub:
'Dim this wherever appropriate for scope. Could be in the afterupdate sub if that works.
dim TextBox1_Value as string
Private Sub TextBox1_AfterUpdate()
TextBox1_Value = TextBox1.value
End Sub
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.
I have made a user control that contains a panel and i want to add another control that i made to it. All of this i want it to be realised programmatically.
Actualy i wanted to create a Calandar, sizable columns, and cells.
I Want to add my cells to my columns. then add my columns to my Calendar object.
Here is the code i created for the momment..
Creating the columns:
Private Sub CreateColumns()
For i = 0 To Calendar.GetUpperBound(0)
ASFColumns(i) = New ASFcolumn
With ASFColumns(i)
.Width = 252
.Visible = True
.Left = 250 * i + i + 2
.Top = 35
End With
Me.Controls.Add(ASFColumns(i))
'AddHandler Calendar(i, j).Click, AddressOf ClickOnCells
Next
End Sub
Adding my cells to it
For i = 0 To Calendar.GetUpperBound(0)
For j = 0 To Calendar.GetUpperBound(1)
Calendar(i, j) = New ASFmultiTaskCell
With Calendar(i, j)
.Width = 250
.Visible = True
.Left = 250 * j + j + 2
.Top = 33 * i + i + 70
.BringToFront()
End With
'Me.Controls.Add(Calendar(i, j))
ASFColumns(i).Controls.Add(Calendar(i, j))
AddHandler Calendar(i, j).Click, AddressOf ClickOnCells
Next
Next
Thank you
I'm not quite sure what you are trying to do, so I assumed some things. I created Calendar as a 2d array of ASFmultiTaskCell, which is a user control. The follow code sucessfully add the user controls to either a Form or a Panel/Group Box. The event works too.
Dim Calendar(2, 3) As ASFmultiTaskCell
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
For i = 0 To Calendar.GetUpperBound(0)
For j = 0 To Calendar.GetUpperBound(1)
Calendar(i, j) = New ASFmultiTaskCell
With Calendar(i, j)
.Width = 250
.Visible = True
.Left = 250 * j + j + 2
.Top = 33 * i + i + 70
.BringToFront()
End With
Me.Controls.Add(Calendar(i, j))
GroupBox1.Controls.Add(Calendar(i, j))
AddHandler Calendar(i, j).Click, AddressOf ClickOnCells
Next
Next
End Sub
Private Sub ClickOnCells()
End Sub