*VBA CODE FOR EXCEL TO INSERT BLOCKS IN AUTOCAD

[Anonymous]

Hi all,

I am currently working with a VBA code developed by someone that allows to insert blocks from excel. I was wondering if it could be modified to change dynamic visual state of block and write in to their tag values too. I am working with 1000+ blocks but all of them have same tag names ( PN_1-5 & DES_1-5).

The current code works based on this metheod 

RetVal = object.InsertBlock(InsertionPoint, BlockName, Xscale, Yscale, ZScale, RotationAngle)

I have attached the excel and sample blocks with this post.

Thanks

Kuldeep

[leoroncetti]

This is what i use to insert blocks, set attributes and dyn properties.

Public Function Insere_Bloco( _
ByVal nome_bloco As String, _
ByRef pins As Variant, _
Optional ByVal escala_X As Double = 1, _
Optional ByVal escala_Y As Double = 1, _
Optional ByVal escala_Z As Double = 1, _
Optional ByVal angulo_Eixo_Z As Double = 0, _
Optional ByVal layer As String = vbNullString, _
Optional ByVal Atributos As Variant, _
Optional ByVal angulo_plano_XY As Double = 0, _
Optional ByVal valores_bloco_dinamico As Variant) As AcadBlockReference
'-----------------------------------------------------------------------------------------------------------------------
'Criação: 15/01/2001
'Descrição: Insere um bloco ou arquivo no desenho atual
'
'Folhas:
'
'Parâmetros: nome_bloco Nome do bloco ou do arquivo (usar a extensão ".dwg" no caso de arquivo)
' pins Ponto de inserção do bloco
' Layer Layer na qual o bloco será inserido. Caso a layer não exista,
' esta será criada antes da inserção. Para inserir o bloco na
' layer corrente, a string Layer deve ser vazia (vbnullstring)
' angulo_eixo_Z Ângulo de rotação do bloco em relação ao eixo Z [graus]
' angulo_plano_XY Ângulo de rotação do bloco em relação ao plano XY [graus]
'
'Retorno: Nenhum
'
'Observação: 1) Cabe à função que chamou este procedimento, que retorne à aplicação ativa
' pois antes deste procedimento se executado, o foco é voltado para o Autocad
' 2) Os valores são convertidos para strings e as vírgulas são substituídas por pontos
'-----------------------------------------------------------------------------------------------------------------------
'Data Alteração: Autor: Grau de Otimização: Tratamento de Erro:
' 21/11/2004 Leonardo Roncetti Nenhum Nenhum
'-----------------------------------------------------------------------------------------------------------------------
Dim espaco As Object
Dim i As Integer '' Contador para o For
Dim j As Integer '' Contador para o For
Dim objAtributos As Variant
Dim objBloco As AcadBlockReference
Dim ptRot(x To Z) As Double

Dim objUCS As AcadUCS

'' Seleciona em que espaço será inserido o bloco
If GetVar("TILEMODE") = 1 Then Set espaco = acadDoc.ModelSpace Else Set espaco = acadDoc.PaperSpace

Set objBloco = espaco.InsertBlock(pins, nome_bloco, escala_X, escala_Y, escala_Z, mat.radianos(angulo_Eixo_Z))
If Len(layer) > 0 Then objBloco.layer = layer

''Set objUCS = acadDoc.ActiveUCS

''Call WCS2UCS(objBloco)

'' Rotação do bloco no plano XY
If angulo_plano_XY <> 0 Then
Call delta(pins, ptRot, 100, 0, 0)
Call objBloco.Rotate3D(pins, ptRot, mat.radianos(angulo_plano_XY))
End If

'' Atributos
If objBloco.HasAttributes And Not IsMissing(Atributos) Then
objAtributos = objBloco.GetAttributes
For j = LBound(objAtributos) To UBound(objAtributos)
For i = 0 To UBound(Atributos, 2)
If UCase$(Atributos(0, i)) = UCase$(objAtributos(j).TagString) Then
If Len(Atributos(1, i)) > 0 Then objAtributos(j).TextString = IIf(Right$(Atributos(1, i), 1) = ",", Left$(Atributos(1, i), Len(Atributos(1, i)) - 1), Atributos(1, i))
Exit For
End If
Next
Next
End If

'' Valores bloco dinâmico
If objBloco.IsDynamicBlock And Not IsMissing(valores_bloco_dinamico) Then
For j = LBound(valores_bloco_dinamico, 2) To UBound(valores_bloco_dinamico, 2)
Call Altera_Propriedade_BDyn(objBloco, valores_bloco_dinamico(0, j), valores_bloco_dinamico(1, j))
Next
End If

If Len(layer) > 0 Then objBloco.layer = layer

Set Insere_Bloco = objBloco
End Function