Keskustelu: Koodit: VB6: Pyöriteltävä 3D-kuutio

Option Explicit
'Hiirellä käänneltävä 3D-kuutio (rautalanka)
'Antero Korteila  3.10.2000
'muokattu 1.3.2004
'kärkipisteiden koordinaatit
Dim px(7) As Single, py(7) As Single, pz(7) As Single
Dim xx As Single, yy As Single, zz As Single 'muunnoksen apuna
Dim mx(7) As Single, mz(7) As Single 'projektiot
Dim X0 As Single, Y0 As Single 'Hiirikoordinaatit
Dim a As Single, b As Single 'katselukulmat, b pystysuunta
Dim c As Single 'särmän puolisko
Dim d As Single, k As Single 'perspektiivi, d=etäisyys
Dim sa As Single, sb As Single 'sinit
Dim ca As Single, cb As Single 'cosinit
Dim I As Integer 'laskuri
Dim ra As Single 'rad > asteet
Dim z As Single 'zoomaus
Dim dx As Single, dy As Single


Sub kuvio() '3D-kuution piirtäminen
  For I = 0 To 7
    muunnos 'lasketaan pisteiden projektiot
  Next
  Pic.Cls
  Pic.Line (mx(0), mz(0))-(mx(1), mz(1)) 'särmä 0 - 1
  For I = 2 To 7
    Pic.Line -(mx(I), mz(I)) 'jne.
  Next
  Pic.Line -(mx(0), mz(0))
  Pic.Line -(mx(5), mz(5))
  Pic.Line (mx(4), mz(4))-(mx(1), mz(1))
  Pic.Line (mx(2), mz(2))-(mx(7), mz(7))
  Pic.Line (mx(6), mz(6))-(mx(3), mz(3))

  'präntätään kirjaimet A, B, C ja D
  Pic.CurrentX = mx(5) - 0.4 * z / d
  Pic.CurrentY = mz(5)
  Pic.Print "A"
  Pic.CurrentX = mx(0) - 0.4 * z / d
  Pic.CurrentY = mz(0) + 0.1 * z / d
  Pic.Print "B"
  Pic.CurrentX = mx(1) - 0.4 * z / d
  Pic.CurrentY = mz(1) + 0.1 * z / d
  Pic.Print "C"
  Pic.CurrentX = mx(2) + 0.2 * z / d
  Pic.CurrentY = mz(2) + 0.2 * z / d
  Pic.Print "D"
End Sub

Sub muunnos()
'koordinaatiston kierto z-aks. ympäri kulman a myötäpäivään
'ja xx-aks. ympäri kulman b myötäpäivään
'projektiotaso on xx,zz-taso, katsotaan yy-aks. suuntaan
  xx = px(I) * ca + py(I) * sa 'x --> xx, y --> yy
  yy = (py(I) * ca - px(I) * sa) * cb - pz(I) * sb
  zz = (py(I) * ca - px(I) * sa) * sb + pz(I) * cb
  k = z / (d + yy) 'etäisyydestä riippuva projisointikerroin
'mitä kauempana pisteet ovat, sitä lähemmäksi keskustaa ne siirtyvät
  mx(I) = k * xx
  mz(I) = k * zz
End Sub

Private Sub Pic_KeyPress(KeyAscii As Integer)
  Select Case KeyAscii
  Case Asc("-")     'kameran etäisyys
    d = d / 1.01    'lähelle
    'rajoitetaan minimietäisyys = kuution särmä
    If d < 2 * c Then d = 2 * c
  Case Asc("+")     'kauas
    d = d * 1.01
  Case Asc("x")     'kuution siirto x-aks. suunnassa
    For I = 0 To 7
      px(I) = px(I) - 0.05
    Next
  Case Asc("X")
    For I = 0 To 7
      px(I) = px(I) + 0.05
    Next
  Case Asc("y")     'kuution siirto y-aks. suunnassa
    For I = 0 To 7
      py(I) = py(I) - 0.05
    Next
  Case Asc("Y")
    For I = 0 To 7
      py(I) = py(I) + 0.05
    Next
  Case Asc("z")     'zoomaus
    z = z / 1.01    'kauas
  Case Asc("Z")
    z = z * 1.01    'lähelle
  End Select
  lblD = Format(d, "##.0 cm")
  lblZ = Format(z, "##.0 cm")
  Pic.FontSize = 14 * z / d
  kuvio
End Sub

Private Sub Pic_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  X0 = X: Y0 = Y
End Sub

Private Sub Pic_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If Button Then
    a = a + (X0 - X) / 3: b = b + (Y0 - Y) / 3
    lbla = Format(ra * a, "###.0°")
    lblb = Format(-ra * b, "###.0°")
    sa = Sin(a): ca = Cos(a)
    sb = Sin(b): cb = Cos(b)
    X0 = X: Y0 = Y
    kuvio
  End If
End Sub

Private Sub Form_Load()
  Pic.AutoRedraw = True
  Pic.ScaleMode = 7
  Pic.ScaleLeft = -Pic.ScaleWidth / 2
  Pic.ScaleTop = -Pic.ScaleHeight / 2
  c = Pic.ScaleHeight
  If c > Pic.ScaleWidth Then c = Pic.ScaleWidth
  c = c / 4: d = 25: z = 25
  Pic.DrawWidth = 2
  Pic.FontName = "Times New Roman"
  Pic.FontSize = 12
  Pic.FontBold = True
  ra = 45 / Atn(1)
  a = 30 / ra: b = -20 / ra
  lbla = Format(ra * a, "###.0°")
  lblb = Format(-ra * b, "###.0°")
  lblD = Format(d, "##.0 cm")
  lblZ = Format(z, "##.0 cm")
  sa = Sin(a): ca = Cos(a)
  sb = Sin(b): cb = Cos(b)
  px(0) = -c: py(0) = -c: pz(0) = -c
  px(1) = c: py(1) = -c: pz(1) = -c
  px(2) = c: py(2) = c: pz(2) = -c
  px(3) = c: py(3) = c: pz(3) = c
  px(4) = c: py(4) = -c: pz(4) = c
  px(5) = -c: py(5) = -c: pz(5) = c
  px(6) = -c: py(6) = c: pz(6) = c
  px(7) = -c: py(7) = c: pz(7) = -c
  kuvio
End Sub