---

Hallo an Alle,

ich hab mal wieder ne schwierige Frage.
Ich bräuchte die Koordinaten der linken oberen Ecke des aktuellen Ansichtsfensters im Model-Bereich.
Also die Koordinaten die ich erhalten würde, wenn ich mit der Maus ganz hoch und ganz links fahren würde und dann gerade noch im zeichnungsbereich klicken würde.
Mein Ansatz waren die Systemvariablen VIEWCTR und VIEWSIZE.
Damit hätte ich den Bildschirmmittelpunkt und die Höhe, daraus könnte ich die Y-Koordinate errechnen. Aber wie komm ich auf X?
Hat jemand ne Idee?

Gruß, Theo

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

---

Hallo Theo,

versuchs mal so:

Code:

---

    Set ViewPort = ThisDrawing.ActiveViewport
    Zentrum = ViewPort.Center
    UntenLinks(0) = Zentrum(0) - ViewPort.Width / 2
    UntenLinks(1) = Zentrum(1) - ViewPort.Height / 2
    ObenRechts(0) = Zentrum(0) + ViewPort.Width / 2
    ObenRechts(1) = Zentrum(1) + ViewPort.Height / 2
   
    Debug.Print "Viewport"
    Debug.Print "UntenLinks: ", UntenLinks(0), ",", UntenLinks(1)
    Debug.Print "ObenRechts: ", ObenRechts(0), ",", ObenRechts(1)
    Debug.Print "Zentrum: ", Zentrum(0), ",", Zentrum(1)

---

Was hoch ist kann auch breit sein 
Wilfried Stelberg

------------------
Warum lisp'eln wenn's auch anders geht.
www.ib-stelberg.de

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

---

Danke. Das probier ich mal aus.

Gruß, Theo

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

---

Hallo,

das hat leider nicht geklappt. Das Zentrum von ActiveViewport ist glaube ich die Mitte des Zoombaren-Bereichs. Hat irgendwas mit Limiten zu tun. Ich bräuchte aber das aktuell gezoomte Ansichtsfenster(also der sichtbare Bereich). Also wie es jetzt im Augenblick ist.
Danke für jede Idee.

Gruß, Theo

[Diese Nachricht wurde von Theo37 am 11. Jan. 2012 editiert.]

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

---

Hallo Theo,

das liegt wohl daran das die Werte vom Viewport nicht immer aktuell sind. Wechselt man vom Papier in den Modellbereich wird der aktuelle Viewport aktualisiert.
So geht es

Code:

---

Sub test()

    Dim Untenlinks(0 To 2) As Double
    Dim ObenRechts(0 To 2) As Double
    Dim Zentrum As Variant
    Dim viewport As AcadViewport

    ThisDrawing.ActiveSpace = acPaperSpace
    ThisDrawing.ActiveSpace = acModelSpace
   
    Set viewport = ThisDrawing.ActiveViewport
    Zentrum = viewport.Center
    Untenlinks(0) = Zentrum(0) - viewport.Width / 2
    Untenlinks(1) = Zentrum(1) - viewport.Height / 2
    ObenRechts(0) = Zentrum(0) + viewport.Width / 2
    ObenRechts(1) = Zentrum(1) + viewport.Height / 2
     
    ThisDrawing.Regen acAllViewports
    Debug.Print "Viewport"
    ThisDrawing.Utility.Prompt Chr(10) & "Viewport  " & Format(Time, "HH:MM:SS")
    Debug.Print "UntenLinks: ", Untenlinks(0), "/", Untenlinks(1)
    ThisDrawing.Utility.Prompt Chr(10) & "UntenLinks: " & Untenlinks(0) & "/" & Untenlinks(1)
    Debug.Print "ObenRechts: ", ObenRechts(0), "/", ObenRechts(1)
    ThisDrawing.Utility.Prompt Chr(10) & "ObenRechts: " & ObenRechts(0) & "/" & ObenRechts(1)
    ThisDrawing.Utility.Prompt Chr(10)
    Debug.Print "Zentrum: ", Zentrum(0), ",", Zentrum(1)
End Sub

---

------------------
Warum lisp'eln wenn's auch anders geht.
www.ib-stelberg.de

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

---

Das scheint zu funktionieren. Muß ich probieren.
Danke für Deine Hilfe,
Gruß, Theo

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

---

Hi,

ich wollte mal erklären zu was ich die Bildschirmecke eigentlich brauche. Ich möchte den Befehl "Textexp" aus den Expresstools nachbasteln und dann auf meine Bedürfnisse anpassen. Dazu wird der Text in WMF exportiert und dann wieder importiert. Dazu brauche ich die linke obere Ecke als Einfügepunkt. Soweit klappt der Code unten ganz gut nur die Korrekturfaktoren beim Errechnen der Bildecke sind doof und auch nur anähernd richtig. Hat da jemand noch nee Idee wie man das besser machen könnte? Bin auch für jeden anderen Verbesserungsvorschlag dankbar.

Gruß, Theo

<Autodesk.AutoCAD.Runtime.CommandMethod("Tex")> _
      Sub Tex()
        Dim Myselect As AcadSelectionSet
        Dim Bildecke(2) As Double
        Dim Zentrum(2) As Double
        Dim PunktüberZentrum(2) As Double
        Dim Point(2) As Double
        Dim Mytext As AcadMText
        Dim Mytextmirr As AcadMText
        Dim Viewport As AcadViewport
        Dim Satz() As AcadEntity
        Dim sstext As AcadSelectionSet
        Dim FilterType(3) As Int16
        Dim FilterData(3) As Object
        Dim MyEnti As AcadEntity
        Dim MyEntiMirr As AcadEntity
        Dim i As Integer = 0
        FilterType(0) = -4
        FilterData(0) = "<or"
        FilterType(1) = 0
        FilterData(1) = "TEXT"
        FilterType(2) = 0
        FilterData(2) = "MTEXT"
        FilterType(3) = -4
        FilterData(3) = "or>"

        Myselect = ThisDrawing.SelectionSets.Add("ss2")
        Myselect.SelectOnScreen(FilterType, FilterData)
        If Myselect.Count = 0 Then
            Myselect.Delete()
            MsgBox("Sorry, keine Texte gewählt!", MsgBoxStyle.Critical)
            Exit Sub
        End If
        If ThisDrawing.ActiveLayer.Lock = True Then
            Myselect.Delete()
            MsgBox("Sorry, der aktive Layer ist gesperrt", MsgBoxStyle.Critical)
            Exit Sub
        End If
        ThisDrawing.SetVariable("ucsfollow", 0)
        ThisDrawing.ActiveSpace = Common.AcActiveSpace.acPaperSpace
        ThisDrawing.ActiveSpace = Common.AcActiveSpace.acModelSpace
        Viewport = ThisDrawing.ActiveViewport
        Zentrum(0) = Viewport.Center(0)
        Zentrum(1) = Viewport.Center(1)
        Zentrum(2) = 0
        Bildecke(0) = Zentrum(0) - (Viewport.Width / 2) * 0.9993 'hier ist der blöde Korrekturfaktor
        Bildecke(1) = Zentrum(1) + (Viewport.Height / 2) * 0.9999 'hier ist der blöde Korrekturfaktor
        Bildecke(2) = 0
        PunktüberZentrum(0) = Zentrum(0)
        PunktüberZentrum(1) = Zentrum(1) + Viewport.Height / 2
        PunktüberZentrum(2) = Zentrum(2)
        ThisDrawing.SetVariable("Mirrtext", 1)
        ReDim Satz(Myselect.Count - 1)
        For Each MyEnti In Myselect
            Satz(i) = MyEnti.Mirror(Zentrum, PunktüberZentrum)
            i = i + 1
        Next
        Myselect.Erase()
        Myselect.Clear()
        Myselect.AddItems(Satz)
        ThisDrawing.Regen(Common.AcRegenType.acActiveViewport)
        ThisDrawing.Export("D:/Mail/Test", "wmf", Myselect)
        Myselect.Erase()
        Myselect.Clear()
        Myselect.Delete()
        Dim Myblock As AcadBlockReference
        Dim Myblockmirr As AcadBlockReference
        Myblock = ThisDrawing.Import("D:/Mail/Test.wmf", Bildecke, 2)
        Myblockmirr = Myblock.Mirror(Zentrum, PunktüberZentrum)
        Myblockmirr.Explode()
        Myblock.Delete()

    End Sub

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

---

Hier jetzt die (vorläufig) endgültige Form:

Wenn jemand ne Idee hat wie man das schneller und oder genauer machen kann, wäre ich sehr dankbar.

Gruß, Theo
<Autodesk.AutoCAD.Runtime.CommandMethod("Tex")> _
      Sub Tex()
        Dim Myselect As AcadSelectionSet
        Dim Bildecke(2) As Double
        Dim Zentrum(2) As Double
        Dim PunktüberZentrum(2) As Double
        Dim Point(2) As Double
        Dim Mytext As AcadMText
        Dim Mytextmirr As AcadMText
        Dim Viewport As AcadViewport
        Dim Satz() As AcadEntity
        Dim sstext As AcadSelectionSet
        Dim FilterType(3) As Int16
        Dim FilterData(3) As Object
        Dim MyEnti As AcadEntity
        Dim MyEntiMirr As AcadEntity
        Dim i As Integer = 0
        Dim a As Integer = 0
        Dim Mylines As Object
        Dim MylinesTemp As Object
        Dim Mylineskpl(0) As AcadLine
        FilterType(0) = -4
        FilterData(0) = "<or"
        FilterType(1) = 0
        FilterData(1) = "TEXT"
        FilterType(2) = 0
        FilterData(2) = "MTEXT"
        FilterType(3) = -4
        FilterData(3) = "or>"

        Myselect = ThisDrawing.SelectionSets.Add("ss2")
        Myselect.SelectOnScreen(FilterType, FilterData)
        If Myselect.Count = 0 Then
            Myselect.Delete()
            MsgBox("Sorry, keine Texte gewählt!", MsgBoxStyle.Critical)
            Exit Sub
        End If
        If ThisDrawing.ActiveLayer.Lock = True Then
            Myselect.Delete()
            MsgBox("Sorry, der aktive Layer ist gesperrt", MsgBoxStyle.Critical)
            Exit Sub
        End If
        ThisDrawing.SetVariable("ucsfollow", 0)
        ThisDrawing.ActiveSpace = Common.AcActiveSpace.acPaperSpace
        ThisDrawing.ActiveSpace = Common.AcActiveSpace.acModelSpace
        Viewport = ThisDrawing.ActiveViewport
        Zentrum(0) = Viewport.Center(0)
        Zentrum(1) = Viewport.Center(1)
        Zentrum(2) = 0
        Bildecke(0) = Zentrum(0) - (Viewport.Width / 2) * 0.9993 'hier ist der blöde Korrekturfaktor
        Bildecke(1) = Zentrum(1) + (Viewport.Height / 2) * 0.9999 'hier ist der blöde Korrekturfaktor
        Bildecke(2) = 0
        PunktüberZentrum(0) = Zentrum(0)
        PunktüberZentrum(1) = Zentrum(1) + Viewport.Height / 2
        PunktüberZentrum(2) = Zentrum(2)
        ThisDrawing.SetVariable("Mirrtext", 1)
        ReDim Satz(Myselect.Count - 1)
        For Each MyEnti In Myselect
            Satz(i) = MyEnti.Mirror(Zentrum, PunktüberZentrum)
            i = i + 1
        Next
        Myselect.Erase()
        Myselect.Clear()
        Myselect.AddItems(Satz)
        ThisDrawing.Regen(Common.AcRegenType.acActiveViewport)
        Dim Speicherort As String = "C:/Temp/Test"
        ThisDrawing.Export(Speicherort, "wmf", Myselect)
        Myselect.Erase()
        Myselect.Clear()
        Myselect.Delete()
        Dim Myblock As AcadBlockReference
        Dim Myblockmirr As AcadBlockReference
        Speicherort = Speicherort & ".wmf"
        Myblock = ThisDrawing.Import(Speicherort, Bildecke, 2)
        Myblockmirr = Myblock.Mirror(Zentrum, PunktüberZentrum)
        Mylines = Myblockmirr.Explode()
        Myblockmirr.Delete()
        Myblock.Delete()
        For i = 0 To Mylines.Length - 1
            MylinesTemp = Mylines(i).explode()
            Mylines(i).delete()
            For a = 0 To MylinesTemp.length - 1
                Mylineskpl(Mylineskpl.Length - 1) = MylinesTemp(a)
                ReDim Preserve Mylineskpl(Mylineskpl.Length)
            Next
        Next i
        ReDim Preserve Mylineskpl(Mylineskpl.Length - 2)
        Trennstriche(Mylineskpl)
        If My.Computer.FileSystem.FileExists(Speicherort) Then
            My.Computer.FileSystem.DeleteFile(Speicherort)
        End If
    End Sub

    Sub Trennstriche(ByVal Lines() As AcadLine)
        Dim line1 As AcadLine
        Dim line2 As AcadLine
        Dim Trennlinie As Boolean = False
        Dim Mydelline(1) As AcadLine
        Dim AA As Integer
        Dim BB As Integer
        Dim Ende As Integer
        Dim a As Integer = 0
        For AA = 0 To Lines.Length - 1
            line1 = Lines(AA)
            Ende = AA + 121
            If Ende > Lines.Length - 1 Then Ende = Lines.Length - 1
            For BB = AA + 1 To Ende
                line2 = Lines(BB)
                If line1.Length = line2.Length Then
                    If Deckend(line1.StartPoint, line2.StartPoint) Then
                        If Deckend(line1.EndPoint, line2.EndPoint) Then
                            Mydelline(Mydelline.Length - 1) = line1
                            Mydelline(Mydelline.Length - 2) = line2
                            ReDim Preserve Mydelline(Mydelline.Length + 1)
                            Trennlinie = True
                            Exit For
                        End If
                    End If
                    If Deckend(line1.StartPoint, line2.EndPoint) Then
                        If Deckend(line1.EndPoint, line2.StartPoint) Then
                            Mydelline(Mydelline.Length - 1) = line1
                            Mydelline(Mydelline.Length - 2) = line2
                            ReDim Preserve Mydelline(Mydelline.Length + 1)
                            Trennlinie = True
                            Exit For
                        End If
                    End If
                End If
            Next
        Next
        If Trennlinie Then
            For a = 0 To Mydelline.Length - 3
                Mydelline(a).Delete()
            Next
        End If
    End Sub

    Public Function Deckend(ByVal PunktA As Object, ByVal PunktB As Object) As Boolean
        Dim X As Double
        Dim Y As Double
        Dim Abstand As Double
        X = PunktA(0) - PunktB(0)
        Y = PunktA(1) - PunktB(1)
        Deckend = False
        If Math.Sqrt((X * X) + (Y * Y)) = 0 Then Deckend = True
    End Function

[Diese Nachricht wurde von Theo37 am 17. Jan. 2012 editiert.]

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