三维动态仿真 vba编程运行后鼠标会闪动请问一下有没有好的办法解决代码如下

liaoqt · 发表于 2014-10-7 20:55:58

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。

您需要登录才可以下载或查看，没有帐号？注册

x

本帖最后由 liaoqt 于 2014-10-7 20:57 编辑

Option Explicit
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Public Sub test()
Dim Boxobj  As Acad3DSolid
Dim cylinderobj As Acad3DSolid
Dim Ptcen(2) As Double
Dim Heigth As Double, Length As Double, Width As Double, Radius As Double
Dim pt1(2) As Double
pt1(0) = 12: pt1(1) = 0: pt1(2) = 0
Dim sset As AcadSelectionSet
Dim Objentity As AcadEntity
Set sset = ThisDrawing.SelectionSets.Add("NewSSet")
sset.Select acSelectionSetAll
      For Each Objentity In sset
         Objentity.Delete
      Next
sset.Delete
With ThisDrawing

      Ptcen(0) = 0: Ptcen(1) = -57: Ptcen(2) = -40:
      Length = 30: Width = 6: Heigth = 100
      Set Boxobj = .ModelSpace.AddBox(Ptcen, Length, Width, Heigth)
      Boxobj.color = 28
      Ptcen(0) = 0: Ptcen(1) = 57: Ptcen(2) = -40:
      Length = 30: Width = 6: Heigth = 100
      Set Boxobj = .ModelSpace.AddBox(Ptcen, Length, Width, Heigth)
      Boxobj.color = 28

      Ptcen(0) = 0: Ptcen(1) = 0: Ptcen(2) = 0:
      Length = 10: Width = 10: Heigth = 10: Radius = 3
      Set Boxobj = .ModelSpace.AddBox(Ptcen, Length, Width, Heigth)
      Set cylinderobj = .ModelSpace.AddCylinder(Ptcen, Radius, Heigth)
      cylinderobj.Rotate3D Ptcen, pt1, 90 * 3.1415926 / 180
      Boxobj.Boolean acSubtraction, cylinderobj
      Boxobj.color = 1
      Radius = 2.8
      Heigth = 120
      Set cylinderobj = .ModelSpace.AddCylinder(Ptcen, Radius, Heigth)
      cylinderobj.Rotate3D Ptcen, pt1, 90 * 3.1415926 / 180
      cylinderobj.color = 2

End With
Dim Frompt(2) As Double, Topt(2) As Double
Frompt(0) = 0: Frompt(1) = 0: Frompt(2) = 0
Topt(0) = 0: Topt(1) = -49: Topt(2) = 0
Boxobj.Move Frompt, Topt
Boxobj.Update
Frompt(1) = -49
Topt(1) = -48.9
Dim num1 As Double, num As Double
num1 = 1
Do
      If Topt(1) >= 49 Then
         num = Topt(1)
         Topt(1) = Frompt(1)
         Frompt(1) = num
         num1 = -1
      ElseIf Topt(1) <= -49 Then
         num = Topt(1)
         Topt(1) = Frompt(1)
         Frompt(1) = num
         num1 = 1
      End If
      Frompt(1) = Frompt(1) + 0.1 * num1
      Topt(1) = Topt(1) + 0.1 * num1
      Boxobj.Move Frompt, Topt
      Call DelayTime(1)
      Boxobj.Update
      If GetAsyncKeyState(27) = -32767 Then
         Exit Do
      End If
Loop
End Sub

Public Function DelayTime(ByVal timer As Integer)  '延时函数
Dim firsttimer As Long
Dim i As Integer
firsttimer = timeGetTime
For i = 0 To timer
   While timeGetTime < firsttimer + 20
         DoEvents
   Wend
   firsttimer = timeGetTime
Next i
End Function

woaishuijia · 发表于 2014-10-8 08:23:17

timeGetTime函数没有声明

liaoqt · 发表于 2014-10-8 17:32:51

woaishuijia 发表于 2014-10-8 08:23 static/image/common/back.gif& N0 L" s, q" y3 i$ f# _& I- B4 D
timeGetTime函数没有声明

是我粘贴时后忘了实际上是申明过了的主要问题是鼠标会闪在运行时

woaishuijia · 发表于 2014-10-9 06:42:58

本帖最后由 woaishuijia 于 2014-10-9 06:52 编辑

把要移动的对象做成块,再插入块参照,用修改块参照对象的InsertionPoint属性的办法改变它的位置,不使用MOVE方法
看这个用什么方法使曲柄连杆机构转动？
PS:重帖下你的代码.以后发帖时请注意用"添加代码文字"的方法,否则代码中会有大量乱码,别人复制你的代码会很麻烦

Option Explicit7 C7 c. |/ R- O- q) b7 J: U
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer+ F. a; k) P; W0 B1 _
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
* t5 T1 U; w C3 o
Public Sub test()
y4 r: s5 S& L5 g; y$ `7 w) o
Dim Boxobj As Acad3DSolid1 D+ z- b2 @8 `9 ~
Dim cylinderobj As Acad3DSolid
* @! Y& I& w# A
Dim Ptcen(2) As Double
. v6 w# e7 i+ Z3 b, e6 @
Dim Heigth As Double, Length As Double, Width As Double, Radius As Double
3 K4 K8 c8 h5 I4 g
Dim pt1(2) As Double
* b5 u, p3 S* A+ T
pt1(0) = 12: pt1(1) = 0: pt1(2) = 0
" Y/ i0 M( C) i4 q1 [
Dim sset As AcadSelectionSet, ^: U4 l3 P4 A8 b
Dim Objentity As AcadEntity8 ^2 w0 n4 f) D- ~+ z7 @
Set sset = ThisDrawing.SelectionSets.Add("NewSSet")
9 t5 I( w6 Q5 {" G7 d- d
sset.Select acSelectionSetAll; ~3 C2 p( _* M% f, F; p* a! {
For Each Objentity In sset
: P' x. K) |' x3 P3 J3 M# o1 n
Objentity.Delete. [0 ]; H) N6 X1 M
Next
`* c4 ]- s6 U$ o& _+ ^
sset.Delete f6 b; N8 H) H5 \6 G( F
With ThisDrawing% _: I" q `+ O1 ~$ A
/ G7 @* _$ W v, H
Ptcen(0) = 0: Ptcen(1) = -57: Ptcen(2) = -40:. [& Y0 l+ a, [& N
Length = 30: Width = 6: Heigth = 100
6 Q7 `1 Z3 \) A) h& ~) j
Set Boxobj = .ModelSpace.AddBox(Ptcen, Length, Width, Heigth)# j" t" g( R) C M
Boxobj.color = 289 B) R2 K$ g/ n2 u3 M& T, l6 Y
Ptcen(0) = 0: Ptcen(1) = 57: Ptcen(2) = -40:
8 N# W. b4 V4 F- ~# K! w0 q+ k2 C
Length = 30: Width = 6: Heigth = 100' Z/ s1 G; [3 Y4 `+ P
Set Boxobj = .ModelSpace.AddBox(Ptcen, Length, Width, Heigth)& i: h! t+ a* ^8 ^3 E' a
Boxobj.color = 287 U& a7 g" Z6 T6 K4 }: O4 ~
8 P4 T& ?' I: {+ I4 q3 G
Ptcen(0) = 0: Ptcen(1) = 0: Ptcen(2) = 0:0 j7 |( Q |. c' ~; n3 N0 }0 a
Length = 10: Width = 10: Heigth = 10: Radius = 35 c4 R5 k+ Q/ x3 k. ~: p U: J
Set Boxobj = .ModelSpace.AddBox(Ptcen, Length, Width, Heigth)
& f# h6 S, ]/ v' ~! t& h
Set cylinderobj = .ModelSpace.AddCylinder(Ptcen, Radius, Heigth)
9 M( j' E9 X5 k
cylinderobj.Rotate3D Ptcen, pt1, 90 * 3.1415926 / 180
) x" V$ P, Q5 ^& M" h$ ?2 @
Boxobj.Boolean acSubtraction, cylinderobj0 p. n& Z1 ^* W# p: [; o
Boxobj.color = 1, _, i+ P0 A2 [# b: x
Radius = 2.8
1 m# K- K0 P# V# p7 u4 X
Heigth = 120
* z: i9 a( T' f
Set cylinderobj = .ModelSpace.AddCylinder(Ptcen, Radius, Heigth)' j2 I% S' q# {# x6 T4 K
cylinderobj.Rotate3D Ptcen, pt1, 90 * 3.1415926 / 180: I0 X3 e$ }% r3 u* ~
cylinderobj.color = 2) x% j4 r, S/ f
% h c/ |0 \( A0 S- D0 W( k+ J
End With
4 I, @1 Z3 h9 Z( c0 X/ w
Dim Frompt(2) As Double, Topt(2) As Double" K$ P3 R1 z# |
Frompt(0) = 0: Frompt(1) = 0: Frompt(2) = 0
Topt(0) = 0: Topt(1) = -49: Topt(2) = 0
, _; E% d; K. ^/ p/ N7 H
Boxobj.Move Frompt, Topt4 A6 x0 X4 H a* {7 ^9 }
Boxobj.Update
) l1 T$ E* O9 B+ l1 e5 v
Frompt(1) = -49! d9 A% `& m' G5 ]1 q
Topt(1) = -48.93 W) ~ V& R9 A$ Z- z
Dim num1 As Double, num As Double
+ o( Q$ a# T5 d/ Q
num1 = 1: |! W5 V! `6 @" l, l
Do' `! ?6 w" C3 A4 W8 e
If Topt(1) >= 49 Then( x3 e6 G3 A: E/ H, \8 m
num = Topt(1)% q; s- d$ R8 o8 }( o# ~, G8 Q) w
Topt(1) = Frompt(1)3 i. x) X v/ g' i
Frompt(1) = num+ x: B0 N# L0 r4 j: x) L
num1 = -1
! u; o$ y) [2 M( m# e% p* X
ElseIf Topt(1) <= -49 Then( u4 O7 i8 X0 j$ D8 [
num = Topt(1)
& F9 k" @ i9 J6 {( K8 K z) X
Topt(1) = Frompt(1); \( y$ T4 S3 y9 h& z
Frompt(1) = num
8 J$ I, p @ U7 Q! p% H$ X
num1 = 1: f" w9 }3 D/ A7 K+ }
End If
# e4 G6 i' i* F( n# ^
Frompt(1) = Frompt(1) + 0.1 * num1' g( {6 y" }1 r2 K; y
Topt(1) = Topt(1) + 0.1 * num1! x, n C/ ]4 s, D
Boxobj.Move Frompt, Topt
9 L8 m& B7 d9 S, ]1 t& }
Call DelayTime(1)4 z1 A3 i2 O! Y+ Z8 e
Boxobj.Update% _5 ^+ N' Z. R( X/ z+ P
If GetAsyncKeyState(27) = -32767 Then+ [( E9 W0 c4 M* ^
Exit Do* V, Z+ R7 B& ]2 i' K0 }
End If
1 Z* y9 K8 ]; h/ `. Y: n5 ^+ Y. j
Loop4 u+ m9 v4 r2 w6 L- c( O' \' d, Z3 {
End Sub
; {, u) S( X% @' o" `: o
$ X0 a9 _) T2 D2 [& E
Public Function DelayTime(ByVal timer As Integer) '延时函数2 t2 K$ s" m5 t& t4 O
Dim firsttimer As Long' ~4 G' U' T! j- M
Dim i As Integer
" s8 E# ]4 p1 }& w" {( a
firsttimer = timeGetTime
9 q9 R1 B4 Q& L7 R X @: n2 U6 M
For i = 0 To timer
8 ]! j. O0 h$ @" {/ n
While timeGetTime < firsttimer + 20
% I- u$ y# t; a, }( M. b/ V E
DoEvents& M/ l7 _! c$ ^
Wend
9 {' ]& o8 H: ~" z' P7 g7 U
firsttimer = timeGetTime
c! d- N0 V- O
Next i
- ? K. k, E. x
End Function

复制代码

liaoqt · 发表于 2014-10-9 14:53:43

woaishuijia 发表于 2014-10-9 06:42 static/image/common/back.gif1 c' q. v' z% c# k
把要移动的对象做成块,再插入块参照,用修改块参照对象的InsertionPoint属性的办法改变它的位置,不使用MOVE方 ...

非常感谢你推荐的帖子里有代码解释赞一个

:lol:

		自动登录	找回密码
密码			注册

通知

[求助] 三维动态仿真 vba编程运行后鼠标会闪动请问一下有没有好的办法解决代码如下

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。

浏览过的版块

通知

[求助] 三维 动态仿真 vba编程 运行后 鼠标会闪动 请问一下 有没有好的办法解决 代码如下

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。

浏览过的版块

[求助] 三维动态仿真 vba编程运行后鼠标会闪动请问一下有没有好的办法解决代码如下