Modification d\'un bloc existant...

[sechanbask]

[résolu]

 

Bonjour,

Je souhaiterais modifier un bloc déjà existant, je souhaiterais changer de propriété et de calque quelques entités, mais je ne sais pas comment naviguer dans les entités de mon bloc... J'ai trouvé

 

Sub Impact_circulaire()


Dim objCercle As AcadObject
Dim objBloc As AcadBlockReference
Dim varPins As Variant
Dim strUnitvar As String
Dim sngCoef As Single
Dim dblteta As Double
Dim teta As Double
Dim dbldiamech As Double
Dim SngCalo As Single
Dim dblDiametre As Double
Dim objLine As acadline
Dim objLine1 As acadline

Dim varPinsLineH(0 To 2) As Double
Dim varPinsLineH1(0 To 2) As Double
Dim varPinsLineV(0 To 2) As Double
Dim varPinsLineV1(0 To 2) As Double

Dim strCalqueActive As String
Dim newlayer As AcadLayer

'On Error GoTo Gestion

strCalqueActive = ThisDrawing.ActiveLayer.Name
Set newlayer = ThisDrawing.layers.Add(strCalqueActive & "-A")
Set newlayer = ThisDrawing.layers.Add(strCalqueActive & "-calo")
strUnitvar = ThisDrawing.GetVariable("INSUNITS")

Select Case strUnitvar

Case 4
'(millimètre)
sngCoef = 1
Case 5
'(centimètre)
sngCoef = 0.1
Case 6
'(mètre)
sngCoef = 0.001
End Select


'On Error Resume Next

dblDiametre = ThisDrawing.Utility.GetReal("Veuillez indiquer le diamètre de la gaine en mm : (ou le diamètre précédent: Ø" & dblDiametrePrec & ")")

Select Case Err.Number
Case -2145320928
dblDiametre = dblDiametrePrec
Err.Clear
Case -2147352567
ThisDrawing.Utility.Prompt "Annulée par l'utilisateur."
Err.Clear
Exit Sub
Case Is <> 0
Debug.Print Err.Number, Err.Description
Err.Clear
ThisDrawing.Utility.Prompt "Une erreur inconnue est survenue, veuillez contacter le développeur."
Exit Sub
End Select
'On Error GoTo Gestion

dblDiametrePrec = dblDiametre

dbldiamech = sngCoef * dblDiametre
dblDiametre = dbldiamech / 2




varPins = ThisDrawing.Utility.GetPoint(, "Veuillez choisir un point : ")

teta = 0



Set objBloc = ThisDrawing.ModelSpace.InsertBlock(varPins, "Sect_circ_bloc.dwg", dbldiamech#, dbldiamech#, dbldiamech#, teta)

objBloc.GetExtensionDictionary
Dim explodedObjects As Variant
   explodedObjects = objBloc.Explode

   ' Loop through the exploded objects
   Dim I As Integer
   For I = 0 To UBound(explodedObjects)
       explodedObjects(I).Layer = strCalqueActive
       explodedObjects(I).color = acByLayer
      
       
       Dim ent As AcadEntity
       Dim objBlock As AcadBlock
       Set objBlock = ThisDrawing.Blocks.Item(explodedObjects(I).Name)
       
       For Each ent In objBlock
       Debug.Print ent.ObjectName
           Select Case ent.ObjectName
           
           Case "AcDbLine"
           ent.Layer = strCalqueActive & "-A"
           ent.Update
           End Select
       explodedObjects(I).Update
       Next

       Next


objBloc.Delete

   Dim keyWord As String
   
   ThisDrawing.Utility.InitializeUserInput 0, "Avec Sans"
   keyWord = ThisDrawing.Utility.GetKeyword(vbCrLf & "Entrer une option (/Sans) calo: ")
   
   Select Case keyWord
   Case "s", "S", "sans", "Sans"
   Case "", "a", "A", "avec", "Avec"
   'On Error Resume Next
   SngCalo = ThisDrawing.Utility.GetReal("Veuillez indiquer l'épaisseur du calo en mm : (ou calo précédent " & SngCaloPrec & "mm)")
   Select Case Err.Number
   Case -2145320928
   SngCalo = SngCaloPrec
   Err.Clear
   Case -2147352567
   Err.Clear
   ThisDrawing.Utility.Prompt "Annulée par l'utilisateur."
   Exit Sub
   Case Is <> 0
   Debug.Print Err.Number, Err.Description
   Err.Clear
   ThisDrawing.Utility.Prompt "Une erreur inconnue est survenue, veuillez contacter le développeur."
   Exit Sub
   End Select
   'On Error GoTo Gestion
       
   
   
   
   SngCaloPrec = SngCalo
   Dim varDecalage As Variant
   Set objCercle = ThisDrawing.ModelSpace.AddCircle(varPins, dblDiametre + (SngCalo * sngCoef))
   With objCercle
   .Layer = strCalqueActive & "-calo"
   .color = acByLayer
   .Update
   End With
   
    '   For I = 0 To UBound(varDecalage)
     '  varDecalage(I).Layer = strCalqueActive & "-calo"
      ' varDecalage(I).color = acByLayer
       'varDecalage(I).Update
       'Next
   
   
   End Select


Exit Sub
Gestion:

Select Case Err.Number
  Case "-2147352567"
  ThisDrawing.Utility.Prompt "Annulée par l'utilisateur."
  Case Else
  Debug.Print Err.Number, Err.Description
  ThisDrawing.Utility.Prompt "Une erreur inconnue est survenue, veuillez contacter le développeur."
  End Select
  
  
End Sub

 

 

J'arrive à insérer un bloc sur un plan. Ce bloc est en fait un fichier qui contient uniquement le bloc "section_circulaire".

Lorsque j'insère ce bloc sur mon plan, l'objet inséré devient un bloc (que l'on va appelé "bloc B") qui contient le bloc "section_circulaire". Pour ne pas garder de bloc imbriqués, j'explose "bloc B", je navigue dans les objets explosés : je trouve uniquement mon "section_circulaire" et je le change de calque, je lui attribue la couleur DUCALQUE, et je navigue dans les entités du bloc pour modifier le calque des entité "ligne" et finalement, je supprime l'objet bloc B".

 

[Edité le 9/10/2007 par sechanbask]

 

[Edité le 13/10/2007 par sechanbask]

[LUDWIG]

sacré code !