Tweet
Hallo VBA-Profis
Ich hoffe, es kann mir hier jemand weiterhelfen. Es geht darum, aus einer Autocad-Zeichnung Informationen in Excel auszulesen, dort zu bearbeiten und wieder in die Zeichnung zurück zu spielen. Dazu wurde ich in einem Autocad-Forum fündig, es hat dort jemand ein xls mit VBA-Script zur Verfügung gestellt.
Die Funktion ist diejenige, dass ab Spalte E Werte aus Zeichnungsobjekten eingefügt werden, solange bis keine Informationen mehr vorhanden sind in den Objekten.
Funktioniert so weit so gut. Das Problem ist, dass bei Spalte Z fertig ist. Es sind jedoch mehr Informationen vorhanden, also der Bedarf wäre bei Spalte AA, AB usw. weiter zu schreiben bis die Bedingung fertig abgearbeitet ist. Was ich bis jetzt herausgefunden habe, ist, dass es wohl an der Bereichsdefinition scheitert.
Hier ein Auszug aus dem Script:
*************************
AppActivate Application.Caption
j = 1
If ssetobj.Count > 0 Then
For i = 0 To ssetobj.Count - 1
Set bl = ssetobj.Item(i)
If bl.HasAttributes = True Then 'Falls der Block Attribute aufweist
Range("A" + Trim(Str(j + 1))).Select
ActiveCell.FormulaR1C1 = acad.ActiveDocument.FullName 'schreib Dateiname in Spalte A
Range("B" + Trim(Str(j + 1))).Select
ActiveCell.FormulaR1C1 = bl.handle 'schreib Blockreferenz in Spalte B
Range("C" + Trim(Str(j + 1))).Select
ActiveCell.FormulaR1C1 = bl.name 'schreib Blockname in Spalte C
Range("D" + Trim(Str(j + 1))).Select
ActiveCell.FormulaR1C1 = bl.Layer 'schreib Layer des Blocks in Spalte D
attr = bl.GetAttributes 'lies die Attribute aus dem Block
z = Asc("E") 'starte Attribute befüllen in Spalte E
'...bis hier funktion i.o.
'...ab hier fehlerhaft (bei Spalte Z ist finito....)
For k = LBound(attr) To UBound(attr)
Range(Chr(z) + Trim(Str(j + 1))).Select
ActiveCell.FormulaR1C1 = attr(k).TagString
z = z + 1
Range(Chr(z) + Trim(Str(j + 1))).Select
ActiveCell.FormulaR1C1 = attr(k).TextString
z = z + 1
Next k
j = j + 1
'ab hier wieder i.o.
Else
MsgBox "Gewählte Blöcke haben keine Attribute!", vbOKOnly, "Meldung"
End If
Next i
Else
MsgBox "Keine Blöcke gewählt!", vbOKOnly, "Meldung"
End If
ssetobj.Delete
*********************************
Hat jemand eine Lösung, wie das abgeändert werden müsste?
Zur Info (für diejenigen die es noch nicht festgestellt haben...): Bin eigentlich "nur" Anwender mit Ideen und probiere, dieses Programm so gut wie möglich lesen zu können.
Besten Dank schon im Voraus für Eure Hilfe
Thomas
(Excel '97, Windows XP Prof. SP2)
Ich hoffe, es kann mir hier jemand weiterhelfen. Es geht darum, aus einer Autocad-Zeichnung Informationen in Excel auszulesen, dort zu bearbeiten und wieder in die Zeichnung zurück zu spielen. Dazu wurde ich in einem Autocad-Forum fündig, es hat dort jemand ein xls mit VBA-Script zur Verfügung gestellt.
Die Funktion ist diejenige, dass ab Spalte E Werte aus Zeichnungsobjekten eingefügt werden, solange bis keine Informationen mehr vorhanden sind in den Objekten.
Funktioniert so weit so gut. Das Problem ist, dass bei Spalte Z fertig ist. Es sind jedoch mehr Informationen vorhanden, also der Bedarf wäre bei Spalte AA, AB usw. weiter zu schreiben bis die Bedingung fertig abgearbeitet ist. Was ich bis jetzt herausgefunden habe, ist, dass es wohl an der Bereichsdefinition scheitert.
Hier ein Auszug aus dem Script:
*************************
AppActivate Application.Caption
j = 1
If ssetobj.Count > 0 Then
For i = 0 To ssetobj.Count - 1
Set bl = ssetobj.Item(i)
If bl.HasAttributes = True Then 'Falls der Block Attribute aufweist
Range("A" + Trim(Str(j + 1))).Select
ActiveCell.FormulaR1C1 = acad.ActiveDocument.FullName 'schreib Dateiname in Spalte A
Range("B" + Trim(Str(j + 1))).Select
ActiveCell.FormulaR1C1 = bl.handle 'schreib Blockreferenz in Spalte B
Range("C" + Trim(Str(j + 1))).Select
ActiveCell.FormulaR1C1 = bl.name 'schreib Blockname in Spalte C
Range("D" + Trim(Str(j + 1))).Select
ActiveCell.FormulaR1C1 = bl.Layer 'schreib Layer des Blocks in Spalte D
attr = bl.GetAttributes 'lies die Attribute aus dem Block
z = Asc("E") 'starte Attribute befüllen in Spalte E
'...bis hier funktion i.o.
'...ab hier fehlerhaft (bei Spalte Z ist finito....)
For k = LBound(attr) To UBound(attr)
Range(Chr(z) + Trim(Str(j + 1))).Select
ActiveCell.FormulaR1C1 = attr(k).TagString
z = z + 1
Range(Chr(z) + Trim(Str(j + 1))).Select
ActiveCell.FormulaR1C1 = attr(k).TextString
z = z + 1
Next k
j = j + 1
'ab hier wieder i.o.
Else
MsgBox "Gewählte Blöcke haben keine Attribute!", vbOKOnly, "Meldung"
End If
Next i
Else
MsgBox "Keine Blöcke gewählt!", vbOKOnly, "Meldung"
End If
ssetobj.Delete
*********************************
Hat jemand eine Lösung, wie das abgeändert werden müsste?
Zur Info (für diejenigen die es noch nicht festgestellt haben...): Bin eigentlich "nur" Anwender mit Ideen und probiere, dieses Programm so gut wie möglich lesen zu können.
Besten Dank schon im Voraus für Eure Hilfe
Thomas
(Excel '97, Windows XP Prof. SP2)