form1.frm

Scanin geomedia web map supermap TerraVista生成视景数据库 VirtuoZo数字摄影测量系统 集思宝G516-专业GIS数据采集器 激光测距仪手册

VERSION 5.00
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "byzh1110"
   ClientHeight    =   4650
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   7560
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   310
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   504
   StartUpPosition =   2  'CenterScreen
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   44
      Left            =   7200
      Top             =   4440
   End
   Begin VB.PictureBox picRay 
      Appearance      =   0  'Flat
      AutoSize        =   -1  'True
      BackColor       =   &H00FFFFFF&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   2040
      Left            =   960
      ScaleHeight     =   136
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   128
      TabIndex        =   1
      Top             =   1200
      Width           =   1920
   End
   Begin VB.PictureBox Picture1 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   2040
      Left            =   4560
      ScaleHeight     =   136
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   136
      TabIndex        =   0
      Top             =   1200
      Width           =   2040
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'桌球

'vb游戏开发站
Private Declare Function GetTickCount Lib "kernel32" () As Long
Dim FPS_Count As Long
Dim CColor As Long
Dim CColor2 As Long

Const rao As Single = 45 '球半径

Private Type ball
X As Vector
Y As Vector
Z As Vector
 angv As Single
 angh As Single
End Type
Dim light As Vector
Dim eye As Vector

Dim Showd As Vector
Dim Showd1 As Vector
Dim Showd2 As Vector
Dim Showd3 As Vector

Dim c As Single
Dim c2 As Single

Dim Sqrr(0 To 127, 0 To 127) As Vector
'Dim atnn(-10000 To 10000) As Single
Dim tmp As Vector
Dim tmpc As Vector
Dim tmpd As Vector
Dim ang As Single
Dim ang2 As Single
Dim lng As Single
Dim lng2 As Single
Dim asb As Single
Dim i As Long
Dim j As Long
Dim K1 As Single
Dim K2 As Single
Dim K3 As Single
Dim K4 As Single
Dim T1 As Long
Dim T2 As Long
Dim ball As ball

Private Sub Command1_Click()
Picture1.Cls
tim = 0

Timer1.Enabled = True
End Sub

Private Sub Form_Load()
Me.Show
Timer1.Enabled = True
ball.X.X = 1
ball.Y.Y = -1
ball.Z.Z = 1

light.Z = 1
light.X = 0.5
light.Y = -0.2
VectorNormalize light
eye.Z = 1

GetBmpFile App.Path + "\zqh.bmp", Bmp_Bmp
GetBmpFile App.Path + "\Gound.jpg ", Bmp_Gound
 
Me.Picture1.Picture = LoadPicture("zqh.bmp")
'Me.picRay.Picture = LoadPicture("zq5.bmp")

For i = 0 To BmpWidth - 1
  For j = 0 To BmpHeight - 1
    COLtmp(i, j) = Bmp_Bmp(i + 1, j + 1).Red + 256 * CLng(Bmp_Bmp(i + 1, j + 1).Green) + CLng(Bmp_Bmp(i + 1, j + 1).Blue) * 256 * 256
  Next
Next

For i = 0 To BmpWidth - 1
  For j = 0 To BmpHeight - 1
    COLtmpGound(i, j) = Bmp_Gound(i + 1, j + 1).Red + 256 * CLng(Bmp_Gound(i + 1, j + 1).Green) + CLng(Bmp_Gound(i + 1, j + 1).Blue) * 256 * 256
  Next
Next


 
'法线预处理
For i = 0 To 127
  For j = 0 To 127
    Sqrr(i, j).X = i - 63.5
    Sqrr(i, j).Y = j - 63.5
    lng = rao ^ 2 - ((i - 63.5) ^ 2 + (j - 63.5) ^ 2)
    If lng > 0 Then Sqrr(i, j).Z = Sqr(lng)
    VectorNormalize Sqrr(i, j)
  Next
Next


'漫反射
For i = 0 To 127
  For j = 0 To 127
    diff(i, j) = VectorDot(Sqrr(i, j), light)
    If diff(i, j) < 0 Then diff(i, j) = 0
    diff(i, j) = 0.2 + 0.8 * diff(i, j)
    If Sqrr(i, j).Z = 0 Then diff(i, j) = 0.8
  Next
Next
 
calccol
 
'高光
For i = 0 To 127
  For j = 0 To 127
    tmpc = Vectorscale(VectorAdd(eye, light), 0.5)
    VectorNormalize tmpc
    c = VectorDot(Sqrr(i, j), light)
    spe(i, j) = 255 * c ^ 5
    spe(i, j) = spe(i, j) / 2
    If spe(i, j) < 0 Then spe(i, j) = 0
  Next
Next

mai

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Load Me
End
End Sub

Private Sub Timer1_Timer()


Do
  FPS_Count = GetTickCount
  roolball

  For i = 0 To BmpWidth - 1
    For j = 0 To BmpHeight - 1

      If Sqrr(i, j).Z <> 0 Then
        ang = VectorDot(Sqrr(i, j), ball.Z)

        VectorCross Sqrr(i, j), ball.Z, tmp
        VectorNormalize tmp
        ang2 = VectorDot(tmp, ball.X)
        
        ang = Atn(Sqr(1 - ang * ang) / ang)
        If (1 - ang2 ^ 2) > 0 Then ang2 = Atn(Sqr(1 - ang2 * ang2) / ang2)
        If ang2 < 0 Then ang2 = pi + ang2
        If VectorDot(tmp, ball.Y) < 0 Then ang2 = -ang2


        c = ang * 65 * Cos(ang2) + 63.5
        c2 = ang * 65 * Sin(ang2) + 63.5
      
        If c > 2 And c2 > 2 And c < 126 And c2 < 126 Then
          lng = c - Int(c)
          lng2 = c2 - Int(c2)
          T1 = Int(c) + 1
          T2 = Int(c2) + 1

          K1 = (1 - lng) * (1 - lng2)
          K2 = lng * (1 - lng2)
          K3 = (1 - lng) * lng2
          K4 = lng * lng2
            '羽化
          rgbRed = (Bmp_Bmp(T1, T2).Red * K1 + Bmp_Bmp(T1 + 1, T2).Red * K2 + Bmp_Bmp(T1, T2 + 1).Red * K3 + Bmp_Bmp(T1 + 1, T2 + 1).Red * K4)
          rgbGreen = (Bmp_Bmp(T1, T2).Green * K1 + Bmp_Bmp(T1 + 1, T2).Green * K2 + Bmp_Bmp(T1, T2 + 1).Green * K3 + Bmp_Bmp(T1 + 1, T2 + 1).Green * K4)
          rgbBlue = (Bmp_Bmp(T1, T2).Blue * K1 + Bmp_Bmp(T1 + 1, T2).Blue * K2 + Bmp_Bmp(T1, T2 + 1).Blue * K3 + Bmp_Bmp(T1 + 1, T2 + 1).Blue * K4)

          CColor = rgbRed + 256 * CLng(rgbGreen) + CLng(rgbBlue) * 65536 '256^2

          COL(i, j) = CColor ' + CColor2
        Else
          COL(i, j) = COLtmp(0, 0)
        End If

      Else
        COL(i, j) = COLtmpGound(i, j) '地面
      End If

    Next
  Next
  sha

  Do
    If GetTickCount - FPS_Count > 55 Then Exit Do
    DoEvents
  Loop
  DoEvents
Loop

End Sub

Public Sub roolball()
VectorRollz ball.Z, 0.1
VectorRollx ball.Z, 0.05
VectorRolly ball.Z, 0.1

VectorNormalize ball.Z
VectorCross ball.Z, ball.X, tmp
VectorCross tmp, ball.Z, ball.X
VectorNormalize ball.X
VectorCross ball.Z, ball.X, ball.Y
End Sub

Public Sub calccol()

'阴影
Showd1 = Vectorscale(light, 1000)
Showd2 = Vectorscale(Showd1, -1)
lng = VectorLength(Showd2)
For i = 0 To 127
  For j = 0 To 127
    Showd.Z = -rao
    Showd.X = i - 63.5
    Showd.Y = j - 63.5
    VectorSub Showd, Showd1, Showd3
    VectorNormalize Showd3
    c = VectorDot(Showd3, Showd2)
  tmp = Vectorscale(Showd3, c)
    VectorSub tmp, Showd2, tmpc
     c2 = VectorLength(tmpc)
   
    VectorNormalize tmpc
  tmpc = Vectorscale(tmpc, rao)
    VectorSub tmpc, Showd, tmpd
    lng = VectorLength(tmpd)
    VectorNormalize tmpd
    VectorNormalize Showd3
    c = VectorDot(tmpd, Showd3)
   tmpd = Vectorscale(tmpd, c)
    VectorSub Showd3, tmpd, tmp
    lng2 = VectorLength(tmp)
    If c2 < rao And Sqrr(i, j).Z = 0 Then
   
      If lng2 < 0.2 Then
        diff(i, j) = 0.4 + 0.2 - lng2
      Else
        diff(i, j) = 0.4
      End If
   
    Else
   
      If lng2 < 0.2 And Sqrr(i, j).Z = 0 Then diff(i, j) = 0.6 + lng2
   
    End If
  Next
Next

End Sub