vba ppt蝴蝶曲线

banjinjiu

file:///C:/Users/Administrator/AppData/Roaming/360se6/Application/User Data/temp/dKeLT26WPAAA&ek=1&kp=1&pt=0&bo=7ACxAAAAAAAFAH4!&su=093454865&sce=0-12-12&rf=2-9..jpg

1. Private Sub CommandButton1_Click() '蝴蝶曲线
   
2. With SlideShowWindows(Index:=1).View
   
3. .PointerColor.RGB = vbBlue
   
4. π = 3.1415926
   
5. r = t * 360
   
6. For t = -π To π Step 0.001
   
7. x = 50 * Sin(t) * (Exp(Cos(t)) - 2 * Cos(4 * t) - Sin(t / 12) ^ 5)
   
8. y = 50 * Cos(t) * (Exp(Cos(t)) - 2 * Cos(4 * t) - Sin(t / 12) ^ 5)
   
9. SlideShowWindows(1).View.DrawLine 360 + x, 270 + y, 360 + x + 0.001, 270 + y + 0.001 '
   
10. Next
    
11. For t = -π To π Step 0.001
    
12. x = 40 * Sin(t) * (Exp(Cos(t)) - 2 * Cos(4 * t) - Sin(t / 12) ^ 5)
    
13. y = 40 * Cos(t) * (Exp(Cos(t)) - 2 * Cos(4 * t) - Sin(t / 12) ^ 5)
    
14. SlideShowWindows(1).View.DrawLine 360 + x, 270 + y, 360 + x + 0.001, 270 + y + 0.001 '
    
15. Next
    
16. For t = -π To π Step 0.001
    
17. x = 20 * Sin(t) * (Exp(Cos(t)) - 2 * Cos(4 * t) - Sin(t / 12) ^ 5)
    
18. y = 20 * Cos(t) * (Exp(Cos(t)) - 2 * Cos(4 * t) - Sin(t / 12) ^ 5)
    
19. SlideShowWindows(1).View.DrawLine 360 + x, 270 + y, 360 + x + 0.001, 270 + y + 0.001 '
    
20. Next
    
21. End With
    
22. End Sub

复制代码

wangg913

可否发个完整的附件，分享给大家。

banjinjiu

附件已上传，是ppt放映模式使用的，不知道改成窗体，我正在研究窗体的gai+，希望得到高手帮助。

banjinjiu

wangg913 发表于 2015-9-19 23:21
可否发个完整的附件，分享给大家。

附件已上传，是ppt放映模式使用的，不知道如何改成窗体。

April100

感谢分享，放映点击按钮，没有响应。

banjinjiu

April100 发表于 2015-10-9 14:50
感谢分享，放映点击按钮，没有响应。

有现成的代码，你可以根据我的代码重新做下，我是win7的系统，ppt2003

带金求助

谢谢分享！学习了！原来VBA还可以这样用！

zopey

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
'Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub CommandButton1_Click()
   
    Dim hwnd, dc, rgbColor
    hwnd = FindWindow(vbNullString, Me.Caption)
    hDC = GetDC(hwnd)
    Pi = 3.1415926
    For i = 1 To 49
    'Me.BackColor = RGB(255, 255, 255)
   If i Mod 6 = 1 Then
      rgb2 = RGB(255, 0, 0)
   ElseIf i Mod 6 = 2 Then
      rgb2 = RGB(255, 255, 0)
   ElseIf i Mod 6 = 3 Then
      rgb2 = RGB(0, 255, 0)
   ElseIf i Mod 6 = 4 Then
      rgb2 = RGB(0, 255, 255)
   ElseIf i Mod 6 = 5 Then
      rgb2 = RGB(0, 0, 255)
   ElseIf i Mod 6 = 0 Then
      rgb2 = RGB(255, 0, 255)
   End If
    For t = Pi * (i - 1) To Pi * i Step 0.001
        X = Sin(t) * (Exp(Cos(t)) - 2 * Cos(4 * t) - Sin(t / 12) ^ 5)
        Y = Cos(t) * (Exp(Cos(t)) - 2 * Cos(4 * t) - Sin(t / 12) ^ 5)
        rgbColor = SetPixel(hDC, 300 + 60 * X, 320 - 60 * Y, rgb2)
        
        Sleep 0.5
        DoEvents
    Next
    Next
   
    ReleaseDC hwnd, hDC
End Sub

dongdonggege

联系，我以前的号，下次，能找到。