frmmain.frm

都是基于VB所做的程序集合,值得大家作为实践的参考资料.

        Super3D1.Layer3Ds.AddDataset SuperWorkspace1.Datasources(strparent).Datasets(strSelected), True
        Super3D1.Refresh
        Super3DLegend1.Refresh
    End If
End Sub

Private Sub mnu_3DScaleZ_Click()
    Dim strscale As String
    strscale = InputBox("", "设置伸缩比率", "")
    If IsNumeric(strscale) Then
        Super3D1.ScaleZ = CLng(strscale)
        Super3D1.Refresh
    End If
End Sub

Private Sub mnu_3DSetting_Click()
    frmSetting.Show vbModal, Me
End Sub

Private Sub mnu_CloseWorkspace_Click()
    Call OnFileCloseWorkspace
End Sub

Private Sub mnu_Flood_Click()
    mnu_Flood.Checked = Not mnu_Flood.Checked
    If mnu_Flood.Checked Then
        Super3D1.FloodEnable = True
        Timer1.Interval = 500
        Timer1.Enabled = True
        fWaterHeight = 0
    Else
        Super3D1.FloodEnable = False
        Timer1.Interval = 0
        Timer1.Enabled = False
        fWaterHeight = 0
        Super3D1.Refresh
    End If
End Sub

Private Sub mnu_OpenWorkspace_Click()
    Dim sFile As String
    
    With cmdOpen
        .DialogTitle = "Open"
        .CancelError = False
        'ToDo: set the flags and attributes of the common dialog control
        .Filter = "All Files (*.smw)|*.smw|(*.sxw)|*.sxw"
        .ShowOpen
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With
    
    Dim objds As soDataSource
    Dim strWorkSpaceName As String
    Dim i As Integer
    
    If Super3D1.Layer3Ds.Count > 0 Then
        Super3D1.Layer3Ds.RemoveAll
        Super3D1.Refresh
    End If
    
    If SuperWorkspace1.Open(sFile, "") = False Then
        MsgBox "打开数据失败", , "错误"
    Else
        TreeViewData.Nodes.Clear
        strWorkSpaceName = PathToName(sFile)
        TreeViewData.Nodes.Add , , "W" + strWorkSpaceName, strWorkSpaceName, 5
        For i = 1 To SuperWorkspace1.Datasources.Count
            Set objds = SuperWorkspace1.Datasources(i)
            OnAddDSToTreeView objds, Me.TreeViewData, strWorkSpaceName
        Next i
        TreeViewData.Nodes(1).Expanded = True
        
        TreeViewMap.Nodes.Clear
        TreeViewMap.Nodes.Add , , "WORKSPACE", strWorkSpaceName, 5
        For i = 1 To SuperWorkspace1.Maps.Count
            TreeViewMap.Nodes.Add "WORKSPACE", tvwChild, , SuperWorkspace1.Maps(i), 46
        Next i
        TreeViewMap.Nodes(1).Expanded = True
    End If
End Sub

Private Sub Super3D1_DragDrop(Source As Control, X As Single, Y As Single)
    If Source.Name = "TreeViewData" Then
        Dim objdt As soDataset
        Dim objdv As soDatasetVector
        Dim objds As soDataSource
        Dim strselect As String, strparent As String
On Error GoTo errorhandle:
        strselect = frmMain.TreeViewData.SelectedItem.Text
        If Not frmMain.TreeViewData.SelectedItem.Parent Is Nothing Then
            strparent = frmMain.TreeViewData.SelectedItem.Parent.Text
            Set objds = frmMain.SuperWorkspace1.Datasources(strparent)
            Set objdt = objds.Datasets(strselect)
            
            If objdt.Vector And objdt.Type <> scdTIN Then '如果是矢量数据集，弹出选择高程窗口
                Set objdv = objdt
                frmAddDataset.InitFields objdv
                frmAddDataset.Show vbModal, Me
                If frmAddDataset.m_bResult Then
                    AddDatasetToSuper3D frmAddDataset.cmbFieldZA.Text, frmAddDataset.cmbFiledZB.Text
                End If
            Else
                Super3D1.Layer3Ds.AddDataset objdt, True
                Super3DLegend1.Refresh
            End If
            
            Super3D1.Refresh
            
            mnu_3D.Enabled = True
        End If
    Else
        If Source.Name = "TreeViewMap" Then
            Call TreeViewMap_DblClick
        End If
    End If
errorhandle:
End Sub

Private Sub Super3D1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim objrc As soRecordset
    Dim i As Integer
    Dim AddItem As ListItem
    If Not Super3D1.selection Is Nothing Then
        If Super3D1.selection.Count < 0 Then
            Set objrc = Super3D1.selection.ToRecordset(False)
            If objrc.RecordCount > 0 Then
                objrc.MoveFirst
                With frmInfo.lvwInfo
                    .ListItems.Clear
                    For i = 1 To objrc.GetFieldInfos.Count
                        Set AddItem = .ListItems.Add(, , objrc.GetFieldInfo(i).Name)
                        AddItem.SubItems(1) = objrc.GetFieldValue(i)
                    Next i
                End With
                frmInfo.Show vbModeless, Me
            End If
        End If
    End If
End Sub

Private Sub Super3DLegend1_Modified()
    Super3D1.Refresh
End Sub

Private Sub Timer1_Timer()
    If fWaterHeight < Super3D1.Layer3Ds(1).Dataset.MaxZ Then
        fWaterHeight = fWaterHeight + (Super3D1.Layer3Ds(1).Dataset.MaxZ - Super3D1.Layer3Ds(1).Dataset.MinZ) / 20
    Else
        fWaterHeight = Super3D1.Layer3Ds(1).Dataset.MaxZ
    End If
    Super3D1.Flood fWaterHeight
    Super3D1.Refresh
End Sub

Private Sub tlbView_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case Button.Index
        Case 1:
            Super3D1.Action = sca3DPointSelect
        Case 2:
            Super3D1.Action = sca3DZoomIn
        Case 3:
            Super3D1.Action = sca3DZoomOut
        Case 4:
            Super3D1.Action = sca3DZoomRectIn
        Case 5:
            Super3D1.Action = sca3DZoomRectOut
        Case 6:
            Super3D1.Action = sca3DZoomFree
        Case 7:
            Super3D1.Action = sca3DPan
        
        Case 9:
            Super3D1.Refresh
    End Select
End Sub

Private Sub TreeViewData_DblClick()
    Dim objdt As soDataset
    Dim objds As soDataSource
    Dim strselect As String, strparent As String
    Dim objdv As soDatasetVector
On Error GoTo errorhandle:
    If TreeViewData.SelectedItem Is Nothing Then Exit Sub
    strselect = TreeViewData.SelectedItem.Text
    If Not TreeViewData.SelectedItem.Parent Is Nothing Then
        If TreeViewData.SelectedItem.Parent.Key <> "WORKSPACE" Then
            strparent = TreeViewData.SelectedItem.Parent.Text
            Set objds = SuperWorkspace1.Datasources(strparent)
            Set objdt = objds.Datasets(strselect)
            Super3D1.Layer3Ds.RemoveAll
            If objdt.Vector And objdt.Type <> scdTIN Then '如果是矢量数据集，弹出选择高程窗口
                Set objdv = objdt
                frmAddDataset.InitFields objdv
                frmAddDataset.Show vbModal, Me
                If frmAddDataset.m_bResult Then
                    AddDatasetToSuper3D frmAddDataset.cmbFieldZA.Text, frmAddDataset.cmbFiledZB.Text
                End If
            Else
                Super3D1.Layer3Ds.AddDataset objdt, True
            End If
            
            Super3D1.Refresh
            Super3DLegend1.Refresh
            
            mnu_3D.Enabled = True
        End If
    End If
errorhandle:
End Sub

Private Sub TreeViewData_DragDrop(Source As Control, X As Single, Y As Single)
    If Not TreeViewData.DropHighlight Is Nothing And m_bDragFlag = True Then
        Set moDragNode.Parent = TreeViewData.DropHighlight
        m_bDragFlag = False
    End If
End Sub

Private Sub TreeViewData_DragOver(Source As Control, X As Single, Y As Single, State As Integer)
    m_bDragFlag = False
End Sub

Private Sub TreeViewData_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Set TreeViewData.DropHighlight = TreeViewData.HitTest(X, Y)
   
    If Not TreeViewData.DropHighlight Is Nothing Then
        If Not TreeViewData.DropHighlight.Parent Is Nothing Then
            If TreeViewData.DropHighlight.Parent.Key <> "WORKSPACE" Then
                m_bDragFlag = True
                TreeViewData.SelectedItem = TreeViewData.HitTest(X, Y)
                Set moDragNode = TreeViewData.SelectedItem ' Set the item being dragged.
            End If
        End If
    End If
    Set TreeViewData.DropHighlight = Nothing
End Sub

Private Sub TreeViewData_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton And m_bDragFlag = True Then
        TreeViewData.DragIcon = TreeViewData.SelectedItem.CreateDragImage
        TreeViewData.Drag vbBeginDrag ' Drag operation.
    End If
End Sub

Private Sub AddDatasetToSuper3D(strFieldZ1 As String, strFieldZ2 As String) '添加数据集到super3d
    Dim objdt As soDataset
    Dim objds As soDataSource
    Dim strselect As String, strparent As String
    Dim objlayer As so3DLayer
On Error GoTo errorhandle:
    strselect = frmMain.TreeViewData.SelectedItem.Text
    If Not frmMain.TreeViewData.SelectedItem.Parent Is Nothing Then
        strparent = frmMain.TreeViewData.SelectedItem.Parent.Text
        Set objds = frmMain.SuperWorkspace1.Datasources(strparent)
        Set objdt = objds.Datasets(strselect)
        
        If Not objdt Is Nothing Then
            Set objlayer = Super3D1.Layer3Ds.AddDataset(objdt, True)
            If strFieldZ1 <> "" Then objlayer.BaseHeightField = strFieldZ1
            If strFieldZ2 <> "" Then objlayer.RelativeHeightField = strFieldZ2
            frmMain.Super3DLegend1.Refresh
        End If
        
    End If
     
errorhandle:
End Sub

Private Sub TreeViewMap_DblClick()
    Dim strselect As String, strparent As String
On Error GoTo errorhandle:
    If TreeViewMap.SelectedItem Is Nothing Then Exit Sub
    strselect = TreeViewMap.SelectedItem.Text
    Super3D1.OpenMap3D strselect
    Dim objlight As New soLight
    If Super3D1.Lights.Count >= 1 Then
        Super3D1.Lights.Remove 1
    End If
    Super3D1.Lights.Add objlight
    Super3D1.Refresh
    Super3DLegend1.Refresh
errorhandle:
End Sub

Private Sub TreeViewMap_DragDrop(Source As Control, X As Single, Y As Single)
    If Not TreeViewMap.DropHighlight Is Nothing And m_bDragFlag = True Then
        Set moDragNode.Parent = TreeViewMap.DropHighlight
        m_bDragFlag = False
    End If
End Sub

Private Sub TreeViewMap_DragOver(Source As Control, X As Single, Y As Single, State As Integer)
    m_bDragFlag = False
End Sub

Private Sub TreeViewMap_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Set TreeViewMap.DropHighlight = TreeViewMap.HitTest(X, Y)
        
    If Not TreeViewMap.DropHighlight Is Nothing Then
        If Not TreeViewMap.DropHighlight.Parent Is Nothing Then
            If TreeViewMap.DropHighlight.Parent.Key = "WORKSPACE" Then
                m_bDragFlag = True
                TreeViewMap.SelectedItem = TreeViewMap.HitTest(X, Y)
                Set moDragNode = TreeViewMap.SelectedItem ' Set the item being dragged.
            End If
        End If
    End If
    
    Set TreeViewMap.DropHighlight = Nothing
End Sub

Private Sub TreeViewMap_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton And m_bDragFlag = True Then
        TreeViewMap.DragIcon = TreeViewMap.SelectedItem.CreateDragImage
        TreeViewMap.Drag vbBeginDrag ' Drag operation.
    End If
End Sub