form1.frm

里面有我用VB二次开发MAPGIS的20个例子

If Not pDBSArea Is Nothing Then
    If IsArcDisp = True Then
        IsArcDisp = False
    Else
        IsArcDisp = True
    End If
    With mnuArcVisible
        .Checked = Not .Checked
    End With
    EditView.UpdateWindow
End If
End Sub

Private Sub mnuAttAskGraDataToArea_Click()
Dim clsNo As Integer
Dim pDRect As New D_Rect
Dim wArea As WorkArea
If Not pDBSArea Is Nothing Then
    If (Not pDDotR Is Nothing) And (Not pDDotL Is Nothing) Then
        pDRect.xmax = pDDotR.x
        pDRect.xmin = pDDotL.x
        pDRect.ymax = pDDotL.y
        pDRect.ymin = pDDotR.y
    End If
    '由对话框选择图库当前层类
    clsNo = pDBSArea.dsSelDBSCurClass
    If clsNo >= 0 And Not pDRect Is Nothing Then
       '对指定层类在给定区域内设定属性条件提取图形数据到工作区中
        Set wArea = pDBSArea.dsAttAskGraDataToArea(clsNo, pDRect)
    End If
    If Not wArea Is Nothing Then
        wArea.SaveAs
    End If
End If
End Sub

Private Sub mnuChartDisp_Click()
If Not pDBSArea Is Nothing Then
    If IsGraDisp = True Then
        With mnuChartDisp
            .Checked = Not .Checked
        End With
        With mnuGraphDisp
            .Checked = Not .Checked
        End With
        With mnuDelFrm
            .Enabled = Not .Enabled
        End With
        With mnuPntClassNo
            .Enabled = Not .Enabled
        End With
        With mnuPntAtt
            .Enabled = Not .Enabled
        End With
        With mnuLinClassNo
            .Enabled = Not .Enabled
        End With
        With mnuLinAtt
            .Enabled = Not .Enabled
        End With
       With mnuRegClassNo
            .Enabled = Not .Enabled
        End With
        With mnuRegAtt
            .Enabled = Not .Enabled
        End With
        IsGraDisp = False
    End If
    EditView.UpdateWindow
End If
End Sub

Private Sub mnuCloseDocum_Click()
If Not pDBSArea Is Nothing Then
    pDBSArea.Clear
    EditView.UpdateWindow
End If
End Sub
Private Sub mnuDataManager_Click()
If Not pDBSArea Is Nothing Then
    IsView = True
End If
End Sub
Private Sub mnuDelFrm_Click()
If Not pDBSArea Is Nothing Then
    IsDel = True
End If
End Sub
Private Sub mnudsExpJTBToPrj_Click()
If Not pDBSArea Is Nothing Then
    pDBSArea.dsExportDBSJTBToPrj
End If
End Sub

Private Sub mnuEditParam_Click()
If Not pDBSArea Is Nothing Then
    pDBSArea.dsViewDBSMapParam
End If
End Sub
'显示坐标内容
Private Sub EditView_MousePosition(ByVal x_Pos As Double, ByVal y_Pos As Double)
Dim str As String

str = "X坐标:" & Format(x_Pos, "0.000") & "  Y坐标:" & Format(y_Pos, "0.000")
Me.StatusBar.Panels(1).Text = "图库组件化测试"
Me.StatusBar.Panels(2).Text = str

End Sub

Private Sub mnuEnableRange_Click()
'pDBSLayer.dsStrollMapDBS hWnd,pDDot.x,pDDot.y
End Sub

Private Sub mnuExpIndex_Click()
If Not pDBSArea Is Nothing Then
    pDBSArea.dsExportIdxToREGArea
End If
End Sub

'初始化
Private Sub Form_Load()
Set pDBSLayer = New DBSLayer
End Sub


'定大小
Private Sub Form_Resize()
If Me.ScaleHeight - StatusBar.Height <= 0 Then
 Exit Sub
End If
EditView.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight - StatusBar.Height

Me.StatusBar.Panels(1).Width = Me.ScaleWidth * 2 / 7
Me.StatusBar.Panels(2).Width = Me.ScaleWidth * 3 / 7
Me.StatusBar.Panels(3).Width = Me.ScaleWidth * 2 / 7

End Sub
Private Sub Form_Unload(Cancel As Integer)
'Set pubSetobj = Nothing
MapGis.CloseMapGisBmp
End Sub

'==========================选择、显示测试代码==========================
'自绘事件
Private Sub EditView_MyDraw(ByVal MpDC As Object)
If Not pDBSLayer Is Nothing Then
    '显示地图库数据
     pDBSLayer.dsDispDBSArea MpDC, IsGraDisp, IsArcDisp
     '设置接图表绘制前景颜色
     pDBSLayer.dsSetDBSFrClr 5
End If
End Sub
Private Sub mnuGraphDisp_Click()
If Not pDBSArea Is Nothing Then
    If IsGraDisp = False Then
        With mnuGraphDisp
            .Checked = Not .Checked
        End With
        With mnuChartDisp
            .Checked = Not .Checked
        End With
        With mnuDelFrm
        .Enabled = Not .Enabled
        End With
        With mnuPntClassNo
            .Enabled = Not .Enabled
        End With
        With mnuPntAtt
            .Enabled = Not .Enabled
        End With
        With mnuLinClassNo
            .Enabled = Not .Enabled
        End With
        With mnuLinAtt
            .Enabled = Not .Enabled
        End With
       With mnuRegClassNo
            .Enabled = Not .Enabled
        End With
        With mnuRegAtt
            .Enabled = Not .Enabled
        End With
        IsGraDisp = True
    End If
    EditView.UpdateWindow
End If
End Sub

Private Sub mnuImpIndex_Click()
If Not pDBSArea Is Nothing Then
    pDBSArea.dsImportIdxToDBSArea
End If
End Sub

Private Sub mnuIndexReg_Click()
Dim rArea As RegArea
If Not pDBSArea Is Nothing Then
    Set rArea = pDBSArea.dsGetDBSIndexRegAi
    If Not rArea Is Nothing Then
        rArea.SaveAs
    End If
End If
End Sub

Private Sub mnuMerg_Click()
If Not pDBSArea Is Nothing Then
    With mnuMerg
        .Checked = Not .Checked
    End With
    If IsMerg = True Then
        IsMerg = False
    Else
        IsMerg = True
    End If
End If
End Sub
Private Sub mnuLayerManage_Click()
If Not pDBSArea Is Nothing Then
    If IsGraDisp = False Then
           pDBSArea.dsDBSClassManger
    Else
           pDBSArea.dsDBSClassViewer
    End If
End If
End Sub

Private Sub mnuLinAtt_Click()
If Not pDBSArea Is Nothing Then
    IsQuLinA = True
End If
End Sub

Private Sub mnuLinClassNo_Click()
If Not pDBSArea Is Nothing Then
    IsQuLin = True
End If
End Sub
Private Sub mnuOpenDBS_Click()
Set pDBSArea = pDBSLayer.WorkArea
pDBSArea.Load
EditView.SetWinMapRange pDBSArea.rect.xmin, pDBSArea.rect.ymin, pDBSArea.rect.xmax, pDBSArea.rect.ymax
EditView.RestoreWindow
End Sub

Private Sub mnuOutDocument_Click()
If Not pDBSArea Is Nothing Then
    pDBSArea.dsOutDBSDocDat
End If
End Sub

Private Sub mnuPackSaveAs_Click()
If Not pDBSArea Is Nothing Then
    pDBSArea.dsPackSaveFILEAs
End If
End Sub

Private Sub mnuPntAtt_Click()
IsQuPntA = True
End Sub

Private Sub mnuPntClassNo_Click()
IsQuPnt = True
End Sub

Private Sub mnuQueryInf_Click()
If Not pDBSArea Is Nothing Then
    pDBSArea.dsViewDBSInfo
End If
End Sub
Private Sub mnuRegAtt_Click()
IsQuRegA = True
End Sub

Private Sub mnuRegClassNo_Click()
IsQuReg = True
End Sub
Private Sub mnuRgnAttAskDBSClsDat_Click()
Dim clsNo As Integer
Dim pDRect As D_Rect
Dim pDDotSet As New D_DotSet
Dim wArea As WorkArea
If Not pDBSArea Is Nothing Then
    If Not pDRect Is Nothing Then
        pDBSArea.dsGetDBSFrmRect lFramNo, pDRect
        '由对话框选择图库当前层类
        clsNo = pDBSArea.dsSelDBSCurClass
        pDDotSet.Append pDRect.xmin, pDRect.ymin
        pDDotSet.Append pDRect.xmax, pDRect.ymax
        pDDotSet.Append2 pDDotL
    End If
     If clsNo >= 0 Then
        '在给定区域按一定属性条件提取指定层类数据到工作区中
        Set wArea = pDBSArea.dsRgnAttAskDBSClsDat(clsNo, pDDotSet)
    End If
    If Not wArea Is Nothing Then
        wArea.SaveAs
    End If
End If
End Sub

Private Sub mnuSave_Click()
If Not pDBSArea Is Nothing Then
    pDBSArea.Save
End If
End Sub

Private Sub mnuSaveAs_Click()
If Not pDBSArea Is Nothing Then
    pDBSArea.SaveAs
End If
End Sub

Private Sub mnuSelFrams_Click()
Dim framLst As LONGList
If Not pDBSArea Is Nothing Then
    '通过对话框选择多个图幅
    Set framLst = pDBSArea.dsSelDBSFramsByDlg
    If Not framLst Is Nothing Then
        '根据给定图幅列表提取图库数据处理
        pDBSArea.dsFramLstClipProc framLst
        '释放由dsSelDBSFramsByDlg方法产生的图库图幅选择表
        pDBSArea.dsFreeDBSFrmSelLst
    End If
End If
End Sub

Private Sub mnuSetCoordinate_Click()
If Not pDBSArea Is Nothing Then
    pDBSArea.dsSetDBSDispCordParam
End If
End Sub

Private Sub RgnAttAskDBSClsDat_Click()
Dim clsNo As Integer
Dim pDRect As D_Rect
Dim pDDotSet As New D_DotSet
Dim wArea As WorkArea
If Not pDBSArea Is Nothing Then
    If Not pDRect Is Nothing Then
        pDBSArea.dsGetDBSFrmRect lFramNo, pDRect
        pDDotSet.Append pDRect.xmax, pDRect.ymax
        pDDotSet.Append pDRect.xmin, pDRect.ymin
        pDDotSet.Append2 pDDotL
        '由对话框选择图库当前层类
        clsNo = pDBSArea.dsSelDBSCurClass
    End If
    If clsNo >= 0 Then
        '在给定区域按一定属性条件提取指定层类数据到工作区中
        Set wArea = pDBSArea.dsRgnAttAskDBSClsDat(clsNo, pDDotSet)
    End If
    If Not wArea Is Nothing Then
        wArea.SaveAs
    End If
End If
End Sub