Common Function in Loading Layers From Personal Database

Key Words: ArcGIS,ArcObject, VBA,Access,Cycle through all Polygons

///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////

Private Type GRLayerNM
    strLayerName As String 'MGISDBSRV
    strUserName As String   'TGMS3
End Type
'//////////////////////////////////////////////////////////////////////////////////////////////////
Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
'//////////////////////////////////////////////////////////////////////////////////////////////////
Declare Function RemoveMenu Lib "user32" _
(ByVal hMenu As Long, ByVal nPosition As Long, _
ByVal wFlags As Long) As Long
'//////////////////////////////////////////////////////////////////////////////////////////////////
'//////////////////////////////////////////////////////////////////////////////////////////////////
Dim pFact As IWorkspaceFactory
Public pSDEWorkspace As IWorkspace
Dim pFeatureWorkspace As IFeatureWorkspace
Public pEditor As IEditor
Public pID As New UID
Public LayersName() As GRLayerNM
Public AdoCon As ADODB.Connection
Public Adors As ADODB.Recordset
Public ct As Integer, totalCt As Integer
Public arrLayersName() As String
Public arrLayerOutputName() As String
Public GB_OUTPUT_FILE_PATH As String
'//////////////////////////////////////////////////////////////////////////////////////////////////
'//////////////////////////////////////////////////////////////////////////////////////////////////
Declare Function GetSystemMenu Lib "user32" _
(ByVal hwnd As Long, ByVal bRevert As Long) As Long
Public Const MF_BYPOSITION = &H400&
Public Const MF_REMOVE = &H1000&
 
Public Sub DisableFormCloseButton()
'//###################################################################
'//###  Author:   GuanRui
'//###  Date:     Oct 16, 2006 
'//###  Description: Disable the "close" button of ArcMap
'//###  In:     void
'//###  Out:    void
'//###################################################################
    Dim lHwnd As Long
    lHwnd = FindWindow("ThunderDFrame", "Config SDE Server") 'Change to match your userforms caption
    Do While lHwnd = 0
        lHwnd = FindWindow("ThunderDFrame", "Config") 'Change to match your userforms caption
        DoEvents
    Loop
    RemoveMenu GetSystemMenu(lHwnd, 0), 6, MF_BYPOSITION 'When using by position, 6 represents the 7th menu item (including separators)
End Sub
 
Public Function GetCurrentPath() As String
    On Error GoTo ErrHandle:
    Dim strFullName As String
    Dim strPath As String
    Dim iPos As Integer
    
    
    Dim pVBProject As VBIDE.VBProject
    
    strPath = vbNullString
    Set pVBProject = Application.Document.VBProject
    If Not pVBProject Is Nothing Then
        strFullName = pVBProject.FileName
        iPos = InStrRev(strFullName, "\")
        If iPos > 0 Then
            strPath = Mid(strFullName, 1, iPos)
        Else
            strPath = vbNullString
        End If
    End If
    
    GetCurrentPath = strPath
    Exit Function
ErrHandle:
    MsgBox Err.Description
End Function


Public Sub LoadLayerNameToArray()
   Dim i As Integer
   Do Until Adors.EOF
       totalCt = totalCt + 1
       Adors.MoveNext
   Loop
   Adors.MoveFirst
   
   ReDim arrLayersName(0 To totalCt - 1) As String
   ReDim arrLayerOutputName(0 To totalCt - 1) As String
   i = 0
   Do Until Adors.EOF
       arrLayersName(i) = CStr(Adors.Fields("FD_LayerName").Value)
       arrLayerOutputName(i) = CStr(Adors.Fields("FD_OutputFile").Value)
       i = i + 1
       Adors.MoveNext
       Debug.Print arrLayersName(1)
       Debug.Print arrLayersName(2)
       Debug.Print arrLayersName(3)
   Loop
   Adors.MoveFirst
End Sub


Public Sub OpenOLEDB()
    Set AdoCon = New ADODB.Connection
    Set Adors = New ADODB.Recordset
    Dim sqlstr As String, sConstring As String
    
    sConstring = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                    "Data Source=" & GB_OUTPUT_FILE_PATH & "GEODB\Test.mdb;"
    
    AdoCon.Open sConstring
      
    sqlstr = "select *,FD_LayerName from TB_LayerName"
    Adors.CursorLocation = adUseClient
    Adors.Open sqlstr, AdoCon, adOpenStatic, adLockOptimistic
    'Set frmConfig.
End Sub
Public Sub LoadMapFromAccess()
    Dim pMxDocument As IMxDocument
    Dim pMap As IMap
    Dim pPropSet As IPropertySet
    Dim pFeatureClass As IFeatureClass
    Dim mLayer() As TLayer
    Dim pLyr As ILayer
    Dim pFLyrFile, pFeatureLayer As IFeatureLayer
    Dim pDataset As IDataset
'
'    Dim pEditor As IEditor
'    Dim pID As New UID
    
    Dim bLayerExists As Boolean
    
    Set pPropSet = New PropertySet
    Set pMxDocument = Application.Document
    Set pMap = pMxDocument.FocusMap
    
    
    pPropSet.SetProperty "DATABASE", GB_OUTPUT_FILE_PATH & "\GEODB\Test.mdb"
    
    Set pFact = New AccessWorkspaceFactory
    Set pSDEWorkspace = pFact.Open(pPropSet, 0)  'Open use SDE
    
    Set pFeatureWorkspace = pSDEWorkspace
    If pFeatureWorkspace Is Nothing Then Exit Sub
    If pMap.LayerCount <> 0 Then Exit Sub
    
    bLayerExists = False
    If pMap.LayerCount > 0 Then
       bLayerExists = True
    End If
    For i = 0 To UBound(arrLayersName) - 1
        'Set pFeatureClass = pFeatureWorkspace.OpenFeatureClass(frmConfig.cboLayerList.Text)
        Set pFeatureClass = pFeatureWorkspace.OpenFeatureClass(arrLayersName(i))
        Set pFeatureLayer = New FeatureLayer
        Set pFeatureLayer.FeatureClass = pFeatureClass
        Set pDataset = pFeatureClass
        pFeatureLayer.Name = pDataset.Name
        
        If Not pFeatureLayer Is Nothing Then
            pMap.MapUnits = esriMeters
            pFeatureLayer.Visible = True
            pFeatureLayer.Selectable = True
            Set pLyr = pFeatureLayer
            pMap.AddLayer pLyr
        End If
        'Set pFeatureWorkspace = Nothing
    Next
    
    'Set pGeoLyr = Nothing
    Set pLyr = Nothing
    Set pFeatureLayer = Nothing
    Set pDataset = Nothing
    'Set pWorkspace = Nothing
End Sub