frmtop.frm

游戏《家园》源码

VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "Comctl32.ocx"
Begin VB.Form frmTop 
   BackColor       =   &H80000008&
   Caption         =   "Top View"
   ClientHeight    =   3204
   ClientLeft      =   60
   ClientTop       =   348
   ClientWidth     =   4716
   FillColor       =   &H80000008&
   FontTransparent =   0   'False
   Icon            =   "frmTop.frx":0000
   KeyPreview      =   -1  'True
   MDIChild        =   -1  'True
   MinButton       =   0   'False
   ScaleHeight     =   3204
   ScaleWidth      =   4716
   Begin VB.PictureBox pbViewPort 
      BackColor       =   &H80000007&
      BorderStyle     =   0  'None
      ClipControls    =   0   'False
      HasDC           =   0   'False
      Height          =   2775
      Left            =   60
      MousePointer    =   2  'Cross
      ScaleHeight     =   2772
      ScaleWidth      =   4572
      TabIndex        =   1
      Top             =   60
      Width           =   4575
   End
   Begin ComctlLib.StatusBar sbStatusBar 
      Align           =   2  'Align Bottom
      Height          =   276
      Left            =   0
      TabIndex        =   0
      Top             =   2928
      Width           =   4716
      _ExtentX        =   8319
      _ExtentY        =   487
      SimpleText      =   ""
      _Version        =   327682
      BeginProperty Panels {0713E89E-850A-101B-AFC0-4210102A8DA7} 
         NumPanels       =   1
         BeginProperty Panel1 {0713E89F-850A-101B-AFC0-4210102A8DA7} 
            AutoSize        =   1
            Object.Width           =   7916
            Text            =   "Cursor: 0 0 0 m"
            TextSave        =   "Cursor: 0 0 0 m"
            Object.Tag             =   ""
         EndProperty
      EndProperty
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "MS Sans Serif"
         Size            =   7.8
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
End
Attribute VB_Name = "frmTop"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim bClick As Boolean
Dim bPress As Boolean

Dim nButton As Integer
Dim nShift As Integer

Dim fMx As Single
Dim fMy As Single

Dim fRx As Single
Dim fRy As Single

Dim fAng As Single

Dim aPos(4) As Single

Dim nContext As Long
Dim nSel As Long

Sub Render()
    'Check flag
    If fMainForm.mnuViewGraphTop.Checked Then Call rendUpdateCont(nContext)
End Sub

Sub SetDetail(ByVal nDetail As Integer)
    'Set level-of-detail
    Call rendSetContDetail(nContext, nDetail)
End Sub

Sub SetSel(ByVal bFlag As Boolean)
    'Check flag
    If Not fMainForm.mnuViewGraphTop.Checked Then Exit Sub
    
    'Set selection color
    Call rendSetContSel(nContext, nSelCol)
    
    'Refresh
    If bFlag = True Then Render
End Sub
    
Sub SetGrid(ByVal bFlag As Boolean)
    'Check flag
    If Not fMainForm.mnuViewGraphTop.Checked Then Exit Sub
    
    'Set grid size and color
    Call rendSetContGrid(nContext, fGridSize, nGridCol)
    
    'Refresh
    If bFlag = True Then Render
End Sub

Sub SetCursor(ByVal bFlag As Boolean)
    'Check flag
    If Not fMainForm.mnuViewGraphTop.Checked Then Exit Sub
    
    'Set cursor and color
    Call rendSetContCursor(nContext, aCursor(0), nCursCol)
    
    'Refresh
    If bFlag = True Then Render
End Sub

Sub SetScale(ByVal bFlag As Boolean)
    'Check flag
    If Not fMainForm.mnuViewGraphTop.Checked Then Exit Sub
    
    'Set scale
    Call rendSetContScale(nContext, fViewScale)
    
    'Refresh
    If bFlag = True Then Render
End Sub
    
Sub SetView(ByVal bFlag As Boolean)
    'Check flag
    If Not fMainForm.mnuViewGraphTop.Checked Then Exit Sub
    
    'Set view
    Call rendSetContView(nContext, (-pbViewPort.Width / (fConvScale * 2)) + aOffset(2), (-pbViewPort.Height / (fConvScale * 2)) + aOffset(0), pbViewPort.Width / fConvScale, pbViewPort.Height / fConvScale)
    
    'Refresh
    If bFlag = True Then Render
End Sub
    
Sub SetCamera(ByVal bFlag As Boolean)
    'Check flag
    If Not fMainForm.mnuViewGraphTop.Checked Then Exit Sub
    
    'Set camera eye, focus and color
    Call rendSetContCamera(nContext, aEye(0), aFocus(0), nCamCol)
    Call rendGetContCamera(nContext, aEye(0), aFocus(0))
    
    'Refresh
    If bFlag = True Then Render
End Sub
    
Sub Reset()
    Dim aP(4) As Single
    
    'Set top view position and size
    aP(0) = fMainForm.ScaleWidth / 4
    aP(1) = 0
    aP(2) = 3 * fMainForm.ScaleWidth / 8
    aP(3) = fMainForm.ScaleHeight / 2
    
    'Move form
    On Error Resume Next
    Me.WindowState = vbNormal
    Call Me.Move(aP(0), aP(1), aP(2), aP(3))
    On Error GoTo 0
End Sub
    
Private Sub Form_Load()
    Dim n As Integer
    Dim nCount As Integer
    
    Dim nPos As Long
        
    Dim fSize As Single
    
    Dim sList As String
    
    'Clear key press flag
    bPress = False
    
    'Create new context
    If rendNewCont(nContext, pbViewPort.hWnd, 2) < 0 Then Call MsgBox("DLL error: Unable to create context!", vbOKOnly Or vbExclamation, "MissionMan")
    
    'Set selection color
    Call rendSetContSel(nContext, nSelCol)
    
    'Set grid size and color
    Call rendSetContGrid(nContext, fGridSize, nGridCol)
    
    'Set cursor and color
    Call rendSetContCursor(nContext, aCursor(0), nCursCol)
    
    'Set scale
    Call rendSetContScale(nContext, fViewScale)
    
    'Set camera eye, focus and color
    Call rendSetContCamera(nContext, aEye(0), aFocus(0), nCamCol)
    Call rendGetContCamera(nContext, aEye(0), aFocus(0))
    
    'Set top view position and size
    aPos(0) = fMainForm.ScaleWidth / 4
    aPos(1) = 0
    aPos(2) = 3 * fMainForm.ScaleWidth / 8
    aPos(3) = fMainForm.ScaleHeight / 2
    
    'Reset count
    nCount = 0
    
    'Get window
    Call misGetListByKey(MIS_SEC_COM, MIS_KEY_TOPV, sList, nCount, MIS_MOD_INI)
    
    'Check count
    If nCount > 0 Then
        'Truncate list
        sList = TruncStr(sList)

        'Loop thru list
        For n = 0 To 3
            'Get position of | character in string
            nPos = InStr(sList, "|")
        
            'If possible, truncate string at | character
            If nPos > 0 Then
                'Set position
                aPos(n) = Val(Left(sList, nPos - 1)) * fConvScale
                sList = Mid(sList, nPos + 1, Len(sList))
            Else
                'Set position
                aPos(n) = Val(sList) * fConvScale
            End If
        Next n
    End If
    
    'Initialize form
    On Error Resume Next
    Call Me.Move(aPos(0), aPos(1), aPos(2), aPos(3))
    On Error GoTo 0
    fMainForm.mnuViewGraphTop.Checked = True
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim n As Integer
    
    Dim sList As String
    
    'Delete context
    Call rendDelCont(nContext)
    
    'Cleanup form
    fMainForm.mnuViewGraphTop.Checked = False
    
    'Check position
    If aPos(0) = Me.Left And aPos(1) = Me.Top And aPos(2) = Me.Width And aPos(3) = Me.Height Then Exit Sub
    
    'Set position
    aPos(0) = Me.Left
    aPos(1) = Me.Top
    aPos(2) = Me.Width
    aPos(3) = Me.Height
    
    'Reset list
    sList = ""
    For n = 0 To 3
        'Append list
        sList = sList + "|" + Format(aPos(n) / fConvScale, "0.0;-0.0")
    Next n
    
    'Put window
    Call misPutListByKey(MIS_SEC_COM, MIS_KEY_TOPV, sList, MIS_MOD_INI)
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim nCount As Integer
    Dim aBand(4) As Single
    Dim nList As String
    
    If KeyCode = vbKeyReturn Then
        'Check copy key
        If InStr(sListKey, " ") > 0 Then
            'Show selection property
            fMainForm.GetListProp
            Exit Sub
        End If
        
        ' Check node key
        If Left(sCurKey, 1) = "o" Then
            'Show form
            frmObjects.Show
            Call frmObjects.GetObject(sParKey, sCurKey, 0, 0, 0)
            frmObjects.SetFocus
            Exit Sub
        End If
    End If
    
    If KeyCode = vbKeyDelete Then
        'Commit
        Call CommitDB("Delete")
            
        'Delete item(s)
        Call fMainForm.DelList(sParKey, sListKey, "")
        Exit Sub
    End If
    
    If KeyCode = vbKeyEscape Then
        If bClick = True And nButton = 1 And (nShift = 0 Or nShift = 2) Then
            'Reset mouse down flag
            bClick = False
        
            'Reset band box coordinates
            aBand(0) = 0
            aBand(1) = 0
            aBand(2) = 0
            aBand(3) = 0
            
            'Set band box
            Call rendSetContBand(nContext, aBand(0), nBandCol)
            
            'Refresh
            Render
        End If
        Exit Sub
    End If
    
    If KeyCode = vbKeyUp Then
        'Set offset
        aOffset(0) = aOffset(0) + 10
    End If
        
    If KeyCode = vbKeyDown Then
        'Set offset
        aOffset(0) = aOffset(0) - 10
    End If
        
    If KeyCode = vbKeyLeft Then
        'Set offset
        aOffset(2) = aOffset(2) + 10
    End If
        
    If KeyCode = vbKeyRight Then
        'Set offset
        aOffset(2) = aOffset(2) - 10
    End If
        
    If KeyCode = vbKeyUp Or KeyCode = vbKeyDown Or KeyCode = vbKeyLeft Or KeyCode = vbKeyRight Then
        'Set key press flag