用VB画圆、正方形、长方形、球、正方体、长方体
1个回答

画圆

VERSION 5.00

Begin VB.Form FMain

BorderStyle = 1 'Fixed Single

Caption = "Form1"

ClientHeight = 5205

ClientLeft = 45

ClientTop = 330

ClientWidth = 7035

LinkTopic = "Form1"

MaxButton = 0 'False

MinButton = 0 'False

ScaleHeight = 5205

ScaleWidth = 7035

StartUpPosition = 2 '屏幕中心

Begin VB.CheckBox chkA

Caption = "自动反转"

Height = 375

Left = 5280

TabIndex = 5

Top = 3600

Width = 1695

End

Begin VB.CheckBox chkAuto

Caption = "自动旋转"

Height = 255

Left = 5280

TabIndex = 4

Top = 3240

Width = 1575

End

Begin VB.Timer tmrTurn

Enabled = 0 'False

Interval = 100

Left = 5280

Top = 4080

End

Begin VB.PictureBox picDraw

Height = 5000

Left = 120

ScaleHeight = 4935

ScaleWidth = 4935

TabIndex = 3

Top = 120

Width = 5000

End

Begin VB.CommandButton cmdTurnAnti

Caption = "正向"

Height = 495

Left = 5280

TabIndex = 2

Top = 1200

Width = 1575

End

Begin VB.TextBox txtAngle

Height = 375

Left = 5280

TabIndex = 1

Text = "30"

Top = 120

Width = 1575

End

Begin VB.CommandButton cmdTurn

Caption = "反向"

Height = 495

Left = 5280

TabIndex = 0

Top = 600

Width = 1575

End

End

Attribute VB_Name = "FMain"

Attribute VB_GlobalNameSpace = False

Attribute VB_Creatable = False

Attribute VB_PredeclaredId = True

Attribute VB_Exposed = False

Option Explicit

Private Const rPI As Single = 3.14159265358979

Private iAngle As Integer '转过角度

Private Sub chkAuto_Click()

tmrTurn.Enabled = chkAuto.Value

End Sub

Private Sub cmdTurn_Click()

iAngle = iAngle + Val(txtAngle.Text)

Call Draw

End Sub

Private Sub cmdTurnAnti_Click()

iAngle = iAngle - Val(txtAngle.Text)

Call Draw

End Sub

Private Sub Form_Load()

picDraw.Scale (-1, 1)-(1, -1) '中心设为原点

picDraw.DrawWidth = 5 '加粗

End Sub

Private Sub Draw()

picDraw.Cls

picDraw.Line (0, 0)-(Cos(iAngle / 180 * rPI), Sin(iAngle / 180 * rPI))

End Sub

Private Sub tmrTurn_Timer()

If chkA.Value = 0 Then

Call cmdTurnAnti_Click

Else

Call cmdTurn_Click

End If

End Sub

矩形

Public Sub DrawRectangle(ByVal Width As Long, ByVal Height As Long, Optional Top As Long, Optional Left As Long)

Line (Left, Top)-(Left + Width, Top)

Line (Left, Top)-(Left, Top + Height)

Line (Left, Top + Height)-(Left + Width, Top + Height)

Line (Left + Width, Top)-(Left + Width, Top + Height)

End Sub

定义一个数组记录某一个值是不是已经被使用

比如有10个数供选择,那就定义a[10],赋初值0,表示没有使用,当抽取一个号码后,比如是5,那就令a[5-1]=1,求救已经使用,每次取数时判断一下取得的数i对应的a[i]是否等于0就可以了.

长方体

Private Type xyz '定义3D坐标类型

y As Single

z As Single

End Type

Private xyz1() As xyz

Public x0 As Single, y0 As Single, x1 As Single, y1 As Single

Private Sub Check1_Click()

If x1 = 0 Or y1 = 0 Then

Exit Sub

End If

If Check1.Value = 1 Then '如果选择显示空间坐标轴,就画出空间坐标轴

Line (x1, y1)-(x1, y1 - 6400)

Line (x1, y1)-(x1 + 6400, y1)

Line (x1, y1)-(x1 - 4050, y1 + 4050)

Line (x1, y1 - 6400)-(x1 - 200, y1 - 6200)

Line (x1, y1 - 6400)-(x1 + 200, y1 - 6200)

Line (x1 + 6400, y1)-(x1 + 6200, y1 + 200)

Line (x1 + 6400, y1)-(x1 + 6200, y1 - 200)

Line (x1 - 4050, y1 + 4050)-(x1 - 4050, y1 + 3850)

Line (x1 - 4050, y1 + 4050)-(x1 - 3850, y1 + 4050)

Else

Cls

End If

End Sub

Private Sub Command1_Click()

drawpnt Val(Text1.Text), Val(Text2.Text), Val(Text3.Text) '这是在三维空间画点的事件

End Sub

Private Sub Command2_Click()

Call VScroll1_Change(0) '画长方体

End Sub

Private Sub Command3_Click()

dmove 0, 500, 0 '移动

End Sub

Private Sub Command4_Click()

dmove -500, 0, 0 '移动

End Sub

Private Sub Command5_Click()

dmove 500, 0, 0 '移动

End Sub

Private Sub Command6_Click()

dmove 0, -500, 0 '移动

End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)

Cls

x0 = x

y0 = y

x1 = x

y1 = y

Call Check1_Click

ReDim xyz1(0 To 1)

xyz1(0).y = x

xyz1(0).z = y

PSet (x, y)

'在程序上点击鼠标画出空间坐标轴,并记录原点

End Sub

Sub drawpnt(dx As Single, dy As Single, dz As Single)

Dim dxy As Single

dxy = Fix(dx * Sqr(2) / 2)

xyz1(0).y = x0 - dxy + dy

xyz1(0).z = y0 + dxy - dz

PSet (xyz1(0).y, xyz1(0).z)

'画点的过程

End Sub

Sub dline(dx1 As Single, dy1 As Single, dz1 As Single, dx2 As Single, dy2 As Single, dz2 As Single)

Dim dxy1 As Single, dxy2 As Single

dxy1 = Fix(dx1 * Sqr(2) / 2)

dxy2 = Fix(dx2 * Sqr(2) / 2)

xyz1(0).y = x0 - dxy1 + dy1

xyz1(0).z = y0 + dxy1 - dz1

xyz1(1).y = x0 - dxy2 + dy2

xyz1(1).z = y0 + dxy2 - dz2

Line (xyz1(0).y, xyz1(0).z)-(xyz1(1).y, xyz1(1).z)

'划线的过程

End Sub

Private Sub VScroll1_Change(index As Integer)

If x0 = 0 Or y0 = 0 Then

Exit Sub

End If

Cls

Call Check1_Click

Dim a As Single, b As Single, c As Single

a = VScroll1(0).Value * 900

b = VScroll1(1).Value * 900

c = VScroll1(2).Value * 900

square a, b, c

'根据a,b,c(长,宽,高)来画长方体的过程

End Sub

Sub square(a As Single, b As Single, c As Single)

dline 0, 0, 0, a, 0, 0

dline 0, 0, 0, 0, b, 0

dline 0, 0, 0, 0, 0, c

dline a, 0, 0, a, b, 0

dline a, 0, 0, a, 0, c

dline 0, b, 0, a, b, 0

dline 0, b, 0, 0, b, c

dline 0, 0, c, a, 0, c

dline 0, 0, c, 0, b, c

dline a, b, c, a, b, 0

dline a, b, c, a, 0, c

dline a, b, c, 0, b, c

End Sub

Sub dmove(dx As Single, dy As Single, dz As Single)

If x0 = 0 Or y0 = 0 Then

Exit Sub

End If

Cls

Call Check1_Click

x0 = x0 + dx

y0 = y0 - dy

Call VScroll1_Change(0)

'移动长方体的过程

End Sub

正方体和长方体的原理一样,写不动啦!