---

Salü zusammen.

Bin auf der Suche nach einem Makro welches über die ganze Datenbank gestartet wird und alle einträge in einem Bestimmten Attribut löscht.

Ich wollte das Makro für die Kabelziele löschen umbauen, so das man einfach nur die Attribut ID eingeben kann und alles was darin eingetragen war entfernt wird.

Attribute währe:

Vorgänger: A10104 und Nachfolger: 473

Ausschlagebender Punkt ist, dass diese Attribute durch neue Formelattribute ersetzt wurden aber nicht aus der Typendefinition des Blattes entfernt werden können da sie noch voll sind. Das möchte ich über ein Makro lösen, da es doch an die 50 Projekte sind die sonst per Arbeitsblatt geändert werden müssten.

Wer kann da weiter helfen?

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hi Badger

Hier der Code(kursiv) für das entsprechende Makro

Public Sub ForAllSelectedProjects()

For lPj = 1 To Application.Selection.Count
    If Application.Selection(lPj).Kind = aucObjProject Then
        handleproject Application.Selection(lPj)
    End If
Next

End Sub

Private Sub handleproject(oPj As Project)
Dim oWks As Worksheet
Dim oSheet As ObjectItem
Dim lSheet As Long
Set oWks = oPj.DrawingsFolder.OpenWorksheetDirect(aucObjSheet, 0, aucCondEqual, "", 473, 10104)

For lSheet = 1 To oWks.RowCount
    If Len(oWks.GetText(lSheet, 1)) <> 0 Or Len(oWks.GetText(lSheet, 2)) <> 0 Then
        Set oSheet = oWks.GetObjectItem(lSheet)
        If Len(oWks.GetText(lSheet, 1)) <> 0 Then
            oSheet.Attributes.ItemByID(473).EmptyValue = True
        End If
        If Len(oWks.GetText(lSheet, 2)) <> 0 Then
            oSheet.Attributes.ItemByID(10104).EmptyValue = True
        End If
        oSheet.Store
    End If
Next

End Sub

greetings
Fask

------------------
Um ein tadelloses Mitglied einer Schafherde sein zu können, muss man vor allem ein Schaf sein! (A. Einstein)

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Merci.

Zitat:

---

Set oWks = oPj.DrawingsFolder.OpenWorksheetDirect(aucObjSheet, 0, aucCondEqual, "", 473, 10104)

---

Hat mir gefehlt, den Rest habe ich aus dem Makro mit den Drahtzielen abgeleitet.
Das Makro kann man nun verwenden um alle Attribute zu leren die bei

Zitat:

---

Set oWks = oPj.DrawingsFolder.OpenWorksheetDirect(aucObjSheet, 0, aucCondEqual, "", ****)

---

als **** eingetragen werden.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Fehler beim kompilieren:

For lPj = 1 To Application.Selection.Count
Variabel ist nicht definiert.

Müsste noch definiert werden.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Der Code müsste so aussehen:
Public Sub ForAllSelectedProjects()

Dim lPj As Long

For lPj = 1 To Application.Selection.Count
    If Application.Selection(lPj).Kind = aucObjProject Then
        handleproject Application.Selection(lPj)
    End If
Next

End Sub

Private Sub handleproject(oPj As Project)
Dim oWks As Worksheet
Dim oSheet As ObjectItem
Dim lSheet As Long
Set oWks = oPj.DrawingsFolder.OpenWorksheetDirect(aucObjSheet, 0, aucCondEqual, "", 473, 10104)

For lSheet = 1 To oWks.RowCount
    If Len(oWks.GetText(lSheet, 1)) <> 0 Or Len(oWks.GetText(lSheet, 2)) <> 0 Then
        Set oSheet = oWks.GetObjectItem(lSheet)
        If Len(oWks.GetText(lSheet, 1)) <> 0 Then
            oSheet.Attributes.ItemByID(473).EmptyValue = True
        End If
        If Len(oWks.GetText(lSheet, 2)) <> 0 Then
            oSheet.Attributes.ItemByID(10104).EmptyValue = True
        End If
        oSheet.Store
    End If
Next

End Sub

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

So wie ich oben beschriebenhabe funktioniert es einwandfrei.
Variabel lPj muss noch definiert werden als Long damit die Prozedur abhängig von der Objektzahl wiederholt wird.

Allerdings kommt es wenn man zu viele Objekte bearbeiten muss dass der EB Prozess an die 1,5 GB Grenze läuft.
In diesem Zusammenhang erzeugt VBA einen Absturz.

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP