I'm using latest version of Powerpoint on Windows 10.
I'm trying to rotate a 3d model with below code but its not refreshing the screen each time it does a IncrementRotationX
Is there a special function call to get powerpoint to refresh/redraw the 3d object so that it smoothly shows the rotation on screen ? Any help would be appreciated.
Sub Program()
Set myDocument = ActivePresentation.Slides(8)
Dim x As Integer
Dim y As Integer
Dim z As Integer
'Save current position
x = ActivePresentation.Slides(8).Shapes("3D Model 3").Model3D.RotationX
y = ActivePresentation.Slides(8).Shapes("3D Model 3").Model3D.RotationY
z = ActivePresentation.Slides(8).Shapes("3D Model 3").Model3D.RotationZ
MsgBox "RESET Position"
For i = 1 To 45
With myDocument
.Shapes("3D Model 3").Model3D.IncrementRotationX (1)
.Shapes("3D Model 3").Model3D.IncrementRotationY (1)
.Shapes("3D Model 3").Model3D.IncrementRotationZ (1)
End With
Next i
MsgBox "End of routine"
'reset position to starting point
ActivePresentation.Slides(8).Shapes("3D Model 3").Model3D.RotationX = x
ActivePresentation.Slides(8).Shapes("3D Model 3").Model3D.RotationY = y
ActivePresentation.Slides(8).Shapes("3D Model 3").Model3D.RotationZ = z
End Sub
I'm expecting my object to smoothly rotate in the powerpoint slide but it does not. It simply jolts to the last position; its not updating and refreshing to show it rotate as I "IncrementRotationX(1)"
For smooth rotation or animation, it is needed to wait some time between the loops. A possible way is to wait 1 second. (For waiting less than 1 second, see the solutions here - How to give a time delay of less than one second in excel vba?)
Thus, write Wait1Second within the loop:
For i = 1 To 45
With myDocument
.Shapes("3D Model 3").Model3D.IncrementRotationX (1)
.Shapes("3D Model 3").Model3D.IncrementRotationY (1)
.Shapes("3D Model 3").Model3D.IncrementRotationZ (1)
End With
WaitASecond
Next i
This is the sub Wait1Second():
Sub Wait1Second()
Application.Wait (Now + #12:00:01 AM#)
End Sub
And this is a demo in Excel:
The code of the demo:
Option Explicit
Sub TestMe()
Dim cnt As Long
For cnt = 1 To 3
Wait1Second
WriteCircle 15, 1, 1
Wait1Second
WriteCircle 15, 1, 2
Wait1Second
WriteCircle 15, 2, 1
Wait1Second
WriteCircle 15, 2, 2
Next cnt
End Sub
Sub WriteCircle(sizeX As Long, stepX As Long, stepY As Long)
Dim sizeY As Long: sizeY = sizeX
Dim y&, x&, r&, g&, b&
Dim myCell As Range
Worksheets(1).Cells.Clear
For x = 1 To sizeX Step stepX
For y = 1 To sizeY Step stepY
With Worksheets(1)
Set myCell = .Cells(x, y)
If r >= 255 Then
If g >= 255 Then
b = b + 2
Else
g = g + 2
End If
Else
r = r + 2
End If
myCell.Interior.Color = RGB(r, g, b)
End With
Next
Next
End Sub
Related
Currently trying to create a macro that fills in number 1 to 10 down a column and repeats until the end of my For statement. This is what I have in mind:
With a click of a button the number will start at row 3 and count to 10. Once done it will repeat until it reaches the end. I previously done a variant this program which creates repeats of 1 for 10 rows, repeat 2 for the next 10 rows and so on like so:
Sub fill()
Dim ID
ID = 1
For c = 1 To 34
ActiveWorkbook.Sheets("Sheet1").Cells(c + 2, 1) = ID
ActiveWorkbook.Sheets("Sheet1").Cells(c + 3, 1) = ID
c = c + 1
If (c Mod 10) = 0 Then
ID = ID + 1
End If
Next c
End Sub
If I want to convert it to counting 1-10 and then repeat, what needs to be changed. I would like to reuse this code with some modifications to the formula.
Here is an example of a lazy way to do this.
Sub Macro1(offsetIn As Integer, colIn As Integer)
offset = offsetIn - 1
Column = colIn
For c = 1 To 34
ActiveWorkbook.Sheets("Sheet1").Cells(c + offset, colIn) = c Mod 10
If (c Mod 10 = 0) Then
ActiveWorkbook.Sheets("Sheet1").Cells(c + offset, colIn) = 10
End If
Next c
End Sub
As for getting this macro to trigger on click. You can do something like this:
This code needs to go into your worksheet code. i.e. right click on sheet icon and click "view code".
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim rInt As Range
Dim rCell As Range
Set rInt = Intersect(Target, Range("A1:P312"))
If Not rInt Is Nothing Then
Call Macro1(rInt.Row, rInt.Column)
End If
Set rInt = Nothing
Set rCell = Nothing
Cancel = True
End Sub
EDIT: This should now work for any double click on any cell within the Range("A1:P312").
I'm playing with a progress bar (with basically zero experience with VBA whatsoever). I found the following snippet online:
Sub ProgressBar()
On Error Resume Next
With ActivePresentation
.SectionProperties.SlidesCount(
For N = 2 To .Slides.Count
.Slides(N).Shapes("Progress_Bar").Delete
Set s = .Slides(N).Shapes.AddShape(msoShapeRectangle, 0, .PageSetup.SlideHeight - 10, N * .PageSetup.SlideWidth / .Slides.Count, 10)
Call s.Fill.Solid
s.Fill.ForeColor.RGB = RGB(128, 128, 128)
s.Line.Visible = False
s.Name = "Progress_Bar"
Next N:
End With
End Sub
Note the part with For N = 2 To .Slides.Count. I'd like the progress bar not to reach from the second slide the last one but rather from the second slide to the last slide of the section I called "conclusion". How can I do that?
Thanks!
Edit: My current workaround is a hard coded number of slides that I define as a variable at the beginning of the macro and then use the variable throughout the rest of it.
Here are a couple of bits that should get you started:
LastSlideOf returns the slide index of the last slide in the named section passed to it:
Function LastSlideOf(sSectionName As String) As Long
Dim x As Long
With ActivePresentation.SectionProperties
x = SectionIndexOf(sSectionName)
LastSlideOf = (.FirstSlide(x) + .SlidesCount(x)) - 1
End With
End Function
Function SectionIndexOf(sSectionName As String) As Long
Dim x As Long
With ActivePresentation.SectionProperties
For x = 1 To .Count
If .Name(x) = sSectionName Then
SectionIndexOf = x
End If
Next
End With
End Function
I'm a VBA newcomer. I wonder why does sum1() show 10 while sum2() show 11? Thanks in advance.
Sub sum1()
Dim x As Integer
x = 0
For x = 5 To 5
x = x + x
MsgBox x
Next
End Sub
Sub sum2()
Dim x As Integer
x = 0
For x = 5 To 5
x = x + x
Next
MsgBox x
End Sub
A vba for-loop increments the index variable at the end of each iteration. That is what the Next keyword does. In sum1() You get:
Sub sum1()
Dim x As Integer
x = 0 ' x is 0
For x = 5 To 5 ' x set to 5
x = x + x 'x gets 5+5=10
Next 'x gets 10+1=11
MsgBox x 'display x=11
End Sub
but in sum2() you get:
Sub sum2()
Dim x As Integer
x = 0 ' x is 0
For x = 5 To 5 ' x is 5
x = x + x 'x gets 5+5=10
MsgBox x 'display x=10
Next 'x gets 10+1 and is now 11
End Sub
I agree with #MitchWheat, it usually not good practice to modify your index variable while inside a loop. A better approach would be this:
Sub sum3()
Dim x as Integer
Dim i as Integer
x= 1
For i = 5 To 5
x = x + x
Next
MsgBox x
End Sub
For loops increment the loop variable at the end of the loop.
In the second code snippet, the for loop increments x from 10 to 11, and then you display it.
Whereas the first code snippets increments x AFTER you display it. This is not something specific to VBA.
To see this, run:
Sub sum1_1()
Dim x As Integer
x = 0
For x = 5 To 5
x = x + x
MsgBox x
Next
MsgBox x
End Sub
As an aside: It's not best practice to modify loop counters from inside a loop. It can lead to code that is hard to understand.
I am attempting to loop the a specific set of frames within each Multipage page in my VBA User_Form. However, it does not seem like I can use a variable object name with each frame control like I can with the pages.
I am getting an error
object doesn't support this property or method
at the following line
For Each cCont in Me.MultiPage1.Pages(PageName).Frames(DataFrame).Controls
My Code
Do While x <= Me.MultiPage1.Pages.Count
PageName = "Page" & CStr(x)
DataFrame = "DataFrame" & CStr(x)
For Each cCont In Me.MultiPage1.Pages(PageName).Frames(DataFrame).Controls
You actually can't iterate the way you would think you could.
First, you need to iterate through all Pages of your MultiPage1.
Second, loop through all Controls inside the current Page , and check if they are of type Frame, if they are you can iterate inside the Frame but the syntax is a little different (see in the code below).
Code
Option Explicit
Private Sub IterateIn_MultiPage()
Dim x As Long, j As Long
Dim cCont As Control
For x = 0 To Me.MultiPage1.Pages.Count - 1 ' <-- loop through all MultiPage Pages
For Each cCont In Me.MultiPage1.Pages(x).Controls ' <-- loop through controls of current page
If TypeOf cCont Is Frame Then ' <-- check if control type is Frame
For j = 0 To cCont.Controls.Count - 1 '<-- loop through all items related to the current Frame collection
MsgBox cCont.Controls(j).Name '<-- display a message box
Next j
End If
Next cCont
Next x
End Sub
Thanks for the help on putting together the code #Shai, for anyone else wondering what the final code looks like here it is. This loops through each frame within each multipage and pastes the caption of checked checkboxes in my desired range.
Option Explicit
Sub IterateIn_MultiPage()
Dim x As Long, j As Long
Dim cCont As Control
Dim counter As Integer
Dim y As Integer
Dim Range As String
y = 1
For x = 0 To ImportData.MultiPage1.Pages.Count - 1
counter = 0
For Each cCont In ImportData.MultiPage1.Pages(x).Controls
Do While counter < 1
If TypeOf cCont Is Frame Then
For j = 0 To cCont.Controls.Count - 1
If cCont.Controls(j).Value = True Then
Range = "E" & y
If counter = 0 Then
Worksheets("Calculations").Range(Range) = cCont.Controls(j).Caption
counter = counter + 1
ElseIf counter = 1 Then
Worksheets("Calculations").Range(Range) = Worksheets("Calculations").Range(Range) & " & " & cCont.Controls(j).Caption
y = y + 1
End If
End If
Next j
End If
Loop
Next cCont
Next x
End Sub
I have a 16*16 matrix and I'm trying to define them as a matrix series in vb.net. Then i make some visual shows with this matrix like led shows.
Dim n As Integer = 16
Dim l As Integer = 16
Dim x(n - 1, l - 1) As Integer
Dim i, j, k As Integer
For i = 0 To n - 1
For j = 0 To l - 1
For k = 1 To 256
If j= k mod16 then
buton(k) = x(i, j)
end if
Next
Next
Next***
I try to apply an algorithm. But it doesn't work. How can i accomplish this? Thanks for your interests..
OK I wrote something like this a while ago - I've adapted it to your needs and it runs ok on my pc. You need to create you array X like this
Dim x(15,15) As Button
To fill the array with buttons, use this method..
Private Sub InitializeArray()
Dim btnslist As New List(Of Button)
Dim btnNum As Integer
Dim btnName As String
Dim splitButtonName() As String
'add all the buttons to a list
For Each btnControl As Object In Controls
Dim btn As Button
'get button number and add it to the list if it is >0 and <=256
If TypeOf btnControl Is Button Then
btn = CType(btnControl, Button)
'get the button number
splitButtonName = Split(btn.Name, "n")
If CInt(splitButtonName(1)) > 0 And CInt(splitButtonName(1)) <= 256 Then
btnslist.Add(btn)
End If
End If
Next
'add the buttons to the matrix in the right order
For i As Integer = 0 To 15
For j As Integer = 0 To 15
For k As Integer = 0 To 255
btnNum = i * 16 + j + 1
btnName = "Button" & btnNum.ToString
If btnslist(k).Name = btnName Then
x(i, j) = btnslist(k)
Exit For
End If
Next
Next
Next
End Sub