no consigo modificar atributos bloques existentes en dwg
Publicado por Enrique Larrosa (1 intervención) el 14/02/2013 14:11:14
Hola a todos
Primero decir que al ser nuevo en el foro, no se si esta forma de proceder es la habitual.
Explicación del problema.
Tengo un plano autocad 2009 con 49 bloques con 8 atributos cada uno. los bloques son el mismo y cuando haces un list puedes ver que cambia el identificador.
donde estoy
1 he creado una macro VBA que se ejecuta desde un icono creado en una barra de herramientas nueva del autocad.
2 la macro abre un fichero excel 2007 de donde deben cogerse los datos.
3 he creado un array donde estan todos los identificadores de los bloques en orden de arriba a abajo.
4 no consigo escojer cada bloque para modificarlo (estoy usando un SelectionSet
5 no consigo modificar los atributos del bloque (estoy usando TagString y un TextString)
6 no consigo que me cree un fichero autocad para cada hoja que posee el fichero excel(solo crea el primero)
¿hay alguna forma de adjuntar los ficheros autocad - excel ?
Adjunto codigo macro VBA.
Agradezco de antemano la colaboración a todos. para poder solucionar el problema porque me urge .
No dudeis em preguntarme cualquier aclaración o duda.
Gracias
'================================
'zona variables
'================================
Public ExcelApp As Excel.Application
Public Wrkbook As Excel.Workbooks
Public Wrksheet As Excel.Worksheet
Dim ss As AutoCAD.AcadSelectionSet
Dim StrNomBlock As String
Dim nomBlockArray() As String
'Dim nomBlock As String
Dim contadorFullesExcel As Variant
'Dim mspace As AcadModelSpace
Dim ssetObj As AcadSelectionSet
Dim acEntidad As Object
'Dim acEntidad As AcadEntity
Dim acadBlkRef As AcadBlockReference
Dim acblock As acadblock
Dim varAttributes As Variant
Dim numDWG As String
Public Sub CreanomBlockArray()
StrNomBlock = "5e4/5da/c57/c61/c6b/c75/c7f/c89/c93/c9d/ca7/cb1/cbb/cc5/ccf/cd9/ce3/ced/cf7/d01/d0b/d15/d1f/d29/d33/"
StrNomBlock = StrNomBlock + "d3d/d47/d51/d5b/d65/d6f/d79/d83/d8d/d97/da1/dab/db5/dbf/dc9/dd3/ddd/de8/df1/dfc/e06/e10/e1a/e23"
'convertimos contenido string a Array siendo el valor de cada posición el que hay entre el separador /
nomBlockArray = Split(StrNomBlock, "/")
End Sub
Function ExcelConnect()
' This function connects excel with autocad
On Error Resume Next
Set ExcelApp = GetObject(, "Excel.Application")
If Err Then
Err.Clear
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = True
If Err Then
MsgBox Err.Description
Exit Function
End If
End If
End Function
Function ExcelClose()
'cerramos fichero Excel
Application.DisplayAlerts = False
Application.Quit
' cierra conexion entre Autocad y excel
Set ExcelApp = Nothing
End Function
Function GetCellValue(row As Integer, column As Integer) As Variant
' This function returns the value of a given cell in excel.
GetCellValue = ExcelApp.ActiveSheet.Cells(row, column).Value
End Function
Public Sub CreaStocklist()
'Set mspace = ThisDrawing.ModelSpace
ExcelConnect
CreanomBlockArray
Workbooks.Open FileName:="C:\dwg\Stocklist_MK135634_MC_L.xlsx"
contadorFullesExcel = ActiveWorkbook.Worksheets.Count
For numFullaExcel = 1 To contadorFullesExcel
Set Wrksheet = Excel.Worksheets("hoja" & CStr(numFullaExcel))
If numFullaExcel = 1 Then
numDWG = "033" 'valor cogido formulario
Else
numDWG = "0" & CStr(Val(numDWG) + 1)
End If
'Set ssetObj = AutoCAD.ActiveDocument.SelectionSets.Add ("SS01")
Set ssetObj = ThisDrawing.SelectionSets.Add("SS01")
For recorrer = LBound(nomBlockArray) To UBound(nomBlockArray)
For Each acEntidad In ssetObj
'If acEntidad.EntityType = acBlockReference And acEntidad.Name = nomBlockArray(recorrer) Then
If acEntidad.Name = nomBlockArray(recorrer) Then
Set acadBlkRef = acEntidad
'como estoy modificando atributos hago una funcion
acadBlkRef = OmplirBlock(acadBlkRef, recorrer)
End If
Next acEntidad
Next recorrer
'vaciamos y borramos el objeto SelectionSet para cada plano Autocad
ssetObj.Clear
ssetObj.Erase
'For Each nomBlock In nomBlockArray
' For row = 1 To 1
' Set block1 = ThisDrawing.Blocks.Item(CStr(nomBlock))
' For column = 1 To 7
' MsgBox Wrksheet.Cells(row, column).Value
'block1(column) = Wrksheet.Cells(row, column)
' Next column
'Next nomBlock
' Next row
ThisDrawing.Regen (acActiveViewport)
AutoCAD.AcadApplication.ZoomExtents
ThisDrawing.SaveAs (numDWG)
AutoCAD.ActiveDocument.Close
Next numFullaExcel
ActiveWindow.Close
Workbooks.Close
ExcelClose
End Sub
Public Function OmplirBlock(ByRef acadBlkRef As AcadBlockReference, ByRef recorrer As Variant) As AcadBlockReference
varAttributes = acadBlkRef.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
If varAttributes(i).TagString = "DETAIL" Then
varAttributes(i).TextString = "1" 'GetCellValue(recorrer,i)
ElseIf varAttributes(i).TagString = "NOUM" Then
varAttributes(i).TextString = "2" 'GetCellValue(recorrer,i)
ElseIf varAttributes(i).TagString = "SHT" Then
varAttributes(i).TextString = "3" 'GetCellValue(recorrer,i)
ElseIf varAttributes(i).TagString = "Q/S" Then
varAttributes(i).TextString = "4" 'GetCellValue(recorrer,i)
ElseIf varAttributes(i).TagString = "MAT" Then
varAttributes(i).TextString = "5" 'GetCellValue(recorrer,i)
ElseIf varAttributes(i).TagString = "MPN" Then
varAttributes(i).TextString = "6" 'GetCellValue(recorrer,i)
ElseIf varAttributes(i).TagString = "DESC/STK" Then
varAttributes(i).TextString = "7" 'GetCellValue(recorrer,i)
ElseIf varAttributes(i).TagString = "PART" Then
varAttributes(i).TextString = "8" 'GetCellValue(recorrer,i)
End If
Next i
End Function
Primero decir que al ser nuevo en el foro, no se si esta forma de proceder es la habitual.
Explicación del problema.
Tengo un plano autocad 2009 con 49 bloques con 8 atributos cada uno. los bloques son el mismo y cuando haces un list puedes ver que cambia el identificador.
donde estoy
1 he creado una macro VBA que se ejecuta desde un icono creado en una barra de herramientas nueva del autocad.
2 la macro abre un fichero excel 2007 de donde deben cogerse los datos.
3 he creado un array donde estan todos los identificadores de los bloques en orden de arriba a abajo.
4 no consigo escojer cada bloque para modificarlo (estoy usando un SelectionSet
5 no consigo modificar los atributos del bloque (estoy usando TagString y un TextString)
6 no consigo que me cree un fichero autocad para cada hoja que posee el fichero excel(solo crea el primero)
¿hay alguna forma de adjuntar los ficheros autocad - excel ?
Adjunto codigo macro VBA.
Agradezco de antemano la colaboración a todos. para poder solucionar el problema porque me urge .
No dudeis em preguntarme cualquier aclaración o duda.
Gracias
'================================
'zona variables
'================================
Public ExcelApp As Excel.Application
Public Wrkbook As Excel.Workbooks
Public Wrksheet As Excel.Worksheet
Dim ss As AutoCAD.AcadSelectionSet
Dim StrNomBlock As String
Dim nomBlockArray() As String
'Dim nomBlock As String
Dim contadorFullesExcel As Variant
'Dim mspace As AcadModelSpace
Dim ssetObj As AcadSelectionSet
Dim acEntidad As Object
'Dim acEntidad As AcadEntity
Dim acadBlkRef As AcadBlockReference
Dim acblock As acadblock
Dim varAttributes As Variant
Dim numDWG As String
Public Sub CreanomBlockArray()
StrNomBlock = "5e4/5da/c57/c61/c6b/c75/c7f/c89/c93/c9d/ca7/cb1/cbb/cc5/ccf/cd9/ce3/ced/cf7/d01/d0b/d15/d1f/d29/d33/"
StrNomBlock = StrNomBlock + "d3d/d47/d51/d5b/d65/d6f/d79/d83/d8d/d97/da1/dab/db5/dbf/dc9/dd3/ddd/de8/df1/dfc/e06/e10/e1a/e23"
'convertimos contenido string a Array siendo el valor de cada posición el que hay entre el separador /
nomBlockArray = Split(StrNomBlock, "/")
End Sub
Function ExcelConnect()
' This function connects excel with autocad
On Error Resume Next
Set ExcelApp = GetObject(, "Excel.Application")
If Err Then
Err.Clear
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = True
If Err Then
MsgBox Err.Description
Exit Function
End If
End If
End Function
Function ExcelClose()
'cerramos fichero Excel
Application.DisplayAlerts = False
Application.Quit
' cierra conexion entre Autocad y excel
Set ExcelApp = Nothing
End Function
Function GetCellValue(row As Integer, column As Integer) As Variant
' This function returns the value of a given cell in excel.
GetCellValue = ExcelApp.ActiveSheet.Cells(row, column).Value
End Function
Public Sub CreaStocklist()
'Set mspace = ThisDrawing.ModelSpace
ExcelConnect
CreanomBlockArray
Workbooks.Open FileName:="C:\dwg\Stocklist_MK135634_MC_L.xlsx"
contadorFullesExcel = ActiveWorkbook.Worksheets.Count
For numFullaExcel = 1 To contadorFullesExcel
Set Wrksheet = Excel.Worksheets("hoja" & CStr(numFullaExcel))
If numFullaExcel = 1 Then
numDWG = "033" 'valor cogido formulario
Else
numDWG = "0" & CStr(Val(numDWG) + 1)
End If
'Set ssetObj = AutoCAD.ActiveDocument.SelectionSets.Add ("SS01")
Set ssetObj = ThisDrawing.SelectionSets.Add("SS01")
For recorrer = LBound(nomBlockArray) To UBound(nomBlockArray)
For Each acEntidad In ssetObj
'If acEntidad.EntityType = acBlockReference And acEntidad.Name = nomBlockArray(recorrer) Then
If acEntidad.Name = nomBlockArray(recorrer) Then
Set acadBlkRef = acEntidad
'como estoy modificando atributos hago una funcion
acadBlkRef = OmplirBlock(acadBlkRef, recorrer)
End If
Next acEntidad
Next recorrer
'vaciamos y borramos el objeto SelectionSet para cada plano Autocad
ssetObj.Clear
ssetObj.Erase
'For Each nomBlock In nomBlockArray
' For row = 1 To 1
' Set block1 = ThisDrawing.Blocks.Item(CStr(nomBlock))
' For column = 1 To 7
' MsgBox Wrksheet.Cells(row, column).Value
'block1(column) = Wrksheet.Cells(row, column)
' Next column
'Next nomBlock
' Next row
ThisDrawing.Regen (acActiveViewport)
AutoCAD.AcadApplication.ZoomExtents
ThisDrawing.SaveAs (numDWG)
AutoCAD.ActiveDocument.Close
Next numFullaExcel
ActiveWindow.Close
Workbooks.Close
ExcelClose
End Sub
Public Function OmplirBlock(ByRef acadBlkRef As AcadBlockReference, ByRef recorrer As Variant) As AcadBlockReference
varAttributes = acadBlkRef.GetAttributes
For i = LBound(varAttributes) To UBound(varAttributes)
If varAttributes(i).TagString = "DETAIL" Then
varAttributes(i).TextString = "1" 'GetCellValue(recorrer,i)
ElseIf varAttributes(i).TagString = "NOUM" Then
varAttributes(i).TextString = "2" 'GetCellValue(recorrer,i)
ElseIf varAttributes(i).TagString = "SHT" Then
varAttributes(i).TextString = "3" 'GetCellValue(recorrer,i)
ElseIf varAttributes(i).TagString = "Q/S" Then
varAttributes(i).TextString = "4" 'GetCellValue(recorrer,i)
ElseIf varAttributes(i).TagString = "MAT" Then
varAttributes(i).TextString = "5" 'GetCellValue(recorrer,i)
ElseIf varAttributes(i).TagString = "MPN" Then
varAttributes(i).TextString = "6" 'GetCellValue(recorrer,i)
ElseIf varAttributes(i).TagString = "DESC/STK" Then
varAttributes(i).TextString = "7" 'GetCellValue(recorrer,i)
ElseIf varAttributes(i).TagString = "PART" Then
varAttributes(i).TextString = "8" 'GetCellValue(recorrer,i)
End If
Next i
End Function
Valora esta pregunta
0