Ucs origin verplaatsen via vba

[Kev.]

Alweer een probleemke dat ik na x - aantal uren zoeken niet vind

Ik wil mijn ucs origin verplaatsen via de vba maar ik kan nergens vinden hoe ik dat moet doen. Kan er hierbij iemand helpen aub?

Mvg
Kev.

[Kev.]

kdenk een oplossing gevonden te hebben,  alleen werkt ze nog nie 

Ipv van mijn ucs origin te verplaatsen tov mijn tekening verplaats ik nu mijn tekening tov mijn ucs origin.
Ik heb al het een en ander gezocht en gevonden maar toch zit er nog ergens een fout in dat ik niet vind.

Mijn vba code vind je hier:

Private Sub Move_Click()
    Dim ssetOb As AcadObject
    Set ssetOb = ThisDrawing.SelectionSets.Add("ssetje")

           
   
    Dim ssetje As Integer
   
    ssetje = acSelectionSetAll
   
    Dim punt1(1 To 3) As Double
    Dim punt2(1 To 3) As Double
    punt1(1) = 0: punt2(1) = 0
    punt1(2) = 0: punt2(2) = Val(Txt2) + 500

    ssetje.Move punt1, punt2
    ssetje.Delete
   
End Sub

iemand die mijn fout vind??

Mvg
Kev.

[Steven]

Dit zou moeten werken:

Code Selecteer Uitklappen

Private Sub Move_Click()

Dim ssetOb As AcadSelectionSet
Dim Obj As AcadEntity

On Error Resume Next
Set ssetOb = ThisDrawing.SelectionSets.Item("ssetje")
If Err Then
Set ssetOb = ThisDrawing.SelectionSets.Add("ssetje")
Err.Clear
Else
ssetOb.Clear
End If
   
ssetOb.Select acSelectionSetAll

Dim punt1(1 To 3) As Double
Dim punt2(1 To 3) As Double
punt1(1) = 0: punt2(1) = 0
punt1(2) = 0: punt2(2) = Val(Txt2) + 500

For Each Obj In ssetOb

    Obj.Move punt1, punt2
   
Next

ssetOb.Delete

End Sub

Hopelijk ben je er iets mee.

Groeten.

[Kev.]

Dankt u, het werkt perfect!

Als ik u ooit kan helpen...

Groeten
Kev.

[Joop]

Het visuele resultaat van het vorige programmaatje is wat je wilt.
Maar alle koppelingen met de oorsprong zijn verschoven.
Levert dit geen probleem op met bv plotten en associatief dimensioneren?
Het tekenen met absolute coordinaten kun je nu ook wel vergeten!

Dit is dus wel een oplossing maar niet echt de goede.

Heb je al eens gekeken naar de gegevens van de UCS zoals die opgeslagen zijn in de tekening?
Deze zijn met VBA eenvoudig te wijzigen.

[Kev.]

Wat de koppelingen en het associatief dimensoineren betreft, ik heb het niet nodig bij het tekenen van mijn objecten.

Voor het plotten zie ik geen problemen, ik ben nu bezig met een vba programma te schrijven voor snel en eenvoudig: mijn page setup te doen, titelblad te importeren en mijn titleblad in te vullen.
Volgens mij zullen die bewerkeningen geen hinder ondervinden van het vorige vba programma.

Tips en opmerkingen zijn altijd welkom 


mvg
kev

[Steven]

Dit is dus wel een oplossing maar niet echt de goede.

Heb je al eens gekeken naar de gegevens van de UCS zoals die opgeslagen zijn in de tekening?
Deze zijn met VBA eenvoudig te wijzigen.

Misschien is dit beter:

Code Selecteer Uitklappen


Sub Move_UCS()
   
    Dim Ucs As AcadUCS
   
    origin = ThisDrawing.Utility.GetPoint(, "Duid de oorsprong aan: ")
   
    xAxisPnt = ThisDrawing.Utility.GetPoint(, "Duid een punt op de X-as aan: ")
    yAxisPnt = ThisDrawing.Utility.GetPoint(, "Duid een punt op de Y-as aan: ")
   
   
    Set Ucs = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPnt, yAxisPnt, "NEW_UCS")
   
    ThisDrawing.ActiveViewport.UCSIconAtOrigin = True
    ThisDrawing.ActiveViewport.UCSIconOn = True
    ThisDrawing.ActiveUCS = Ucs
   
End Sub