testcom.frm

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

Set PubMapLeg = Nothing

End Sub

'图例--保存图例对象
Private Sub mnuLegSave_Click()
On Error Resume Next

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

Set PubMapLeg = PubComPrj.Legend

If (PubMapLeg Is Nothing) Then
    Exit Sub
End If

PubMapLeg.SaveLegendFile

Set PubMapLeg = Nothing

End Sub

'图例--另存图例对象
Private Sub mnuLegSaveAs_Click()
On Error Resume Next

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

Set PubMapLeg = PubComPrj.Legend

If (PubMapLeg Is Nothing) Then
    Exit Sub
End If

PubMapLeg.SaveAsLegendFile

Set PubMapLeg = Nothing

End Sub

'图例--关闭图例文件
Private Sub mnuLegClose_Click()
On Error Resume Next

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

Set PubMapLeg = PubComPrj.Legend

If (PubMapLeg Is Nothing) Then
    Exit Sub
End If

PubMapLeg.CloseLegendFile

Set PubMapLeg = Nothing

End Sub

'图例--编辑图例
Private Sub mnuLegEditItem_Click()
On Error Resume Next

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

Set PubMapLeg = PubComPrj.Legend

If (PubMapLeg Is Nothing) Then
    Exit Sub
End If

PubMapLeg.EditLegItem

Set PubMapLeg = Nothing

End Sub

'图例--取当前选中的图例
Private Sub mnuLegGetSelItem_Click()
On Error Resume Next

Dim sellegitem As LegendItem
Dim att As Record
Dim outstr As String

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

Set PubMapLeg = PubComPrj.Legend

If (PubMapLeg Is Nothing) Then
   Exit Sub
End If

Set sellegitem = PubMapLeg.SelectedLegItem

If sellegitem Is Nothing Then
   MsgBox "没有选中任何图例元素!"
Else
   Set att = sellegitem.att
   
   outstr = "选中了图例元素!" & vbCrLf & "类型=" & sellegitem.Type & _
            vbCrLf & "Name=" & sellegitem.Name & _
            vbCrLf & "Describe=" & sellegitem.Describe
            
   '属性内容
   If Not (att Is Nothing) Then
      outstr = outstr & vbCrLf & "-------------" & vbCrLf & _
              vbCrLf & "AttStru.RecordNum=" & att.hd.numbfield & _
              vbCrLf & "Att.Item(0)=" & att.Item(0)
   End If
   
   MsgBox outstr
   
   Set att = Nothing
End If

Set PubMapLeg = Nothing

End Sub

'图例--打开图例板
Private Sub mnuLegOpenPad_Click()
On Error Resume Next

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

Set PubMapLeg = PubComPrj.Legend

If (PubMapLeg Is Nothing) Then
    Exit Sub
End If

PubMapLeg.OpenLegPad

Set PubMapLeg = Nothing
End Sub


'图例--关闭图例板
Private Sub mnuLegClosePad_Click()
On Error Resume Next

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

Set PubMapLeg = PubComPrj.Legend

If (PubMapLeg Is Nothing) Then
    Exit Sub
End If

PubMapLeg.CloseLegPad

Set PubMapLeg = Nothing
End Sub

'图例--设置图例参数
Private Sub mnuLegSetParam_Click()
On Error Resume Next

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

Set PubMapLeg = PubComPrj.Legend

If (PubMapLeg Is Nothing) Then
    Exit Sub
End If

PubMapLeg.SetLegParam

Set PubMapLeg = Nothing
End Sub

'把图例转换为文件
Private Sub mnuLegWriteToFile_Click()
On Error Resume Next

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

Set PubMapLeg = PubComPrj.Legend

If (PubMapLeg Is Nothing) Then
    Exit Sub
End If

PubMapLeg.WriteLegItemsToFile

Set PubMapLeg = Nothing

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

Private Sub mnuRstLayerOpen_Click()
On Error Resume Next

Dim res
Dim rstarea As RasterArea
'输入
CommonDialog1.FileName = ""
CommonDialog1.Filter = "图象文件(*.msi)|*.msi||"
CommonDialog1.ShowOpen

If Len(CommonDialog1.FileName) <= 0 Then
   Exit Sub
End If

Set PubRasterLayer = Nothing
Set PubRasterLayer = New RasterLayer

Set rstarea = PubRasterLayer.WorkArea
res = rstarea.Load(CommonDialog1.FileName)

If res = False Then
   MsgBox "图象文件装载失败！"
End If

End Sub


Private Sub mnuTest_Click()

Set Test1 = New TestClass1

If Test1 Is Nothing Then
   MsgBox "Test1 Is Nothing"
End If

Set Test1 = 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("e:\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

'******************************************'
'**************Tool  处理函数***************'
'******************************************'
'清除所有的Tool对象
Private Sub ClearAllTool()

Set mpMoveLegRectTool = Nothing
Set mpMoveRectTool = Nothing

End Sub

'Tool-移动图例的范围
Private Sub mnuToolMoveLegRect_Click()
On Error Resume Next

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

'清除所有的Tool对象
ClearAllTool

'MsgBox "开始移动图例的范围！"
Set mpMoveLegRectTool = New MoveLegRectTool

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

Call mpMoveLegRectTool.SetMapView(EditView)
EditView.SetExtendTool mpMoveLegRectTool

End Sub

'Tool-移动矩形范围
Private Sub mnuToolMoveRect_Click()
On Error Resume Next

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

'清除所有的Tool对象
ClearAllTool