frmmain.frm

超图网络分析扩展的VB开发程序的应用,对地理信息系统开发有益

Private Sub mnuHydrologyFlowDirection_Click() '流向分析
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    bActiveFrm = False
    IniComboBox frmHdroFlowDirect.cmbDsList
    IniComboBox frmHdroFlowDirect.cmbDsListResult
    frmHdroFlowDirect.Show vbModal, Me
End Sub

Private Sub mnuHydrologyFlowLength_Click() '坡长分析
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    bActiveFrm = False
    IniComboBox frmHdroFlowLength.cmbDsList
    IniComboBox frmHdroFlowLength.cmbDsListTog
    IniComboBox frmHdroFlowLength.cmbDsListResult
    frmHdroFlowLength.Show vbModal, Me
End Sub

Private Sub mnuHydrologySink_Click() '计算伪洼地
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    bActiveFrm = False
    IniComboBox frmHdroSink.cmbDsList
    IniComboBox frmHdroSink.cmbDsListResult
    frmHdroSink.Show vbModal, Me
End Sub

Private Sub mnuHydrologyBasin_Click() '流域盆地分析
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    bActiveFrm = False
    IniComboBox frmHdroBasin.cmbDsList
    IniComboBox frmHdroBasin.cmbDsListResult
    frmHdroBasin.Show vbModal, Me
End Sub

Private Sub mnuMapPan_Click() '漫游
    If SuperMap.Layers.Count < 1 Then Exit Sub
    SuperMap.Action = scaPan
End Sub

Private Sub mnuMapSel_Click() '选择
    If SuperMap.Layers.Count < 1 Then Exit Sub
    SuperMap.Action = scaSelect
End Sub

Private Sub mnuMapViewEn_Click() '全幅
    If SuperMap.Layers.Count < 1 Then Exit Sub
    SuperMap.ViewEntire
    SuperMap.Refresh
End Sub

Private Sub mnuMapZoomF_Click() '自由缩放
    If SuperMap.Layers.Count < 1 Then Exit Sub
    SuperMap.Action = scaZoomFree
End Sub

Private Sub mnuMapZoomIn_Click() '放大
    If SuperMap.Layers.Count < 1 Then Exit Sub
    SuperMap.Action = scaZoomIn
End Sub

Private Sub mnuMapZoomOut_Click() '缩小
    If SuperMap.Layers.Count < 1 Then Exit Sub
    SuperMap.Action = scaZoomOut
End Sub

Private Sub mnuMathDivide_Click() '除法运算
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    bActiveFrm = False
    IniComboBox frmMath.cmbDsList1
    IniComboBox frmMath.cmbDsList2
    IniComboBox frmMath.cmbDsListResult
    frmMath.iMathMod = 4
    frmMath.Show vbModal, Me
End Sub

Private Sub mnuMathExcute_Click() '表达式
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    IniComboBox frmMathExcute.cmbDsListResult
    frmMathExcute.Show vbModal, Me
End Sub

Private Sub mnuMathFloat_Click() '转为浮点
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    bActiveFrm = False
    IniComboBox frmGrid2FltInt.cmbDsList
    IniComboBox frmGrid2FltInt.cmbDsListResult
    frmGrid2FltInt.iChangeType = 2
    frmGrid2FltInt.Show vbModal, Me
End Sub

Private Sub mnuMathInt_Click() '转为整型
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    bActiveFrm = False
    IniComboBox frmGrid2FltInt.cmbDsList
    IniComboBox frmGrid2FltInt.cmbDsListResult
    frmGrid2FltInt.iChangeType = 1
    frmGrid2FltInt.Show vbModal, Me
End Sub

Private Sub mnuMathMinus_Click() '减法运算
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    bActiveFrm = False
    IniComboBox frmMath.cmbDsList1
    IniComboBox frmMath.cmbDsList2
    IniComboBox frmMath.cmbDsListResult
    frmMath.iMathMod = 2
    frmMath.Show vbModal, Me
End Sub

Private Sub mnuMathPlus_Click() '加法运算
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    bActiveFrm = False
    IniComboBox frmMath.cmbDsList1
    IniComboBox frmMath.cmbDsList2
    IniComboBox frmMath.cmbDsListResult
    frmMath.iMathMod = 1
    frmMath.Show vbModal, Me
End Sub

Private Sub mnuMathTimes_Click() '乘法运算
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    bActiveFrm = False
    IniComboBox frmMath.cmbDsList1
    IniComboBox frmMath.cmbDsList2
    IniComboBox frmMath.cmbDsListResult
    frmMath.iMathMod = 3
    frmMath.Show vbModal, Me
End Sub

Private Sub mnuSetEnvionment_Click() '分析环境设置
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    bActiveFrm = False
    IniComboBox frmAnalystEnvionment.cmbDsList
    frmAnalystEnvionment.cmbBounds.Clear
    frmAnalystEnvionment.cmbBounds.AddItem "分析数据的范围交集"
    frmAnalystEnvionment.cmbBounds.AddItem "分析数据的范围并集"
    frmAnalystEnvionment.cmbCell.Clear
    frmAnalystEnvionment.cmbCell.AddItem "分析数据的最小分辨率"
    frmAnalystEnvionment.cmbCell.AddItem "分析数据的最大分辨率"
    frmAnalystEnvionment.Show vbModal, Me
End Sub

Private Sub mnuStatisticCom_Click() '常规分析
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    bActiveFrm = False
    IniComboBox frmStatisticCom.cmbDsList1
    IniComboBox frmStatisticCom.cmbDsList2
    IniComboBox frmStatisticCom.cmbDsListResult
    frmStatisticCom.Show vbModal, Me
End Sub

Private Sub mnuStatisticNeighbour_Click() '领域分析
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    bActiveFrm = False
    IniComboBox frmStatisticNeighbour.cmbDsList
    IniComboBox frmStatisticNeighbour.cmbDsListResult
    frmStatisticNeighbour.Show vbModal, Me
End Sub

Private Sub mnuSurfaceAspect_Click() '坡向图
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    bActiveFrm = False
    IniComboBox frmSurfaceAspect.cmbDsList
    IniComboBox frmSurfaceAspect.cmbDsListResult
    frmSurfaceAspect.Show vbModal, Me
End Sub

Private Sub mnuSurfaceIsoLine_Click() '构建所有等值线
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    bActiveFrm = False
    IniComboBox frmSurfaceIsoLine.cmbDsList
    IniComboBox frmSurfaceIsoLine.cmbDsListResult
    frmSurfaceIsoLine.Show vbModal, Me
End Sub

Private Sub mnuSurfaceIsolineByPoint_Click() '定位生成等值线
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    If SuperMap.Layers.Count < 1 Then
        MsgBox "请在地图窗口打开栅格数据集", vbInformation, "信息提示"
        Exit Sub
    End If
    SuperMap.Action = scaTrackPoint
End Sub

Private Sub mnuSurfaceIsolineByValue_Click() '定值生成等值线
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    bActiveFrm = False
    IniComboBox frmSurfaceILByValue.cmbDsList
    frmSurfaceILByValue.Show vbModal, Me
End Sub

Private Sub mnuSurfaceSlope_Click() '坡度图
    If SuperWorkspace.Datasources.Count < 1 Then Exit Sub
    bActiveFrm = False
    IniComboBox frmSurfaceSlope.cmbDsList
    IniComboBox frmSurfaceSlope.cmbDsListResult
    frmSurfaceSlope.Show vbModal, Me
End Sub

'自定义函数,将文件全路径名转化为文件名(无路径名,无扩展名)
Public Function PathToName(ByVal strPath As String) As String
    Dim nLength As Integer      '字符串长度
    Dim i As Integer
    Dim strTemp As String
    Dim strTemp1 As String
    Dim nPosition As Integer
    
    nPosition = 999
    If InStr(strPath, ".") <> 0 Then
        strTemp = Left(strPath, Len(strPath) - 4)
    Else
        strTemp = strPath
    End If
    
    nLength = Len(strTemp)
    For i = Len(strPath) To 1 Step -1
        If Mid$(strTemp, i, 1) = "\" Then
            nPosition = i
            Exit For
        End If
    Next
    If nPosition = 999 Then
        PathToName = strTemp
    Else
        PathToName = Right(strTemp, nLength - nPosition)
    End If
End Function


Private Sub SuperLegend_Modified()
    SuperMap.Refresh
End Sub

Private Sub SuperMap_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If SuperMap.Layers.Count > 0 Then
        If Button = 2 Then
            PopupMenu mnuMap
        End If
    End If
End Sub

Private Sub SuperMap_Tracked()
    Dim objGp As soGeoPoint
    Dim objDt As soDataset
    Dim objDtRst As soDatasetRaster
    Dim objGeoLine As soGeoLine
    Dim objRect As soRect
    Dim objStyle As New soStyle
    Dim objPt As New soPoint
    Dim dx As Double
    Dim dy As Double
    Dim objSurfaceAnalyst As soSurfaceAnalyst
    Dim objSurfaceOperator As soSurfaceOperator
    Dim objError As New soError
    
    SuperMap.Action = scaSelect
    Set objDt = SuperMap.Layers(1).Dataset
    If objDt.Type = scdDEM Or objDt.Type = scdGrid Then
        Set objDtRst = objDt
        Set objGp = SuperMap.TrackedGeometry
        Set objRect = objDtRst.Bounds
        dx = objGp.x
        dy = objGp.y
        If dx > objRect.Right Or dx < objRect.Left Or dy > objRect.Top Or dy < objRect.Bottom Then
            MsgBox "所点击位置超出数据集范围。", vbInformation, "信息提示"
        Else
            Set objSurfaceAnalyst = SuperAnalyst.SurfaceAnalyst
            Set objSurfaceOperator = objSurfaceAnalyst.Surface
            Set objSurfaceAnalyst.AnalysisEnvionment = objAnalystEnvmnt
            
            objPt.x = objGp.x
            objPt.y = objGp.y
            
            Set objGeoLine = objSurfaceOperator.IsolineByPoint(objDtRst, objPt, 2)
            If Not objGeoLine Is Nothing Then
                objStyle.PenColor = vbRed
                objStyle.PenWidth = 15
                SuperMap.TrackingLayer.ClearEvents
                SuperMap.TrackingLayer.AddEvent objGeoLine, objStyle, ""
                SuperMap.TrackingLayer.Refresh
            Else
                MsgBox "生成等值线失败" & vbCrLf & objError.LastErrorMsg, vbInformation, "信息提示"
            End If
        End If
    End If
    
    Set objError = Nothing
    Set objStyle = Nothing
    Set objRect = Nothing
    Set objPt = Nothing
    Set objGp = Nothing
    Set objGeoLine = Nothing
    Set objDtRst = Nothing
    Set objDt = Nothing
    Set objSurfaceAnalyst = Nothing
    Set objSurfaceOperator = Nothing
End Sub

Private Sub SuperWkspManager_LDbClick(ByVal nFlag As SuperMapLib.seSelectedItemFlag, ByVal strSelected As String, ByVal strParent As String)
    
    Dim bResult As Boolean
    Dim objDataset As soDataset
    If nFlag = scsDatasource Then Exit Sub
    
    If nFlag = scsDataset Then
        Set objDataset = SuperWorkspace.Datasources(strParent).Datasets(strSelected)
        
        If objDataset Is Nothing Then
            MsgBox "打开数据集失败！", vbInformation, "信息提示"
            Exit Sub
        End If
        
        SuperMap.Layers.RemoveAll
        SuperMap.Layers.AddDataset objDataset, True
        SuperMap.ViewEntire
    End If
    
    SuperMap.Refresh
    SuperLegend.Refresh
    Set objDataset = Nothing

End Sub

Private Sub IniComboBox(objCmb As ComboBox)
    Dim objDs As soDataSource
    Dim strDs As String
    Dim i As Integer
    Dim iCnt As Integer
    
    iCnt = SuperWorkspace.Datasources.Count
    If iCnt > 0 Then
        objCmb.Clear
        For i = 1 To iCnt
            Set objDs = SuperWorkspace.Datasources(i)
            strDs = objDs.Alias
            objCmb.AddItem strDs
        Next i
        If objCmb.ListCount > 0 Then objCmb.ListIndex = 0
        objCmb.Refresh
    Else
        MsgBox "获取数据源失败", vbInformation, "信息提示"
    End If
    
    Set objDs = Nothing
End Sub