frmfront.frm

游戏《家园》源码

        'Set key press flag
        bPress = True
    
        'Set level-of-detail to low
        SetDetail (1)
        
        'Update status bar
        sbStatusBar.Panels.Item(1).Text = "View Origin: x" + Format(-aOffset(0) / fViewScale, " 0; -#") + " y" + Format(-aOffset(1) / fViewScale, " 0; -#") + " z" + Format(-aOffset(2) / fViewScale, " 0; -#") + " m"
        
        'Set view
        SetView (True)
    End If
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
    Dim fScale As Single
    
    If KeyAscii = 13 Then KeyAscii = 0
    
    'Set scale
    fScale = fViewScale
    
    'Check key state
    If KeyAscii = Asc("-") Then
        fViewScale = fViewScale * (1 - 0.05)
        If fViewScale < 0.0001 Then fViewScale = 0.0001
    End If
        
    'Check key state
    If KeyAscii = Asc("+") Then
        fViewScale = fViewScale * (1 + 0.05)
    End If
        
    'Check key state
    If (KeyAscii = Asc("-")) Or (KeyAscii = Asc("+")) Then
        'Set key press flag
        bPress = True
    
        'Set level-of-detail to low
        SetDetail (1)
        
        'Remove scale effect from offset
        aOffset(2) = aOffset(2) * fViewScale / fScale
        aOffset(1) = aOffset(1) * fViewScale / fScale
    
        'Update status bar
        sbStatusBar.Panels.Item(1).Text = "View Scale:" + Format(1 / fViewScale, " 0%; -#%")
                
        'Set view and scale
        SetView (False)
        SetScale (True)
    End If
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    If bPress = True Then
        'Set level-of-detail to high
        SetDetail (0)
        
        'Refresh
        Render
        
        'Set view and scale
        frmTop.SetView (False)
        frmTop.SetScale (True)
        frmSide.SetView (False)
        frmSide.SetScale (True)
        
        'Show options
        frmOptions.ShowOptions
        
        'Clear key press flag
        bPress = False
    End If
End Sub

Private Sub pbViewPort_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim nObj As Long
    
    Dim fX As Single
    Dim fY As Single
    Dim fZ As Single
    Dim aBand(4) As Single
       
    'Set mouse down flag
    bClick = True
    
    'Set mouse and key
    nButton = Button
    nShift = Shift
    
    'Set mouse coordinates
    fMx = X
    fMy = Y
    fRx = X
    fRy = Y
    
    'Reset angle
    fAng = 0
    
    'Check mouse and key state
    If nButton = 1 And (nShift = 0 Or nShift = 2) Then
        'Get band box coordinates
        aBand(0) = X / fConvScale
        aBand(1) = Y / fConvScale
        aBand(2) = X / fConvScale
        aBand(3) = Y / fConvScale
            
        'Set band box
        Call rendSetContBand(nContext, aBand(0), nBandCol)
        Exit Sub
    End If
    
    'Check mouse and key state
    If nButton = 1 And nShift = 1 Then
        'Update status bar
        sbStatusBar.Panels.Item(1).Text = "View Origin: x" + Format(-aOffset(0) / fViewScale, " 0; -#") + " y" + Format(-aOffset(1) / fViewScale, " 0; -#") + " z" + Format(-aOffset(2) / fViewScale, " 0; -#") + " m"
        Exit Sub
    End If
    
    'Check mouse and key state
    If nButton = 2 And nShift = 2 Then
        'Get selection
        Call rendCheckContCamera(nContext, X / fConvScale, Y / fConvScale, nSel)
        Exit Sub
    End If
            
    'Check mouse and key state
    If nButton = 1 And nShift = 4 Then
        'Find object
        Call rendFindObj(nObj, Val(Mid(sCurKey, 2)))
        Call rendGetObjTrans(nObj, fX, fY, fZ)
        
        'Update status bar
        sbStatusBar.Panels.Item(1).Text = "Object Position: x" + Format(fX, " 0; -#") + " y" + Format(fY, " 0; -#") + " z" + Format(fZ, " 0; -#") + " m"
        Exit Sub
    End If
    
    'Check mouse and key state
    If nButton = 2 And nShift = 4 Then
        'Set level-of-detail to low
        SetDetail (1)
        
        'Find object
        Call rendFindObj(nObj, Val(Mid(sCurKey, 2)))
        Call rendGetObjRot(nObj, fX, fY, fZ)
        
        'Check key
        If InStr(sListKey, " ") = 0 Then
            'Set context rotation
            Call rendSetContRot(nContext, nObj, nRotCol)
        End If
           
        'Update status bar
        sbStatusBar.Panels.Item(1).Text = "Object Rotation: x" + Format(fX, " 0; -#") + " y" + Format(fY, " 0; -#") + " z" + Format(fZ, " 0; -#") + " deg"
       
        'Refresh
        Render
        
        'Set context rotation
        Call rendSetContRot(nContext, 0, nRotCol)
        
        'Set level-of-detail to high
        SetDetail (0)
    End If
End Sub

Private Sub pbViewPort_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim nObj As Long
    
    Dim fS As Single
    Dim fX As Single
    Dim fY As Single
    Dim fZ As Single
    Dim fA As Single
    Dim fDist As Single
    Dim aBand(4) As Single
    
    'Check mouse down flag
    If bClick = True Then
        If nButton <> Button Or nShift <> Shift Then
            Call pbViewPort_MouseUp(nButton, nShift, X, Y)
            Call pbViewPort_MouseDown(Button, Shift, X, Y)
            Exit Sub
        End If
    
        'Set level-of-detail to low
        SetDetail (1)
        frmCamera.SetDetail (1)
        frmSide.SetDetail (1)
        frmTop.SetDetail (1)
        
        'Check mouse and key state
        If nButton = 1 And (nShift = 0 Or nShift = 2) Then
            'Get band box coordinates
            aBand(0) = fRx / fConvScale
            aBand(1) = fRy / fConvScale
            aBand(2) = X / fConvScale
            aBand(3) = Y / fConvScale
            
            'Set band box
            Call rendSetContBand(nContext, aBand(0), nBandCol)
            
            'Calculate distance
            fDist = Sqr((aBand(0) - aBand(2)) * (aBand(0) - aBand(2)) + (aBand(1) - aBand(3)) * (aBand(1) - aBand(3)))
            
            'Update status bar
            sbStatusBar.Panels.Item(1).Text = "Distance:" + Format(fDist / fViewScale, " 0; -#") + " m"
           
           'Refresh form
            Render
        End If
        
        'Check mouse and key state
        If nButton = 1 And nShift = 1 Then
            'Set offset
            aOffset(2) = aOffset(2) + (fMx - X) / fConvScale
            aOffset(1) = aOffset(1) + (fMy - Y) / fConvScale
            
            'Update status bar
            sbStatusBar.Panels.Item(1).Text = "View Origin: x" + Format(-aOffset(0) / fViewScale, " 0; -#") + " y" + Format(-aOffset(1) / fViewScale, " 0; -#") + " z" + Format(-aOffset(2) / fViewScale, " 0; -#") + " m"
            
            'Set view
            SetView (True)
        End If
        
        'Check mouse and key state
        If nButton = 3 And nShift = 1 Then
            'Remove scale effect from offset
            aOffset(2) = aOffset(2) / fViewScale
            aOffset(1) = aOffset(1) / fViewScale
        
            'Set scale
            If Abs(fMx - X) > Abs(fMy - Y) Then
                fViewScale = fViewScale * (1 + (fMx - X) / (fConvScale * 200))
            Else
                fViewScale = fViewScale * (1 + (fMy - Y) / (fConvScale * 200))
            End If
            If fViewScale < 0.0001 Then fViewScale = 0.0001
        
            'Add scale effect to offset
            aOffset(2) = aOffset(2) * fViewScale
            aOffset(1) = aOffset(1) * fViewScale
            
            'Update status bar
            sbStatusBar.Panels.Item(1).Text = "View Scale:" + Format(1 / fViewScale, " 0%; -#%")
                    
            'Set view and scale
            SetView (False)
            SetScale (True)
        End If
        
        'Check mouse and key state
        If nButton = 2 And nShift = 2 Then
            'Check camera flag
            If bCamFlag = 1 Then
                'Check selection
                If nSel = 1 Then
                    aEye(1) = aEye(1) + (fMy - Y) / (fConvScale * fViewScale)
                    aEye(2) = aEye(2) + (fMx - X) / (fConvScale * fViewScale)
                End If
                
                'Check selection
                If nSel = 2 Then
                    aFocus(1) = aFocus(1) + (fMy - Y) / (fConvScale * fViewScale)
                    aFocus(2) = aFocus(2) + (fMx - X) / (fConvScale * fViewScale)
                End If
            Else
                'Check selection
                If nSel <> 0 Then
                    aEye(1) = aEye(1) + (fMy - Y) / (fConvScale * fViewScale)
                    aEye(2) = aEye(2) + (fMx - X) / (fConvScale * fViewScale)
                    aFocus(1) = aFocus(1) + (fMy - Y) / (fConvScale * fViewScale)
                    aFocus(2) = aFocus(2) + (fMx - X) / (fConvScale * fViewScale)
                End If
            End If
            
            'Refresh
            SetCamera (True)
            frmCamera.SetCamera (False)
        End If
        
        'Check mouse and key state
        If nButton = 1 And nShift = 4 Then
            'Translate object
            Call rendTransSel(0, (fMy - Y) / (fConvScale * fViewScale), (fMx - X) / (fConvScale * fViewScale))
            
            'Find object
            Call rendFindObj(nObj, Val(Mid(sCurKey, 2)))
            Call rendGetObjTrans(nObj, fX, fY, fZ)
            
            'Update status bar
            sbStatusBar.Panels.Item(1).Text = "Object Position: x" + Format(fX, " 0; -#") + " y" + Format(fY, " 0; -#") + " z" + Format(fZ, " 0; -#") + " m"
           
            'Refresh
            Render
            frmCamera.Render
            frmSide.Render
            frmTop.Render
        End If
        
        'Check mouse and key state
        If nButton = 2 And nShift = 4 Then
            'Rotate object
            If Abs(fMx - X) > Abs(fMy - Y) Then
                'Calc angle
                fA = (X - fMx) / fConvScale
            Else
                'Calc angle
                fA = (fMy - Y) / fConvScale
            End If
                      
            'Get absolute angle
            fAng = fAng + fA
            
            'Check key
            If InStr(sListKey, " ") = 0 Then
                'Rotate selection
                Call rendRotSel(0, fA, 0, 0)
                
                'Find object
                Call rendFindObj(nObj, Val(Mid(sCurKey, 2)))
                
                'Set context rotation
                Call rendSetContRot(nContext, nObj, nRotCol)
            Else
                'Rotate selection
                Call rendRotSel(nContext, fA, 0, 0)
            End If
                
            'Update status bar
            sbStatusBar.Panels.Item(1).Text = "Object Rotation: x" + Format(fAng, " 0; -#") + " y" + " 0" + " z" + " 0" + " deg"
                  
            'Refresh
            Render
            frmCamera.Render
            frmSide.Render
            frmTop.Render
            
            'Set context rotation
            Call rendSetContRot(nContext, 0, nRotCol)
        End If
        
        'Check mouse and key state
        If nButton = 3 And nShift = 4 Then
            'Check mouse coordinates
            If Abs(fMx - X) > Abs(fMy - Y) Then
                'Calc scale
                fS = 1 + (X - fMx) / (fConvScale * 200)
            Else
                'Calc scale
                fS = 1 + (fMy - Y) / (fConvScale * 200)
            End If
           
            'Scale selection
            If bScaleFlag = 1 Then
                Call rendScaleSel(1, fS, 1)
            Else
                Call rendScaleSel(fS, fS, fS)
            End If