Приветствую, всех
Возникла проблема при добавлении файла shp в слой-группу (GroupLayer) ArcScene из VBA. Причем если добавлять файл просто на scene методом pSxDoc.Scene.AddLayer - то все работает, а как только пишешь pGroupLayer.Add - файл вроде добавляется, и то это увидишь тока после того как ручками сделаешь Refresh этой самой группе
Вобщем вот код, подскажите где не так
Запускать процедуру test
'
Public Function GetMainLayer(sLayer) As ILayer
Dim pSxDoc As ISxDocument
Dim i As Integer
Dim pLayers As IEnumLayer
Dim pLayer As ILayer
On Error GoTo GetLayer_Err
If IsNumeric(sLayer) Then
' if numeric index, this is easy:
If TypeOf Application.Document Is ISxDocument Then
Set pSxDoc = Application.Document
Set GetMainLayer = pSxDoc.Scene.Layer(sLayer)
End If
Else
' iterate through document layers looking for a name match:
If TypeOf Application.Document Is ISxDocument Then
Set pSxDoc = Application.Document
Set pLayers = pSxDoc.Scene.Layers
Set pLayer = pLayers.Next
Do While Not pLayer Is Nothing
If UCase(sLayer) = UCase(pLayer.Name) Then
Set GetMainLayer = pLayer
Exit Function
End If
Set pLayer = pLayers.Next
Loop
End If
End If
Exit Function
GetLayer_Err:
End Function
Public Sub RefreshDoc()
On Error GoTo RefreshDoc_ERR
Dim pSxDoc As ISxDocument
Set pSxDoc = Application.Document
pSxDoc.UpdateContents
pSxDoc.Scene.SceneGraph.RefreshViewers
Exit Sub
RefreshDoc_ERR:
Debug.Print "RefreshDocument_ERR: " & err.Description
Debug.Assert 0
End Sub
Public Function OpenShapeFile(ADir As String, AName As String) As IFeatureClass
Dim pWSFact As IWorkspaceFactory
Dim connectionProperties As IPropertySet
Dim pShapeWS As IFeatureWorkspace
Dim isShapeWS As Boolean
Set OpenShapeFile = Nothing
Set pWSFact = New ShapefileWorkspaceFactory
isShapeWS = pWSFact.IsWorkspace(ADir)
If (isShapeWS) Then
On Error GoTo errhandler
Set connectionProperties = New PropertySet
connectionProperties.SetProperty "DATABASE", ADir
Set pShapeWS = pWSFact.Open(connectionProperties, 0)
Dim pFClass As IFeatureClass
Set pFClass = pShapeWS.OpenFeatureClass(AName)
Set OpenShapeFile = pFClass
End If
errhandler:
End Function
Public Function LoadLayer(ALayerName As String, ADir As String, AFileName As String, AGroupLayer As IGroupLayer) As ILayer
Dim pSxDoc As ISxDocument
Set pSxDoc = ThisDocument
Dim pFC As IFeatureClass
Set pFC = OpenShapeFile(ADir, AFileName)
' Create a layer from the shapefile and add it to scene:
Dim pLayer As IFeatureLayer
Set pLayer = New FeatureLayer
Set pLayer.FeatureClass = pFC
pLayer.Name = ALayerName
If AGroupLayer Is Nothing Then
pSxDoc.Scene.AddLayer pLayer, True
Else
AGroupLayer.Add pLayer
End If
Set LoadLayer = pLayer
End Function
Public Sub test()
Dim ll As ILayer
Set ll = LoadLayer("Wall", "D:\Temp\Cad\Source\shp", "Wall 0_00_lyr", GetMainLayer("Отметка -0.00"))
RefreshDoc
End Sub
