testcom.frm

来自「里面有我用VB二次开发MAPGIS的20个例子」· FRM 代码 · 共 1,350 行 · 第 1/3 页

'MsgBox "开始移动矩形范围！"
Set mpMoveRectTool = New MoveRectTool

If mpMoveRectTool Is Nothing Then
   MsgBox "mpMoveRectTool Is Nothing!"
   Exit Sub
End If

Call mpMoveRectTool.SetMapView(EditView)
mpMoveRectTool.MoveRect = PubComPrj.Legend.DispRect
EditView.SetExtendTool mpMoveRectTool

End Sub

'清除Tool
Private Sub mnuToolClear_Click()
On Error Resume Next

If PubComPrj Is Nothing Then
   MsgBox "工程对象为空!"
   Exit Sub
End If

'清除所有的Tool对象
ClearAllTool

EditView.SetExtendTool Nothing

End Sub

'******************************************'
'**************Map  处理函数***************'
'******************************************'

'关闭Map
Private Sub mnuCloseMap_Click()
On Error Resume Next

Set PubComPrj = Nothing

'更新显示
EditView.Map = Nothing
layerTreeView.SetMap Nothing

EditView.UpdateWindow

'修改菜单状态
Me.mnuMapDispLeg.Checked = False

End Sub

'新建Map
Private Sub mnuNewMap_Click()
On Error Resume Next

'关闭Map
mnuCloseMap_Click

'创建Map对象
Set PubComPrj = New Map

If PubComPrj Is Nothing Then
   Exit Sub
End If

'更新显示
layerTreeView.SetMap PubComPrj
EditView.Map = PubComPrj

'设置图例显示范围
'SetMapLegendRect

'修改菜单状态
If PubComPrj.CanDispLegend = 1 Then
   Me.mnuMapDispLeg.Checked = True
Else
   Me.mnuMapDispLeg.Checked = False
End If

End Sub

'装入Map
Private Sub mnuOpenMap_Click()
On Error Resume Next

'关闭Map
mnuCloseMap_Click

'创建Map对象
Set PubComPrj = New Map

If PubComPrj Is Nothing Then
   Exit Sub
End If

'装入文件
PubComPrj.LoadMapFile

'更新显示
layerTreeView.SetMap PubComPrj
EditView.Map = PubComPrj

'设置图例显示范围
'SetMapLegendRect

'修改菜单状态
If PubComPrj.CanDispLegend = 1 Then
   Me.mnuMapDispLeg.Checked = True
Else
   Me.mnuMapDispLeg.Checked = False
End If

End Sub

'保存Map
Private Sub mnuSaveMap_Click()
On Error Resume Next

If PubComPrj Is Nothing Then
   Exit Sub
End If

PubComPrj.SaveMapFile

'重新装入Tree内容
layerTreeView.ReloadTree

End Sub

'Map显示图例
Private Sub mnuMapDispLeg_Click()
On Error Resume Next

If PubComPrj Is Nothing Then
   MsgBox "工程对象为空!"
   Exit Sub
End If

If PubComPrj.CanDispLegend = 0 Then
   PubComPrj.CanDispLegend = 1
Else
   PubComPrj.CanDispLegend = 0
End If

'修改菜单状态
If PubComPrj.CanDispLegend = 1 Then
   Me.mnuMapDispLeg.Checked = True
Else
   Me.mnuMapDispLeg.Checked = False
End If

End Sub


'******************************************'
'**************Layer处理函数***************'
'******************************************'
'添加Layer
Private Sub mnuAddLayer_Click()
On Error Resume Next

Dim newlayer
Dim layertype

If PubComPrj Is Nothing Then
   Exit Sub
End If

'输入
CommonDialog1.FileName = ""
CommonDialog1.Filter = "MapGis基本文件(*.w?)|*.w?|点文件(*.wt)|*.wt|线文件(*.wl)|*.wl|区文件(*.wp)|*.wp|网文件(*.wn)|*.wn||"
CommonDialog1.ShowOpen

If CommonDialog1.FileName = "" Then
   Exit Sub
End If

layertype = MapGis.GetFileType(CommonDialog1.FileName)

Select Case layertype
   Case gisPNT: '点文件
            Set newlayer = CreateObject("MapLayerCom.PntLayer.1")
            If newlayer Is Nothing Then
               MsgBox "CreateObject PntLayer失败！"
               Exit Sub
            End If
   Case gisLIN: '线文件
            Set newlayer = CreateObject("MapLayerCom.LinLayer.1")
            If newlayer Is Nothing Then
               MsgBox "CreateObject LinLayer失败！"
               Exit Sub
            End If
   Case gisREG: '区文件
            Set newlayer = CreateObject("MapLayerCom.RegLayer.1")
            If newlayer Is Nothing Then
               MsgBox "CreateObject RegLayer失败！"
               Exit Sub
            End If
   Case gisNET: '网文件
            Set newlayer = CreateObject("MapLayerCom.NetLayer.1")
            If newlayer Is Nothing Then
               MsgBox "CreateObject NetLayer失败！"
               Exit Sub
            End If
   Case Else:
            MsgBox "非法的类型！"
            Exit Sub
End Select

'装入文件
res = newlayer.WorkArea.Load(CommonDialog1.FileName)

If res = False Then
   MsgBox "打开文件失败!"
   Exit Sub
End If

'添加到Map中去
PubComPrj.AddLayer newlayer

End Sub

'删除第一个Layer
Private Sub mnuDelLayer_Click()
On Error Resume Next

Dim dellayer As MapLayer

If PubComPrj Is Nothing Then
   Exit Sub
End If

If PubComPrj.MapLayerCount > 0 Then
   Set dellayer = PubComPrj.layer(0)
   
   If Not dellayer Is Nothing Then
      PubComPrj.DeleteMapLayer dellayer
   End If
   
   Set dellayer = Nothing
End If

End Sub

'关闭/打开第一个Layer
Private Sub mnuVisLayer_Click()
On Error Resume Next

Dim firstlayer As MapLayer

If PubComPrj Is Nothing Then
   Exit Sub
End If

If PubComPrj.MapLayerCount > 0 Then
   Set firstlayer = PubComPrj.layer(0)
   
   If Not firstlayer Is Nothing Then
      firstlayer.Visible = Not firstlayer.Visible
   End If
   
   Set firstlayer = Nothing
End If

End Sub

'******************************************'
'**************Dsp  处理函数***************'
'******************************************'

'是否显示图例
Private Sub mnuDspMyDraw_Click()
On Error Resume Next

End Sub


'******************************************'
'************** Map处理函数 ***************'
'******************************************'

'循环取每个Layer
Private Sub mnuFindFirstNext_Click()
On Error Resume Next

Dim layer As MapLayer
Dim layertype
Dim no As Long
Dim str

If PubComPrj Is Nothing Then
   Exit Sub
End If

no = 0
Set layer = PubComPrj.FindFirst(gisFINDTYPE_NOGROUP)

While Not (layer Is Nothing)
   no = no + 1
   layertype = layer.layertype
   
   If layertype = gisGROUP Then '组
      str = "组:" & layer.Describe
   Else
      If layer.WorkArea Is Nothing Then
         str = "文件:" & "NullWorkArea"
      Else
         str = "文件:" & layer.WorkArea.Name
      End If
   End If
   
   MsgBox "No=" & no & vbCrLf & str
   
   Set layer = Nothing
   
   '下一个
   Set layer = PubComPrj.FindNext
Wend

Set layer = Nothing
End Sub

'取特定的Layer
Private Sub mnuFindLayer_Click()
On Error Resume Next

Dim layer As MapLayer
Dim layertype
Dim no As Long
Dim str As String

If PubComPrj Is Nothing Then
   Exit Sub
End If

CommonDialog1.DialogTitle = "选择要查找的文件"
CommonDialog1.FileName = ""
CommonDialog1.Filter = "MapGis基本文件(*.w?)|*.w?|点文件(*.wt)|*.wt|线文件(*.wl)|*.wl|区文件(*.wp)|*.wp|网文件(*.wn)|*.wn||"

CommonDialog1.ShowOpen
If CommonDialog1.FileName = "" Then
   Exit Sub
End If

no = 0
Set layer = PubComPrj.FindLayerByName(CommonDialog1.FileName, "")

If Not layer Is Nothing Then
   If layer.WorkArea Is Nothing Then
      MsgBox "Found!" & vbCrLf & "NullWorkArea"
   Else
      MsgBox "Found!" & vbCrLf & layer.WorkArea.Name
   End If
Else
   MsgBox "No Found!"
End If

Set layer = Nothing

End Sub

'结束了!
Private Sub mpMoveRectTool_Finished()
MsgBox "mpMoveRectTool_Finished!"

On Error Resume Next

If PubComPrj Is Nothing Then
   MsgBox "工程对象为空!"
   Exit Sub
End If

PubComPrj.Legend.DispRect = mpMoveRectTool.MoveRect

EditView.UpdateWindow
EditView.SetExtendTool Nothing


End Sub

'******************************************'
'**************其他  处理函数***************'
'******************************************'

'处理切分(开始)
Private Sub Spliter_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
On Error Resume Next

bSpliterPressed = True
End Sub

'处理切分(运动)
Private Sub Spliter_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
On Error Resume Next

If bSpliterPressed = True Then
    If x + Spliter.Left < 0 Then
       Spliter.Left = 0 + 1
    End If
       
    If x + Spliter.Left > Me.ScaleWidth Then
       Spliter.Left = Me.ScaleWidth - 1
    End If
    
    Spliter.Left = x + Spliter.Left
    Spliter.RightToLeft = Spliter.Left + SPLITWID
End If

End Sub

'处理切分(结束)
Private Sub Spliter_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
On Error Resume Next

Dim offsetHei
offsetHei = 20

If Me.ScaleHeight - StatusBar.Height - offsetHei <= 0 Then
   Exit Sub
End If

layerTreeView.Move 0, 0, Spliter.Left, Me.ScaleHeight - StatusBar.Height - offsetHei
EditView.Move Spliter.Left, 0, Me.ScaleWidth - Spliter.Left, Me.ScaleHeight - StatusBar.Height - offsetHei


bSpliterPressed = False
End Sub

'设置图例显示范围
Private Sub SetMapLegendRect()

Dim mrc As D_Rect
Dim wid As Double, hei As Double

Set mrc = PubComPrj.MapRect

wid = mrc.xmax - mrc.xmin
hei = mrc.ymax - mrc.ymin

mrc.xmax = mrc.xmin + wid / 4
mrc.ymax = mrc.ymin + hei / 4

PubComPrj.Legend.DispRect = mrc

Set mrc = Nothing

End Sub