form1.frm

supermap制图源代码

        cmdRotate.BackColor = RGB(255, 0, 0)
        cmdRotate.Caption = "结束"
        Timer3.Interval = 100
        Timer3.Enabled = True
    Else
        cmdRotate.BackColor = RGB(191, 191, 191)
        cmdRotate.Caption = "旋转"
        Timer3.Interval = 0
        Timer3.Enabled = False
    End If
End Sub

Private Sub Command1_Click()
    If cmd1Flag = True Then
        Super3D1.Connect SuperWorkspace1.Handle
        SuperWorkspace1.Open App.Path + "\Data\Dem.smw"
        Super3D1.OpenMap3D "Dem"
        Super3D1.Refresh
        cmd1Flag = False
        Command1.Caption = "复位"
     Else
        Command1.Caption = "复位"
        Super3D1.RestoreScene
    End If
End Sub

Private Sub Command2_Click()
    Dim filename As String
    Dlg.InitDir = App.Path
    Dlg.Filter = "(*.bmp)|*.bmp"
    Dlg.ShowOpen
    filename = Dlg.filename
    Super3D1.BackGroundTexture = filename
End Sub

Private Sub Command3_Click()
    Dlg.ShowColor
    Super3D1.BackColor = Dlg.Color
    Super3D1.Refresh
End Sub

Private Sub Command4_Click()
    Dim filename As String
    Dlg.InitDir = App.Path
    Dlg.Filter = "(*.jpg)|*.jpg"
    Dlg.ShowOpen
    filename = Dlg.filename
    Super3D1.OutputToFile filename
End Sub

Private Sub Command5_Click()
    End
End Sub

Private Sub Command6_Click()
    If Command6.Caption = "水淹" Then
        Super3D1.FloodEnable = True
        Timer2.Interval = 50
        Timer2.Enabled = True
        Command6.Caption = "停止"
        Command6.BackColor = RGB(255, 0, 0)
    Else
        Super3D1.FloodEnable = False
        Timer2.Interval = 0
        Timer2.Enabled = False
        Command6.Caption = "水淹"
        Command6.BackColor = RGB(191, 191, 191)
        Super3D1.Refresh
    End If
End Sub



Private Sub Command7_Click()
    Super3D1.Zoom 0.8
End Sub

Private Sub Command8_Click()
    Super3D1.Zoom 1.2
End Sub



Private Sub Down_Click()
     Set ViewPoint = Super3D1.FlightControl.ViewPoint
    ViewPoint.z = ViewPoint.z - 50
    Super3D1.Fly ViewPoint, 0, Super3D1.FlightControl.Roll, 0, Super3D1.FlightControl.Heading
    If PFlag = 2 Then
        FlyPathCount = FlyPathCount + 1
        If FlyPathCount > 100 Then
            FlyPathCount = 1
        End If
        
        Set FlyPathViewPoint(FlyPathCount) = Super3D1.FlightControl.ViewPoint
        FlyPathViewRoll(FlyPathCount) = Super3D1.FlightControl.Roll
        FlyPathViewHeading(FlyPathCount) = Super3D1.FlightControl.Heading
                
    End If
End Sub

Private Sub Form_Load()

    '得到每像素对应的Twip值
    dTwipsX = Screen.TwipsPerPixelX
    dTwipsY = Screen.TwipsPerPixelY
    
    mouseDown = False
    MouseFlag = 1
    cmdMouse.Caption = "平移状态"
    PFlag = 1
    Path.Caption = "移动"
    Path.BackColor = RGB(100, 100, 0)
    
    FlyPathCount = 0
    TimerFlyPosition = 0
    
    cmd1Flag = True
    WaterHeight = 1800
End Sub

Private Sub Path_Click()
    PFlag = PFlag + 1
    If PFlag > 3 Then
        PFlag = 1
    End If
    If PFlag = 1 Then
        Path.Caption = "移动"
        Path.BackColor = RGB(100, 100, 0)
        Timer1.Interval = 0
        Timer1.Enabled = False
        TimerFlyPosition = 1
        FlyPathCount = 0
     ElseIf PFlag = 2 Then
        Path.Caption = "录制"
        Path.BackColor = RGB(255, 0, 0)
     ElseIf PFlag = 3 Then
        Path.Caption = "回放"
        Path.BackColor = RGB(0, 255, 0)
        TimerFlyPosition = 1
        Timer1.Interval = 100
        Timer1.Enabled = True
    End If
    
     
End Sub

Private Sub Rolld_Click()
    ViewRoll = Super3D1.FlightControl.Roll + 5
    Super3D1.Fly Super3D1.FlightControl.ViewPoint, 0, ViewRoll, 0, Super3D1.FlightControl.Heading
    If PFlag = 2 Then
        FlyPathCount = FlyPathCount + 1
        If FlyPathCount > 100 Then
            FlyPathCount = 1
        End If
        
        Set FlyPathViewPoint(FlyPathCount) = Super3D1.FlightControl.ViewPoint
        FlyPathViewRoll(FlyPathCount) = Super3D1.FlightControl.Roll
        FlyPathViewHeading(FlyPathCount) = Super3D1.FlightControl.Heading
                
    End If
End Sub

Private Sub Roll_Click()
    ViewRoll = Super3D1.FlightControl.Roll - 5
    Super3D1.Fly Super3D1.FlightControl.ViewPoint, 0, ViewRoll, 0, Super3D1.FlightControl.Heading
    If PFlag = 2 Then
        FlyPathCount = FlyPathCount + 1
        If FlyPathCount > 100 Then
            FlyPathCount = 1
        End If
        
        Set FlyPathViewPoint(FlyPathCount) = Super3D1.FlightControl.ViewPoint
        FlyPathViewRoll(FlyPathCount) = Super3D1.FlightControl.Roll
        FlyPathViewHeading(FlyPathCount) = Super3D1.FlightControl.Heading
                
    End If
End Sub

Private Sub Forward_Click()
    Dim R1 As Single
    Set ViewPoint = Super3D1.FlightControl.ViewPoint
    R1 = Super3D1.FlightControl.Heading * PI / 180#
    ViewPoint.y = Super3D1.FlightControl.ViewPoint.y - Step * Cos(R1)
    ViewPoint.x = Super3D1.FlightControl.ViewPoint.x - Step * Sin(R1)
    Super3D1.Fly ViewPoint, 0, Super3D1.FlightControl.Roll, 0, Super3D1.FlightControl.Heading
    
    If PFlag = 2 Then
        FlyPathCount = FlyPathCount + 1
        If FlyPathCount > 100 Then
            FlyPathCount = 1
        End If
        
        Set FlyPathViewPoint(FlyPathCount) = Super3D1.FlightControl.ViewPoint
        FlyPathViewRoll(FlyPathCount) = Super3D1.FlightControl.Roll
        FlyPathViewHeading(FlyPathCount) = Super3D1.FlightControl.Heading
                
    End If
End Sub

Private Sub Left_Click()
    ViewHeading = Super3D1.FlightControl.Heading - 5#
    Super3D1.Fly Super3D1.FlightControl.ViewPoint, 0, Super3D1.FlightControl.Roll, 0, ViewHeading
    If PFlag = 2 Then
        FlyPathCount = FlyPathCount + 1
        If FlyPathCount > 100 Then
            FlyPathCount = 1
        End If
        
        Set FlyPathViewPoint(FlyPathCount) = Super3D1.FlightControl.ViewPoint
        FlyPathViewRoll(FlyPathCount) = Super3D1.FlightControl.Roll
        FlyPathViewHeading(FlyPathCount) = Super3D1.FlightControl.Heading
                
    End If
End Sub

Private Sub Right_Click()
    ViewHeading = Super3D1.FlightControl.Heading + 5#
    Super3D1.Fly Super3D1.FlightControl.ViewPoint, 0, Super3D1.FlightControl.Roll, 0, ViewHeading
    If PFlag = 2 Then
        FlyPathCount = FlyPathCount + 1
        If FlyPathCount > 100 Then
            FlyPathCount = 1
        End If
        
        Set FlyPathViewPoint(FlyPathCount) = Super3D1.FlightControl.ViewPoint
        FlyPathViewRoll(FlyPathCount) = Super3D1.FlightControl.Roll
        FlyPathViewHeading(FlyPathCount) = Super3D1.FlightControl.Heading
                
    End If
End Sub

Private Sub Super3D1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    XStart = x / dTwipsX
    YStart = y / dTwipsY
    mouseDown = True
    Dim pnt3D As soPoint3D
  
    If MouseFlag = 3 Then
        Set pnt3D = Super3D1.HitTest(XStart, YStart)
        If pnt3D Is Nothing Then
            MsgBox "鼠标位置超过三维模型空间范围"
            Exit Sub
        End If
        Dim s As String
        s = "X="
        s = s + Str(pnt3D.x)
        s = s + vbCrLf
        s = s + "Y="
        s = s + Str(pnt3D.y)
        s = s + vbCrLf
        s = s + "Z="
        s = s + Str(pnt3D.z)
        MsgBox s
    End If
    
End Sub

Private Sub Super3D1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
   Dim XEnd As Single, YEnd As Single
   
   If mouseDown = True Then
        XEnd = x / dTwipsX
        YEnd = y / dTwipsY
   
        If MouseFlag = 1 Then
            Super3D1.Pan XEnd - XStart, YEnd - YStart
        ElseIf MouseFlag = 2 Then
            Super3D1.Zoom YStart / YEnd
        End If
        XStart = XEnd
        YStart = YEnd
   End If
End Sub

Private Sub Super3D1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    mouseDown = False
End Sub

Private Sub Timer1_Timer()
    TimerFlyPosition = TimerFlyPosition + 1
    If TimerFlyPosition > FlyPathCount Then
        TimerFlyPosition = 1
    End If
    Super3D1.Fly FlyPathViewPoint(TimerFlyPosition), 0, FlyPathViewRoll(TimerFlyPosition), 0, FlyPathViewHeading(TimerFlyPosition)
End Sub

Private Sub Timer2_Timer()
    If WaterHeight < Super3D1.Layers(1).Dataset.MaxZ Then
        WaterHeight = WaterHeight + 50
    Else
        WaterHeight = 1800
    End If
    Super3D1.Flood WaterHeight
End Sub

Private Sub Timer3_Timer()
    Super3D1.Rotate 5, 1, 0, 0
End Sub

Private Sub Up_Click()
    Set ViewPoint = Super3D1.FlightControl.ViewPoint
    ViewPoint.z = ViewPoint.z + 50
    Super3D1.Fly ViewPoint, 0, Super3D1.FlightControl.Roll, 0, Super3D1.FlightControl.Heading
    If PFlag = 2 Then
        FlyPathCount = FlyPathCount + 1
        If FlyPathCount > 100 Then
            FlyPathCount = 1
        End If
        
        Set FlyPathViewPoint(FlyPathCount) = Super3D1.FlightControl.ViewPoint
        FlyPathViewRoll(FlyPathCount) = Super3D1.FlightControl.Roll
        FlyPathViewHeading(FlyPathCount) = Super3D1.FlightControl.Heading
                
    End If
End Sub