---

Hat jemand schonmal selber ein Makro kreiirt, welches das Drahtziel in das Kabelziel kopiert? Ich habe grösste Probleme mit dem Standart Makro von EB. Dieses macht was es grad Lust hat, überschreibt automatisch vergebene Kabelziele (Aus einpoligen Darstellungen), welchselt aber schonmal eingetragene Ziele nicht mehr aus obwohl die Drahtziele geändert wurden.

Leider ist das Makro abgeschlossen, kann also nicht selber analysiert werden. 

Entweder sollte das Makro nur das Kabelziel schreiben sofern noch nichts eingetragen ist, oder alles überschreiben. 

Hat jemand eine andere Lösung?

Grundproblem: Kabel ist im Schema nicht dargestellt nur Kabel, allerdings nicht alle, gewisse sind nur als Einpolige Kabel im Schema vorhanden und finden ihre Kabelziele als Anschluss (Einpolig)

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

---

Nach dem Update auf 6.4.2 funktioniert das Makro nun überhaupt nicht mehr Richtig. Obwohl die Drahtziele manuell getauscht wurden, Das Kabelziel entfernt, füllt das Makro wieder die alten Kabelziele aus.

Beispiel. Draht Ziel 1 = Extern Ziel 2 = Intern.
Nun tausche ich die Drahtziele manuell (Worksheet rechtsklick Drahtziele tauschen)
Neu Ziel 1 = Intern Ziel 2 = Extern.

Kabel besitzt keine Ziele Ziel 1: leer, Ziel 2: leer

Makro "Kabelziel aus Drahtziel generieren" laufen gelassen

Neu Kabelziel Ziel 1: Extern Ziel 2: Intern

Das Obwohl das Drahtziel getauscht ist.

Beim Makro der Version 6.3.1 hats noch funktioniert.
Testet jemand überhaupt solche Makros bevor das Programm ausgeliefert wird?
Miserabel, bei jedem neuen Update wieder Verschlechterungen.

Hat jemand noch das Makro aus der Version 6.3.1? Oder noch besser das der VBA-Programmcode damit ichs selber anpassen kann?? 

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

---

Ich habe dazu ein eigenes Makro - bin aber noch auf 6.4.0 unterwegs. Auch ist es einiges langsamer als das Aucotec Makro, aber ich benutze es in angepassten Varianten um nur gewisse Objekte als Destinationen zuzulassen...
Du kannst ja mal versuchen ob das unter 6.4.2 besser funktioniert:

Public Sub SetCableDestinations()
  Dim mWireWS As Aucotec.Worksheet
  Dim oCable As Cable
  Dim oLeftSide As ObjectItem
  Dim oRightSide As ObjectItem
  Dim i As Long, k As Long
  Dim oStartItem As ObjectItem
  Dim leftIsOk As Boolean
  Dim rightIsOk As Boolean
  Dim obj As CableDestination
 
  For Each oStartItem In Application.Selection()
   
    Set mWireWS = oStartItem.OpenWorksheetDirect(aucObjCable, aucAttrUnspecified, aucCondEqual, "", aucAttrDesignation)
 
    For i = 1 To mWireWS.RowCount
      leftIsOk = False
      rightIsOk = False
      Set oCable = mWireWS.GetObjectItem(i)
      Set oLeftSide = findCommonParentList(oCable, aucRolePin1Wire)
      Set oRightSide = findCommonParentList(oCable, aucRolePin2Wire)
     
      If Not oLeftSide Is Nothing Or Not oRightSide Is Nothing Then
      For k = 1 To oCable.Destinations.Count
        Set obj = oCable.Destinations.Item(k)
        If Not obj.RelatedObject Is Nothing Then
          If Not obj.RelatedObject.IsDeleted Then
        If obj.ManualEntry Then
          If obj.LeftSide And Not oLeftSide Is Nothing Then
            If obj.RelatedObject.ID <> oLeftSide.ID Then
              Call oCable.Destinations.Remove(k)
            Else
              leftIsOk = True
            End If
          ElseIf Not oRightSide Is Nothing Then
            If obj.RelatedObject.ID <> oRightSide.ID Then
              Call oCable.Destinations.Remove(k)
            Else
              rightIsOk = True
            End If
          End If
        Else
          If obj.LeftSide Then
            leftIsOk = True
          Else
            rightIsOk = True
          End If
        End If
        End If
        End If
      Next k
      End If
        If Not leftIsOk And Not oLeftSide Is Nothing Then Call oCable.Destinations.AddNew(oLeftSide, True)
        If Not rightIsOk And Not oRightSide Is Nothing Then Call oCable.Destinations.AddNew(oRightSide, False)
        oCable.Destinations.Store
    Next i
  Next oStartItem
End Sub

Private Function findCommonParentList(ByRef parent As ObjectItem, ByVal destR As AucRole) As ObjectItem
  Dim dictParent1 As Object 'Scripting.Dictionary
  Dim sProjID As String
  Dim sEqFldID As String
  Dim assocs As Aucotec.Associations
  Dim obj As ObjectItem
  Dim oWires As Aucotec.Worksheet
  Dim oWire As ObjectItem
  Dim i As Long
  Dim oChild As Aucotec.Cable
  Dim dest As Aucotec.CableDestination
 
  Let sProjID = parent.Project.ID
  Let sEqFldID = parent.Project.EquipmentFolder.ID
 
  Set oWires = parent.OpenWorksheetDirectEx(aucObjWire, aucAttrTID, aucCondNotEqual, aucWireScreen, aucWorksheetOpenDeep, aucAttrTID)
 
  For i = 1 To oWires.RowCount
    Set oWire = oWires.GetObjectItem(i)
    If oWire.TypeID <> aucWirePE Then 'exclude PE Wires
    Set assocs = oWire.TargetAssociations.Filter(destR)
   
    If assocs.Count > 0 Then
      Set obj = assocs.Item(1).RelatedObject
      If dictParent1 Is Nothing Then
        'fill the dict with all parents
        Set dictParent1 = CreateObject("Scripting.Dictionary")
        While obj.ID <> sProjID And obj.ID <> sEqFldID
          If obj.Kind = aucObjDevice Or obj.Kind = aucObjLocation Then 'filter for valid destinations
            Call dictParent1.Add(obj.ID, obj.FullName)
            If findCommonParentList Is Nothing Then
              Set findCommonParentList = obj
            End If
          End If
          Set obj = obj.parent
        Wend
      Else
        'search the first common object
        While obj.ID <> sProjID And obj.ID <> sEqFldID And Not dictParent1.Exists(obj.ID)
          Set obj = obj.parent
        Wend
        If obj.ID = sProjID Or obj.ID = sEqFldID Then
          'Debug.Print ("searchCommonParent found no common object!")
          Set findCommonParentList = Nothing
          Exit Function
        End If
        Set findCommonParentList = obj
      End If
    End If
    End If
  Next i
 
  'do the same for cables (cables in cables...)
  For Each oChild In parent.FindObjects(aucObjCable, aucSearchHierarchical)
    For Each dest In oChild.Destinations
      If (destR = aucRolePin1Wire And dest.LeftSide) _
        Or (destR = aucRolePin2Wire And Not dest.LeftSide) Then
        Set obj = dest.RelatedObject
        If Not obj Is Nothing Then
          If Not obj.IsDeleted Then
            If dictParent1 Is Nothing Then
              'fill the dict with all parents
              Set dictParent1 = CreateObject("Scripting.Dictionary")
              While obj.ID <> sProjID And obj.ID <> sEqFldID
                If obj.Kind = aucObjDevice Or obj.Kind = aucObjLocation Then 'filter for valid destinations
                  Call dictParent1.Add(obj.ID, obj.FullName)
                  If findCommonParentList Is Nothing Then
                    Set findCommonParentList = obj
                  End If
                End If
                Set obj = obj.parent
              Wend
            Else
              'search the first common object
              While obj.ID <> sProjID And obj.ID <> sEqFldID And Not dictParent1.Exists(obj.ID)
                Set obj = obj.parent
              Wend
     
              If obj.ID = sProjID Or obj.ID = sEqFldID Then
                'Debug.Print ("searchCommonParent found no common object!")
                Set findCommonParentList = Nothing
                Exit Function
              End If
              Set findCommonParentList = obj
            End If
          End If
        End If
      End If
    Next dest
  Next oChild
End Function

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