testcom.frm

mapgis二次开发,vb示例 mapgis二次开发,vb示例

  menuID = GetMenuItemID(hSubMenu, 1)
  x = SetMenuItemBitmaps(hMenu, menuID, 0, mnuImageList.ListImages(7).Picture, mnuImageList.ListImages(7).Picture)

End Sub



Private Sub layerTreeView_Click()

End Sub

'******************************************'
'**************Print 处理函数***************'
'******************************************'
'系统自动检测幅面
Private Sub mnuPrintAutoCheckPage_Click()
On Error Resume Next

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

Set PubMapPrintParam = PubComPrj.PrintParam

If (PubMapPrintParam Is Nothing) Then
    Exit Sub
End If

PubMapPrintParam.AutoCheckPage

MsgBox "VerW=" & PubMapPrintParam.PageWidth & vbCrLf & _
       "VerH=" & PubMapPrintParam.PageHeight & vbCrLf & _
       "TranX=" & PubMapPrintParam.TranX & vbCrLf & _
       "TranY=" & PubMapPrintParam.TranY & vbCrLf & _
       "ScaleX=" & PubMapPrintParam.ScaleX & vbCrLf & _
       "ScaleY=" & PubMapPrintParam.ScaleY & vbCrLf & _
       "Angle=" & PubMapPrintParam.angle

Set PubMapPrintParam = Nothing

End Sub

'按照页面大小设置
Private Sub mnuPrintFitToPage_Click()
On Error Resume Next

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

Set PubMapPrintParam = PubComPrj.PrintParam

If (PubMapPrintParam Is Nothing) Then
    Exit Sub
End If


PubMapPrintParam.FitToPage

MsgBox "VerW=" & PubMapPrintParam.PageWidth & vbCrLf & _
       "VerH=" & PubMapPrintParam.PageHeight & vbCrLf & _
       "TranX=" & PubMapPrintParam.TranX & vbCrLf & _
       "TranY=" & PubMapPrintParam.TranY & vbCrLf & _
       "ScaleX=" & PubMapPrintParam.ScaleX & vbCrLf & _
       "ScaleY=" & PubMapPrintParam.ScaleY & vbCrLf & _
       "Angle=" & PubMapPrintParam.angle
       
Set PubMapPrintParam = Nothing

End Sub

'编辑输出参数
Private Sub mnuPrintSetParam_Click()
On Error Resume Next

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

Set PubMapPrintParam = PubComPrj.PrintParam

If (PubMapPrintParam Is Nothing) Then
    Exit Sub
End If

PubMapPrintParam.EditPrintParam

Set PubMapPrintParam = Nothing

End Sub

'光栅化处理
Private Sub mnuRastTreat_Click()
On Error Resume Next

Dim RastMapDC As New MapGisDC

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

Call RastMapDC.CreateRastDC("e:\ComRast.nv1")

Call PubComPrj.MapOutput(RastMapDC)

Set RastMapDC = Nothing

End Sub


'Windows输出
Private Sub mnuWindowsOut_Click()
On Error Resume Next

Dim WinMapDC As New MapGisDC

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

Call WinMapDC.CreatePrintDC

Call PubComPrj.MapOutput(WinMapDC)

Set WinMapDC = Nothing

End Sub


'生成Gif图象
Private Sub mnuCreateGif_Click()
On Error Resume Next

Dim ImageMapDC As New MapGisDC

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

Call ImageMapDC.CreateGIFFileDC("c:\ComGif.gif", PubComPrj.PrintParam.PageWidth, PubComPrj.PrintParam.PageHeight)

Call PubComPrj.MapOutput(ImageMapDC)

Set ImageMapDC = Nothing

End Sub

'生成Tif图象
Private Sub mnuCreateTif_Click()
On Error Resume Next

MsgBox "暂时未实现!"

End Sub



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

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

Set PubComPrj = Nothing

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

EditView.UpdateWindow
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

End Sub

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

'关闭Map
mnuCloseMap_Click

Dim x As Double
Dim y As Double
Dim c As Double
'创建Map对象
Set PubComPrj = New Map

If PubComPrj Is Nothing Then
   Exit Sub
End If

'装入文件
PubComPrj.LoadMapFile

'更新显示

layerTreeView.SetMap PubComPrj
EditView.Map = PubComPrj

'EditView.GetDispParm x, y, c
'c = 7
'EditView.SetDispParm x, y, c

'EditView.UpdateWindow

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处理函数 ***************'
'******************************************'

'循环取每个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 = 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 mnuAppendlin_Click()
On Error Resume Next

If PubComPrj Is Nothing Then
   Exit Sub
End If
EditView.MakeLine
End Sub