Help, Read and Modify Atributos con basic 6 o vb.net

[DrInfierno]

Hola amigos de Autodesk, deseria poder leer los atributos de los bloques y tambien modificarlos

con visual basic 6, tengo varias archivos ,dwg y hay muchos bloques con sus respectivos atributos

los cuales quiero modfiicar manualmente, tengo el Autocad 2012 en español espero me puesan ayudar!!!

Luis Tomasto

SistemasIntegralesTomasto@hotmail.com

[Hallex]

I'm not sure if this works in A2012

You may want to try it:

'--------------Code start--------------------

Option Explicit

' ! request references:
' 1. - Microsoft Shell Controls And Automation
' 2. - Windows Script Host Object Model
' 3. - Microsoft Scripting RunTime
' 4. - AutoCAD/ObjectDBX Common XX.X Library !
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, _
ByVal pszPath As String) As Long
 
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long
 
Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
 
 '-------------------------------------------------------------
Function GetFolder(Optional ByVal Name As String = _
    "Select a folder.") As String
     '-------------------------------------------------------------
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim oDialog As Long
    
    bInfo.pidlRoot = 0& 'Root folder = Desktop
    
    bInfo.lpszTitle = Name
    
    bInfo.ulFlags = &H1 'Type of directory to Return
    oDialog = SHBrowseForFolder(bInfo) 'display the dialog
    
     'Parse the result
    path = Space$(512)
    
    GetFolder = ""
    If SHGetPathFromIDList(ByVal oDialog, ByVal path) Then
        GetFolder = Left(path, InStr(path, Chr$(0)) - 1) & "\"
    End If
    
End Function

Private Function getFiles(ByVal RootFolder As String, ByRef FileColl As Collection)
Dim fs, f, item, mystring As String
Dim File As Variant, folder As Variant
 
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(RootFolder)
   
 
    For Each File In f.files
        If UCase(Right(File.Name, 4)) = UCase(".dwg") Then
            FileColl.Add File.path
        End If
    Next
   
    For Each folder In f.SubFolders
        Call getFiles(folder, FileColl)
    Next
    
End Function

Private Sub ChangeBlocksDBX(dwgFiles As Collection, blkname As String, atag As String, aValue As String)
    Dim oEnt As AcadEntity
    Dim oBlkRef As AcadBlockReference
    Dim oAtt As AcadAttributeReference
    Dim oBlock As AcadBlock
    Dim oLayout As AcadLayout
   
    Dim vers As Double
    vers = Val(Application.ActiveDocument.GetVariable("acadver"))
    Dim dbxvers As String
    dbxvers = "ObjectDBX.AxDbDocument." & Left(Application.ActiveDocument.GetVariable("acadver"), 2)
   
    Dim dbxDoc As New AxDbDocument
   
    Set dbxDoc = ThisDrawing.Application.GetInterfaceObject(dbxvers)
   
    Dim dwgVar As Variant
   
    On Error Resume Next
   
    For Each dwgVar In dwgFiles
    Dim dwgName As String
    dwgName = CStr(dwgVar)
   
    dbxDoc.Open dwgName
   
    For Each oLayout In dbxDoc.Layouts
   
    For Each oEnt In oLayout.Block
   
    If TypeOf oEnt Is AcadBlockReference Then
    Set oBlkRef = oEnt
   
   
    If oBlkRef.EffectiveName = blkname Then
    Dim attVar As Variant
    attVar = oBlkRef.GetAttributes
    Dim i
    For i = 0 To UBound(attVar)
    Set oAtt = attVar(i)
    If oAtt.TagString = atag Then
    oAtt.TextString = aValue
    Exit For
    End If
    Next i
    End If
    End If
    Next
   
    Next
    dbxDoc.SaveAs dwgName
    Next
   
    On Error Resume Next
    Set dbxDoc = Nothing
   
   
End Sub
Public Sub Hola()
Dim blkname As String
Dim atag As String
Dim attvalue As String
blkname = InputBox("Enter a block name:", "Batch attribute change")
atag = UCase(InputBox("Enter an attribute tag:", "Batch attribute change"))
attvalue = InputBox("Enter a new attribute value:", "Batch attribute change")

    Dim strFolder As String
    Dim item As Variant
    Dim FileColl As Collection
    Set FileColl = New Collection

strFolder = GetFolder("Select directory to change attribute") ', ThisDrawing.GetVariable("dwgprefix"))
If strFolder = "" Then Exit Sub
If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
Call getFiles(strFolder, FileColl)

Call ChangeBlocksDBX(FileColl, blkname, atag, attvalue)

MsgBox "done"
End Sub

'-------------------code end ------------------------------

~'J'~

[DrInfierno]

hi man Problems in...

Set dbxDoc = ThisDrawing.Application.GetInterfaceObject(dbxvers)

THISDRAWING ----> variable no reconocida

[Hallex]

Man,

This code on pure VBA, I just show you the way

You can to convert it on vb.net by yourself

Take a look at this link it may helps:

http://forums.autodesk.com/t5/NET/VBA-to-VB-net/td-p/3275489

See the very last post