源程序
Form1( 菜单.frm)
Option Explicit
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Const DT_BOTTOM As Long = &H8
Const DT_CALCRECT As Long = &H400
Const DT_CENTER As Long = &H1
Const DT_EXPANDTABS As Long = &H40
Const DT_EXTERNALLEADING As Long = &H200
Const DT_LEFT As Long = &H0
Const DT_NOCLIP As Long = &H100
Const DT_NOPREFIX As Long = &H800
Const DT_RIGHT As Long = &H2
Const DT_SINGLELINE As Long = &H20
Const DT_TABSTOP As Long = &H80
Const DT_TOP As Long = &H0
Const DT_VCENTER As Long = &H4
Const DT_WORDBREAK As Long = &H10
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Const ScrollText As String = "设计题目:送瓶机" & vbCrLf & _
vbCrLf & "工作原理及工艺动作过程:" & _ vbCrLf & "为了清洗圆形瓶子外面" & _
vbCrLf & "需将瓶子推到上" & _
vbCrLf & "同向转动的导辊" & vbCrLf & _ vbCrLf & "送瓶机的主要动作:" & _
vbCrLf & "将到位的瓶子沿着导轨推动" & _ vbCrLf & " 然后通过另一个曲柄滑块" & _ vbCrLf & "将瓶子的送到转动的导辊上" & _ vbCrLf & "导辊带动瓶子旋转" & _
vbCrLf & "推动瓶子沿导辊前进" & _
vbCrLf & "转动的刷子就将瓶子洗净" & _ vbCrLf & "这里我只设计了" & _
vbCrLf & "前半部分的送瓶机构" & _
vbCrLf & "后面的洗瓶机构" & _
vbCrLf & "还有出瓶机构" & _
vbCrLf & "都没有设计出来" & _
vbCrLf & "洗瓶机构已经有人设计出来了" & _
vbCrLf & "出瓶机构有点困难" & _
vbCrLf & "具体的说明我会写在课程设计说明书中" & _
vbCrLf & "大家可以进行参考设计"
Dim EndingFlag As Boolean
Const pi = 3.1415926
Public t, l1, l2, l3, l4, x0, y0, x1, y1, x2, y2, a0, b0, a1, b1, a2, b2, w As Double
Private Sub label5_Click()
Timer1.Enabled = True
Label1.Visible = True
Picture2.Scale (0, 0)-(11000, 11000)
End Sub
Private Sub label6_Click()
Timer1.Enabled = False
Picture2.Scale (0, 0)-(11000, 11000)
End Sub
Private Sub Form_Load()
Top = 0
Left = 0
Form1.Height = Screen.Height
Form1.Width = Screen.Width
Timer1.Enabled = False
picScroll.ForeColor = vbWhite
picScroll.FontSize = 14
picScroll.DrawWidth = 4
picScroll.Font = "华文行楷"
Label1.Visible = False
End Sub
Private Sub label7_Click()
MsgBox "谢谢欣赏我的程序"
End
End Sub
Private Sub mnui参考资料_Click()
Form14.Show
End Sub
Private Sub mnui设计要求_Click()
Form15.Show
End Sub
Private Sub mnusent不完全齿轮机构_Click()
Form10.Show
End Sub
Private Sub mnusent连杆机构_Click()
Form6.Show
End Sub
Private Sub mnusent偏心轮机构_Click()
Form7.Show
End Sub
Private Sub mnusent凸轮机构_Click()
Form8.Show
End Sub
Private Sub Timer1_Timer()
t = t + pi * w / 180
Cls
draw
End Sub
Private Sub draw()
w = 1
l1 = 1200
l2 = 4800
x0 = 1500
y0 = 2500
x1 = x0 + l1 * Cos(t)
y1 = y0 - l1 * Sin(t)
x2 = x0 + l1 * (Cos(t) + l2 / l1 - 0.25 * l1 / l2 + 0.25 * l1 / l2 * Cos(2 * t))
y2 = 3500
l3 = 1200
l4 = 4800
a0 = 8000
b0 = 7500
a1 = a0 + l3 * Cos(t - pi / 2)
b1 = b0 - l3 * Sin(t - pi / 2)
a2 = 8000
b2 = b0 - l3 * (Cos(t - pi) + l4 / l3 - 0.25 * l3 / l4 + 0.25 * l3 / l4 * Cos(2 * (t - pi)))
Picture2.Cls
Picture2.DrawWidth = 3
Picture2.Line (x0, y0)-(x1, y1), vbBlue
Picture2.Line -(x2, y2), vbBlue
Picture2.Line (x2 - 200, y2 - 100)-(x2 + 200, y2 - 100), vbBlue Picture2.Line -(x2 + 200, y2 + 100), vbBlue
Picture2.Line -(x2 - 200, y2 + 100), vbBlue
Picture2.Line -(x2 - 200, y2 - 100), vbBlue
Picture2.Line (x0 - 200, y0 + 200)-(x0, y0), vbGreen
Picture2.Line -(x0 + 200, y0 + 200), vbGreen
Picture2.Line -(x0 - 200, y0 + 200), vbGreen
Picture2.DrawWidth = 3
Picture2.Line (5000, 3700)-(7600, 3700), vbRed
Picture2.DrawWidth = 3
Picture2.Line (a0, b0)-(a1, b1), vbBlue
Picture2.Line -(a2, b2), vbBlue
Picture2.Line (a2 - 200, b2 - 100)-(a2 + 200, b2 - 100), vbBlue Picture2.Line -(a2 + 200, b2 + 100), vbBlue
Picture2.Line -(a2 - 200, b2 + 100), vbBlue
Picture2.Line -(a2 - 200, b2 - 100), vbBlue
Picture2.Line (a0 - 200, b0 + 200)-(a0, b0), vbGreen
Picture2.Line -(a0 + 200, b0 + 200), vbGreen
Picture2.Line -(a0 - 200, b0 + 200), vbGreen
Picture2.DrawWidth = 1
Picture2.Line (7700, 3300)-(7700, 1500), vbYellow
Picture2.Line (7200, 3300)-(7200, 1500), vbYellow
Picture2.Line (7750, 3300)-(7750, 1500), vbYellow
Picture2.Line (8250, 3300)-(8250, 1500), vbYellow
Picture2.DrawWidth = 2
Picture2.Circle (x0, y0), l1, vbYellow
Picture2.Circle (a0, b0), l3, vbYellow
Picture2.Circle (x0, y0), 50, vbYellow
Picture2.Circle (x1, y1), 50, vbYellow
Picture2.Circle (x2, y2), 50, vbYellow
Picture2.Circle (a0, b0), 50, vbYellow
Picture2.Circle (a1, b1), 50, vbYellow
Picture2.Circle (a2, b2), 50, vbYellow
End Sub
Private Sub mnuhelp画线_Click()
Form3.Show
End Sub
Private Sub mnuhelp画圆_Click()
Form4.Show
End Sub
Private Sub mnuhelp曲柄滑块_Click()
Form11.Show
End Sub
Private Sub mnuhelp双曲柄机构_Click()
Form9.Show
End Sub
Private Sub mnumove加速度分析_Click()
Form5.Show
End Sub
Private Sub mnumove速度分析_Click()
Form2.Show
End Sub
Private Sub mnumove位置分析_Click()
Form13.Show
End Sub
Private Sub Form_Activate()
RunMain
End Sub
Private Sub RunMain()
Dim LastFrameTime As Long
Const IntervalTime As Long = 40
Dim rt As Long
Dim DrawingRect As RECT
Dim UpperX As Long, UpperY As Long 'Upper left point of drawing rect Dim RectHeight As Long
Form1.Refresh
Get the size of the drawing rectangle by suppying the DT_CALCRECT constant rt = DrawText(picScroll.hdc, ScrollText, -1, DrawingRect, DT_CALCRECT) If rt = 0 Then 'err
MsgBox "Error scrolling text", vbExclamation
EndingFlag = True
Else
DrawingRect.Top = picScroll.ScaleHeight
DrawingRect.Left = 0
DrawingRect.Right = picScroll.ScaleWidth
RectHeight = DrawingRect.Bottom
DrawingRect.Bottom = DrawingRect.Bottom + picScroll.ScaleHeight End If
Do While Not EndingFlag
If GetTickCount() - LastFrameTime > IntervalTime Then
picScroll.Cls
DrawText picScroll.hdc, ScrollText, -1, DrawingRect, DT_CENTER Or DT_WORDBREAK
DrawingRect.Top = DrawingRect.Top - 1
DrawingRect.Bottom = DrawingRect.Bottom - 1
If DrawingRect.Top < -(RectHeight) Then 'time to reset
DrawingRect.Top = picScroll.ScaleHeight
DrawingRect.Bottom = RectHeight + picScroll.ScaleHeight End If
picScroll.Refresh
LastFrameTime = GetTickCount()
End If
DoEvents
Loop
Unload Me
Set Form1 = Nothing
End Sub
Private Sub Form_Unload(Cancel As Integer)
EndingFlag = True
End Sub
Private Sub Timer2_Timer()
If Label1.Left > -25000 And Label1.Left < 13000 Then
Label1.Left = Label1.Left - 100
Else
Label1.Left = 12000
Label1.Left = Label1.Left - 100
End If
End Sub
For13.(位置分析)
Option Explicit
Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Const DT_BOTTOM As Long = &H8
Const DT_CALCRECT As Long = &H400
Const DT_CENTER As Long = &H1
Const DT_EXPANDTABS As Long = &H40
Const DT_EXTERNALLEADING As Long = &H200
Const DT_LEFT As Long = &H0
Const DT_NOCLIP As Long = &H100
Const DT_NOPREFIX As Long = &H800
Const DT_RIGHT As Long = &H2
Const DT_SINGLELINE As Long = &H20
Const DT_TABSTOP As Long = &H80
Const DT_TOP As Long = &H0
Const DT_VCENTER As Long = &H4
Const DT_WORDBREAK As Long = &H10
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Const ScrollText As String = "如图所示,矢量方程式为" & vbCrLf & _
vbCrLf & "L1+L2=Yc" & _
vbCrLf & "L1eiψ1+L2eiψ2=yc " & _
vbCrLf & "展开后分别取虚部和实部得" & _
vbCrLf & "L1sinψ1+L2sin(180-ψ2)=0" & _
vbCrLf & "所以" & _
vbCrLf & " 180-ψ2=arcsin(-L1sinψ1)/ψ2" & _
vbCrLf & "ψ2=180-arcsin(-L1sinψ1/ψ2)" & _
vbCrLf & "yc=L1codψ1-L2cosψ2" & _
vbCrLf & "这里我定义一个的坐标范围" & _
vbCrLf & "输入的长度最好不要超过10000" Dim EndingFlag As Boolean
Const pi = 3.1415926
Public t, l1, l2, Xc, w As Double
Private Sub label5_Click()
Timer1.Enabled = True
Picture2.Scale (-10, 10000)-(100, -500)
Picture2.DrawWidth = 3
Picture2.Line (-10, 0)-(100, 0), vbBlue
Picture2.Line (0, 10000)-(0, -500), vbBlue
End Sub
Private Sub label6_Click()
Timer1.Enabled = False
Picture2.Scale (-10, 10000)-(100, -500)
Picture2.DrawWidth = 3
Picture2.Line (-10, 0)-(100, 0), vbBlue
Picture2.Line (0, 10000)-(0, -500), vbBlue
End Sub
Private Sub label7_Click()
Unload Me
End Sub
Private Sub label4_Click()
Text1.Text = 1200
Text2.Text = 4800
Text3.Text = 1
End Sub
Private Sub Form_Load()
Top = 0
Left = 0
Form13.Height = Screen.Height
Form13.Width = Screen.Width
Timer1.Enabled = False
picScroll.ForeColor = vbWhite
picScroll.FontSize = 14
picScroll.DrawWidth = 4
picScroll.Font = "华文行楷"
End Sub
Private Sub Timer1_Timer()
t = t + pi * w / 180
draw
End Sub
Private Sub draw()
l1 = Text1.Text
l2 = Text2.Text
w = Text3.Text
Xc = l1 * (Cos(t) + l2 / l1 - 0.25 * l1 / l2 + 0.25 * l1 * Cos(2 * t) / l2)
Text4.Text = Xc
Picture2.DrawWidth = 2
Picture2.PSet (t, Xc), vbYellow
End Sub
Private Sub Form_Activate()
RunMain
End Sub
Private Sub RunMain()
Dim LastFrameTime As Long
Const IntervalTime As Long = 40
Dim rt As Long
Dim DrawingRect As RECT
Dim UpperX As Long, UpperY As Long 'Upper left point of drawing rect
Dim RectHeight As Long
Form13.Refresh
rt = DrawText(picScroll.hdc, ScrollText, -1, DrawingRect, DT_CALCRECT)
If rt = 0 Then 'err
MsgBox "Error scrolling text", vbExclamation
EndingFlag = True
Else
DrawingRect.Top = picScroll.ScaleHeight
DrawingRect.Left = 0
DrawingRect.Right = picScroll.ScaleWidth
RectHeight = DrawingRect.Bottom
DrawingRect.Bottom = DrawingRect.Bottom + picScroll.ScaleHeight
End If
Do While Not EndingFlag
If GetTickCount() - LastFrameTime > IntervalTime Then
picScroll.Cls
DrawText picScroll.hdc, ScrollText, -1, DrawingRect, DT_CENTER Or DT_WORDBREAK
DrawingRect.Top = DrawingRect.Top - 1
DrawingRect.Bottom = DrawingRect.Bottom - 1
If DrawingRect.Top < -(RectHeight) Then 'time to reset
DrawingRect.Top = picScroll.ScaleHeight
DrawingRect.Bottom = RectHeight + picScroll.ScaleHeight
End If
picScroll.Refresh
LastFrameTime = GetTickCount() End If
DoEvents
Loop
Unload Me
Set Form13 = Nothing
End Sub
Private Sub Form_Unload(Cancel As Integer) EndingFlag = True
End Sub