form1.frm

这是一个非常全的VB+AO二次开发实例集

VERSION 5.00
Object = "{C552EA90-6FBB-11D5-A9C1-00104BB6FC1C}#1.0#0"; "MapControl.ocx"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   5745
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   8055
   LinkTopic       =   "Form1"
   ScaleHeight     =   5745
   ScaleWidth      =   8055
   StartUpPosition =   3  'Windows Default
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   7080
      Top             =   2040
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton cmdSaveMxd 
      Caption         =   "SaveMxd"
      Height          =   495
      Left            =   6840
      TabIndex        =   2
      Top             =   1200
      Width           =   975
   End
   Begin VB.CommandButton cmdAddLayer 
      Caption         =   "AddLayer"
      Height          =   495
      Left            =   6840
      TabIndex        =   1
      Top             =   240
      Width           =   975
   End
   Begin esriMapControl.MapControl MapControl1 
      Height          =   5535
      Left            =   120
      OleObjectBlob   =   "Form1.frx":0000
      TabIndex        =   0
      Top             =   120
      Width           =   6375
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub cmdAddLayer_Click()
    On Error GoTo ErrorHandler
    CommonDialog1.ShowOpen
    AddShapeFile (CommonDialog1.FileName)
    Exit Sub
    
ErrorHandler:
    MsgBox Err.Description
End Sub

Public Sub AddShapeFile(ByVal strFileName As String)
    Dim pWorkspaceFactory As IWorkspaceFactory
    Dim pFeatureWorkspace As IFeatureWorkspace
    Dim pFeatureLayer As IFeatureLayer
    Dim pMxdocumentument As IMxDocument
    Dim pMap As IMap
    Dim strPath As String
    Dim strName As String
    
    strPath = Mid(strFileName, 1, InStrRev(strFileName, "\"))
    strName = Mid(strFileName, InStrRev(strFileName, "\") + 1)
    strName = Mid(strName, 1, Len(strName) - 4)
    'Create a new ShapefileWorkspaceFactory object and open a shapefile folder
    Set pWorkspaceFactory = New ShapefileWorkspaceFactory
    Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(strPath, 0)
    'Create a new FeatureLayer and assign a shapefile to it
    Set pFeatureLayer = New FeatureLayer
    Set pFeatureLayer.FeatureClass = pFeatureWorkspace.OpenFeatureClass(strName)
    pFeatureLayer.Name = pFeatureLayer.FeatureClass.AliasName
    'Add the FeatureLayer to the focus map
    MapControl1.AddLayer pFeatureLayer
    MapControl1.Refresh
    
    Set pWorkspaceFactory = Nothing
    Set pFeatureWorkspace = Nothing
    Set pFeatureLayer = Nothing
    Set pMxdocumentument = Nothing
    Set pMap = Nothing
    
End Sub
Public Function CreateNewDoc() As Boolean
    On Error GoTo ErrorHandler
    
    CreateNewDoc = False
    CommonDialog1.ShowSave
    Dim index                       As Integer
    Dim pMapControl                 As esriMapControl.MapControl
    Dim pApplication                As esriCore.IApplication
    Dim pDocument                   As esriCore.IDocument
    Dim pTemplates                  As esriCore.ITemplates
    Dim pMxDocument                 As esriCore.IMxDocument
    Dim pMap                        As esriCore.IMap
    Dim pActiveView                 As esriCore.IActiveView
    Dim pWorkspaceFactory           As esriCore.IWorkspaceFactory
    Dim pObjFactory                 As esriCore.IObjectFactory
    Dim pFeatureWorkspace           As esriCore.IFeatureWorkspace
    Dim pMDataSet                   As esriCore.IDataset
    Dim pMLayer                     As esriCore.ILayer
    Dim pMFeatureLayer              As esriCore.IFeatureLayer
    Dim pFeatureLayer               As esriCore.IFeatureLayer
    Dim pMGeoLayer                  As esriCore.IGeoFeatureLayer
    Dim pGeoLayer                   As esriCore.IGeoFeatureLayer
    Dim fso                         As New FileSystemObject
    
    If Not fso.FileExists(CommonDialog1.FileName) Then
         Set pMapControl = MapControl1
         Set pDocument = New esriCore.MxDocument
         Set pApplication = pDocument.Parent
         Set pTemplates = pApplication.Templates
         pApplication.NewDocument False, pTemplates.Item(0)
        
         Set pMxDocument = pDocument
         Set pMap = pMxDocument.FocusMap
         Set pMap.SpatialReference = pMapControl.SpatialReference
         Set pObjFactory = pApplication
         For index = pMapControl.LayerCount - 1 To 0 Step -1
             Set pMLayer = pMapControl.Layer(index)
             If Not pMLayer Is Nothing Then
                 If TypeOf pMLayer Is IFeatureLayer Then
                     Dim l               As Long
                     Dim str             As String
                     
                     Set pMFeatureLayer = pMLayer
                     Set pMDataSet = pMFeatureLayer
                     Set pMGeoLayer = pMFeatureLayer ''
                     strFileName = pMDataSet.Workspace.PathName
                     l = InStrRev(strFileName, ".")
                     str = Right(strFileName, Len(strFileName) - l + 1)
                     If UCase(Trim(str)) = ".MDB" Then
                         Set pWorkspaceFactory = New esriCore.AccessWorkspaceFactory
                         Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(strFileName, 0)
                         Set pFeatureLayer = pObjFactory.Create("esriCore.FeatureLayer")
                         Set pFeatureLayer.FeatureClass = pFeatureWorkspace.OpenFeatureClass(pMFeatureLayer.FeatureClass.AliasName)
                         pFeatureLayer.Name = pFeatureLayer.FeatureClass.AliasName
                         Set pGeoLayer = pFeatureLayer
                         Set pGeoLayer.Renderer = pMGeoLayer.Renderer
                     Else
                         Set pWorkspaceFactory = New esriCore.ShapefileWorkspaceFactory
                         Set pFeatureWorkspace = pWorkspaceFactory.OpenFromFile(strFileName, 0)
                         Set pFeatureLayer = pObjFactory.Create("esriCore.FeatureLayer")
                         Set pFeatureLayer.FeatureClass = pFeatureWorkspace.OpenFeatureClass(pMFeatureLayer.FeatureClass.AliasName)
                         pFeatureLayer.Name = pFeatureLayer.FeatureClass.AliasName
                         Set pGeoLayer = pFeatureLayer
                         Set pGeoLayer.Renderer = pMGeoLayer.Renderer
                     End If
                     pMap.AddLayer pFeatureLayer
                 End If
             End If
         Next
         Set pActiveView = pMap
         pActiveView.Extent = pMapControl.Extent
         
         pApplication.SaveDocument CommonDialog1.FileName
         pApplication.Shutdown
    End If
    CreateNewDoc = True
   Exit Function
    
ErrorHandler:
    MsgBox Err.Description
    CreateNewDoc = fales
End Function

Private Sub cmdSaveMxd_Click()
    If CreateNewDoc() = True Then
        MsgBox "Finish--OK"
    Else
        MsgBox "Finish--Err"
    End If
End Sub