Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
корректировка макроса вращения 3d фигуры
 
#1
22.05.2018 14:24:50
Приветствую форумчан!
На просторах интернета нашёл интересный код, для вращения 3d формы, можно ли заставить вращаться не одну форму а несколько, но не синхронно, а так же появление формы сделать только при отработке кода
 
 
 
#2
22.05.2018 14:38:14
Цитата
adamm написал:
можно ли заставить вращаться не одну форму а несколько, но не синхронно
а как, попеременно?

Цитата
adamm написал:
а так же появление формы сделать только при отработке кода
Хочется написать, покажите на примере. например так.
Код
Sub Heart()
    With ActiveSheet.Shapes.Range(Array("Сердце 1"))
        .Visible = True
    With .ThreeD
    For i = 1 To 3000
        'With ActiveSheet.Shapes.Range(Array("Сердце 1")).ThreeD
            .RotationX = i
            .RotationY = i / 20
            .RotationZ = i / 2
        'End With
        DoEvents
        Application.Wait (Now + TimeSerial(0, 0, 0.2))
    Next i
    End With
    .Visible = False
    End With
End Sub
Изменено: БМВ - 22.05.2018 14:38:24
По вопросам из тем форума, личку не читаю.
 
 
 
#3
22.05.2018 14:47:18
В макросах я не силён, объясню простыми словами, нажал на кнопку, появились несколько сердечек и крутятся при том не одинаково то есть по разным осям или стартуют с разных позиций
 
 
 
#4
22.05.2018 14:51:09
Тюнить не имеет смысла. Ну как то так.
По вопросам из тем форума, личку не читаю.
 
 
 
#5
22.05.2018 16:22:35
Ну почему не имеет, можно чутка усложнить правила :-)
Код
Sub Heart()
    Dim shapesColl As ShapeRange, shp As Shape
    Set shapesColl = ActiveSheet.Shapes.Range(Array("Heart 1", "Heart 3", "Heart 4", "Heart 5"))

    rotationLimit = 8
    movementLimit = 8
    monoMovementLimit = 30
    
    
    windowXBorder = ActiveWindow.Width - 50
    windowyBorder = ActiveWindow.Height - 250
    
    ReDim shapesMovements(1 To shapesColl.Count, 0 To 8)
    For i = LBound(shapesMovements, 1) To UBound(shapesMovements, 1)
        ' Start pos X
        shapesMovements(i, 0) = Application.RandBetween(50, 600)
        ' Start pos Y
        shapesMovements(i, 1) = Application.RandBetween(50, 300)
        ' Start Width
        shapesMovements(i, 2) = Application.RandBetween(100, 150)
        ' Start Height
        shapesMovements(i, 3) = Application.RandBetween(100, 150)
        
        With shapesColl(i)
            .Visible = msoTrue
            .Left = shapesMovements(i, 0)
            .Top = shapesMovements(i, 1)
            .Width = shapesMovements(i, 2)
            .Height = shapesMovements(i, 3)
        End With
        
        
        ' Movement X
        shapesMovements(i, 4) = Application.RandBetween(-1 * rotationLimit, rotationLimit)
        ' Movement Y
        shapesMovements(i, 5) = Application.RandBetween(-1 * rotationLimit, rotationLimit)
        ' Rotation X
        shapesMovements(i, 6) = Application.RandBetween(-1 * rotationLimit, rotationLimit)
        ' Rotation Y
        shapesMovements(i, 7) = Application.RandBetween(-1 * rotationLimit, rotationLimit)
        ' Rotation Z
        shapesMovements(i, 8) = Application.RandBetween(-1 * rotationLimit, rotationLimit)
    Next i
    
    
    For j = 1 To 2000
    For i = 1 To shapesColl.Count
        On Error Resume Next
            shapesColl(i).Left = shapesColl(i).Left + shapesMovements(i, 4)
            shapesColl(i).Top = shapesColl(i).Top + shapesMovements(i, 5)
            
            If shapesColl(i).Left = 0 Or shapesColl(i).Left > windowXBorder Then shapesMovements(i, 4) = shapesMovements(i, 4) * -1
            If shapesColl(i).Top = 0 Or shapesColl(i).Top > windowyBorder Then shapesMovements(i, 5) = shapesMovements(i, 5) * -1
            
        With shapesColl(i).ThreeD
        
        
            .RotationX = .RotationX + shapesMovements(i, 6)
            .RotationY = .RotationY + shapesMovements(i, 7)
            .RotationZ = .RotationZ + shapesMovements(i, 8)
            If _
                (.RotationX \ shapesMovements(i, 6)) > monoMovementLimit Or _
                (.RotationY \ shapesMovements(i, 7)) > monoMovementLimit Or _
                (.RotationZ \ shapesMovements(i, 8)) > monoMovementLimit Then
                
                    'Debug.Print shapesColl(i).Name & " is changing direction"
                    
                    ' Movement X
                    shapesMovements(i, 4) = shapesMovements(i, 4) + (Application.RandBetween(-1 * rotationLimit, rotationLimit) / 2)
                    If shapesMovements(i, 4) < 0 Then
                        shapesMovements(i, 4) = Application.Max(shapesMovements(i, 4), -1 * monoMovementLimit)
                    Else
                        shapesMovements(i, 4) = Application.Min(shapesMovements(i, 4), monoMovementLimit)
                    End If
                    
                    ' Movement Y
                    shapesMovements(i, 5) = shapesMovements(i, 5) + (Application.RandBetween(-1 * rotationLimit, rotationLimit) / 2)
                    If shapesMovements(i, 5) < 0 Then
                        shapesMovements(i, 5) = Application.Max(shapesMovements(i, 5), -1 * monoMovementLimit)
                    Else
                        shapesMovements(i, 5) = Application.Min(shapesMovements(i, 5), monoMovementLimit)
                    End If
                    
                    ' Rotation X
                    shapesMovements(i, 6) = shapesMovements(i, 6) + (Application.RandBetween(-1 * rotationLimit, rotationLimit) / 2)
                    If shapesMovements(i, 6) < 0 Then
                        shapesMovements(i, 6) = Application.Max(shapesMovements(i, 6), -1 * monoMovementLimit)
                    Else
                        shapesMovements(i, 6) = Application.Min(shapesMovements(i, 6), monoMovementLimit)
                    End If
                    
                    ' Rotation Y
                    shapesMovements(i, 7) = shapesMovements(i, 7) + (Application.RandBetween(-1 * rotationLimit, rotationLimit) / 2)
                    If shapesMovements(i, 7) < 0 Then
                        shapesMovements(i, 7) = Application.Max(shapesMovements(i, 7), -1 * monoMovementLimit)
                    Else
                        shapesMovements(i, 7) = Application.Min(shapesMovements(i, 7), monoMovementLimit)
                    End If
                    
                    ' Rotation Z
                    shapesMovements(i, 8) = shapesMovements(i, 7) + (Application.RandBetween(-1 * rotationLimit, rotationLimit) / 2)
                    If shapesMovements(i, 8) < 0 Then
                        shapesMovements(i, 8) = Application.Max(shapesMovements(i, 8), -1 * monoMovementLimit)
                    Else
                        shapesMovements(i, 8) = Application.Min(shapesMovements(i, 8), monoMovementLimit)
                    End If
            End If
        End With
        DoEvents
    Next i
    Next j

End Sub
In GoTo we trust
 
 
 
#6
23.05.2018 01:22:12
Всем спасибо! Супер!
 
 
 
Страницы: 1
Наверх