CADsite forum

Hier hebt u momenteel mijn volledige code:

public sub bevriezenlayers()


Dim objEntity As AcadObject
Dim objPViewport As AcadObject
Dim objPViewport2 As AcadObject
Dim objViewPortNew As AcadPViewport
Dim XdataType As Variant
Dim XdataValue As Variant
Dim I As Integer
Dim D As Integer
Dim Counter As Integer
Dim strLayer As String


Dim objVPLeft As AcadPViewport
Dim objVPRight As AcadPViewport
Dim objEnt As AcadEntity
Dim objLayout As AcadLayout
Dim xL As Double
Dim xR As Double
Dim elem As Variant

Set objVPLeft = Nothing
Set objVPRight = Nothing

'onderscheid maken tussen de 2 viewports

For Each elem In ThisDrawing.ActiveLayout.Block
With elem
      If elem.EntityName = "AcDbViewport" Then
            If objVPLeft Is Nothing Then
                Set objVPLeft = elem
            Else
                Set objVPRight = elem
                xL = objVPLeft.center(0)
                xR = objVPRight.center(0)
                If xL > xR Then
                   Set objVPRight = objVPLeft
                   Set objVPLeft = elem
                End If
            End If
        End If
End With
Next elem
   
If ThisDrawing.ActiveSpace = acModelSpace Then
    MsgBox "This program only works with PaperSpace Viewports" & vbCr & _
    "Please go to PaperSpace", vbCritical
    Exit Sub
End If



'viewport 1 bevriezen                     

                        Set objVPLeft = ThisDrawing.ActivePViewport
                        ThisDrawing.MSpace = True
                        Set objVPLeft = ThisDrawing.ActivePViewport
                        objVPLeft.GetXData "ACAD", XdataType, XdataValue
                       
                        For I = LBound(XdataType) To UBound(XdataType)
                           If XdataType(I) = 1003 Then
                               Counter = I + 1
                               If XdataValue(i) = "strLayer1" Then Exit Sub
                           End If
                        Next
                       
                        If Counter = 0 Then
                           For I = LBound(XdataType) To UBound(XdataType)
                               If XdataType(I) = 1002 Then Counter = I - 1
                            Next
                        End If
                       
                        XdataType(Counter) = 1003
                        XdataValue(Counter) = "strLayer1"
                       
                        ReDim Preserve XdataType(Counter + 1)
                        ReDim Preserve XdataValue(Counter + 1)
                       
                        XdataType(Counter + 1) = 1002
                        XdataValue(Counter + 1) = "}"
                       
                        ReDim Preserve XdataType(Counter + 2)
                        ReDim Preserve XdataValue(Counter + 2)
                       
                        XdataType(Counter + 2) = 1002
                        XdataValue(Counter + 2) = "}"
                       
                        objVPLeft.SetXData XdataType, XdataValue
                               
                        Set objVPLeft = ThisDrawing.ActivePViewport
                        ThisDrawing.MSpace = True
                        objVPLeft.Display (False)
                        objVPLeft.Display (True)



'viewport 2 bevriezen                               
                        Set objVPRight = ThisDrawing.ActivePViewport
                        ThisDrawing.MSpace = True
                        objVPRight.GetXData "ACAD", XdataType, XdataValue
                       
                        For I = LBound(XdataType) To UBound(XdataType)
                           If XdataType(I) = 1003 Then
                               Counter = I + 1
                              If XdataValue(I) = "strLayer2" Then Exit Sub
                           End If
                        Next
                       
                        If Counter = 0 Then
                           For I = LBound(XdataType) To UBound(XdataType)
                               If XdataType(I) = 1002 Then Counter = I - 1
                            Next
                        End If
                       
                        XdataType(Counter) = 1003
                        XdataValue(Counter) = "strLayer2"
                       
                        ReDim Preserve XdataType(Counter + 1)
                        ReDim Preserve XdataValue(Counter + 1)
                       
                        XdataType(Counter + 1) = 1002
                        XdataValue(Counter + 1) = "}"
                       
                        ReDim Preserve XdataType(Counter + 2)
                        ReDim Preserve XdataValue(Counter + 2)
                       
                        XdataType(Counter + 2) = 1002
                        XdataValue(Counter + 2) = "}"
                       
                        objVPRight.SetXData XdataType, XdataValue
                               
                        Set objVPRight = ThisDrawing.ActivePViewport
                        ThisDrawing.MSpace = False
                        objVPRight.Display (False)
                        objVPRight.Display (True)


end sub

De naam strLayer1 en strLayer2 zijn de namen van de layers die men wil bevriezen in de viewports.

Hoi,

Nu mijn ander probleem is opgelost, zit ik al met een nieuwe moelijkheid.
Ik zit nog steeds met mijn 2 viewporten die ik allebei wil activeren om de layers te bevriezen.

Ik dacht d.m.v. de volgende code dat ik beurtelings mijn 2 viewporten kon activeren, maar telkens wordt dezelfde viewport geselecteerd (m.a.w. diegene die laatst geactiveerd was in autocad).

Set objVPLeft = ThisDrawing.ActivePViewport
ThisDrawing.MSpace = True

Set objVPRight = ThisDrawing.ActivePViewport
ThisDrawing.MSpace = True


Heeft er iemand een oplossing voor dit probleem?

Probleem is opgelost.

Het probleem lag hem aan het vinden van de 2 viewporten. Ook al stonden er maar 2 op mijn paperspace, toch vond hij zogezegd nog altijd een andere viewport. Hierdoor wilde hij die éne viewport niet veranderen in schaal, maar met een klein stukje code erbij is het inmiddels wel gelukt om de 2 juiste viewports te vinden.


Alvast bedankt

Ik heb dit nu uitgetest met een andere versie van Autocad, maar ook daar heb ik hetzelfde probleem.

Nu moet ik er wel bijvertellen dat ik bij deze zin: "ThisDrawing.SetVariable "CTAB", "FULL SIZE"" altijd een foutmelding verkrijgt. Hierdoor laat ik deze zin niet mee in de code draaien. Zou dit eventueel het probleem kunnen zijn.

Kunt u eventueel nog eens de code doorlopen zonder deze zin. Zodat we kunnen zien of het eventueel aan deze zin ligt.
Maar hoe komt het dat u wel deze zin kan doorlopen zonder foutmelding en ik niet?

Ok, ik zal dit eens proberen met een andere versie van Autocad. Mss lukt dit wel.

Ja inderdaad, maar via deze code zou je denken dat de schaal van beide viewports wordt aangepast. Want ze activeren eerst de linkerviewport en dan de rechterviewport. Maar als ik mijn code doorloop wordt nooit mijn schaal aangepast van mijn rechterviewport. Met andere woorden hij verandert enkel de schaal in de viewport waar ik het laatst heb in gewerkt.

ik heb een stukje vba-code gevonden op internet om automatisch te switchen tussen 2 viewports. Het enige probleem is dat nooit switch, maar steeds in dezelfde viewport aan het werken ben. Weet iemand een antwoord op dit probleem?

Sub SetupFullSizeTab()
Dim objVPLeft As AcadPViewport
Dim objVPRight As AcadPViewport
Dim objEnt As AcadEntity
Dim objLayout As AcadLayout
Dim bTest As Boolean
Dim xL As Double
Dim xR As Double

ThisDrawing.SetVariable "CTAB", "FULL SIZE"
For Each objEnt In ThisDrawing.ActiveLayout.Block
'this test skips the first object in the layout which is always _
the PS Vport of the layout itself
If bTest = True Then
If TypeOf objEnt Is AcadPViewport Then
If objVPLeft Is Nothing Then
Set objVPLeft = objEnt
Else
Set objVPRight = objEnt
xL = objVPLeft.Center(0)
xR = objVPRight.Center(0)
If xL > xR Then
Set objVPRight = objVPLeft
Set objVPLeft = objEnt
Exit For
Else
Exit For
End If
End If
End If
Else
bTest = True
End If
Next

''do whatever with the 2 viewports now
objVPLeft.DisplayLocked = False
objVPLeft.Display True
ThisDrawing.MSpace = True
ThisDrawing.ActivePViewport = objVPLeft
ThisDrawing.Application.ZoomExtents
objVPLeft.StandardScale = acVpCustomScale
objVPLeft.CustomScale = 0.25 / 12#
objVPLeft.DisplayLocked = True
objVPRight.DisplayLocked = False

ThisDrawing.ActivePViewport = objVPRight
ThisDrawing.Application.ZoomExtents
objVPRight.StandardScale = acVpCustomScale
objVPRight.CustomScale = 0.25 / 12#
objVPRight.DisplayLocked = True
ThisDrawing.MSpace = False

End Sub

Het probleem is wel dat ik al bijna mijn volledig programma heb gemaakt in vba. Indien ik toch zou overschakelen naar vb.net of c#, is het dan al mogelijk om het in autocad 2009 te integreren of lukt dit enkel maar vanaf de versie 2012 (wanneer autocad geen vba meer ondersteund)? Of is het beter dat ik eens probeer met autolisp?

Mijn probleemsituaties is dus een 50-tal layouts waarbij telkens een block met attributen is ingevoegd. Ik wil dus een code om uit excel de attributen van de blocks in alle 100-tal layouts in te vullen. Ik zou ook graag een code willen om de 50-tal layouts via één command/knop af te drukken. Dit is me al voor een groot gedeelte gelukt via vba, het enige probleem is dat het veel te lang duurt (grotendeels door regenerating, maar ook door het door te sturen naar een printer). Zal dit ook het geval zijn met de vb.net, autolisp? Of is de traagheid vooral doordat mijn grafische kaart van mijn laptop het niet aankan?

Ik ben nu al zover geraakt met vba en zou het graag willen afwerken.
Graag had ik jullie gedacht eens hierover gehoord.

** Met dit stukje code kan ik al veel vlugger afdrukken, enkel nog regenerate van de layouts duurt enorm lang **

      ThisDrawing.SetVariable "BACKGROUNDPLOT", 0

Dit is idd niet slecht gezien, maar ik blijf wel nog altijd met hetzelfde probleem zitten van die layouts.

Dag, zojuist ben ik begonnen met het programmeren in autocad.

Mijn probleemsituatie gaat als volgt: ik heb een vijftigtal layouts en in iedere layout wil ik bepaalde bewerkingen uitvoeren.
Maar graag zou ik een code hebben die niet altijd de layouts activeert (want doordat ze zich telkens regenerate, duurt het een tijd).

Ikzelf probeer te werken met:

For Each elem In ThisDrawing.Layouts.Item(layoutname)
       elem.Delete
Next elem 

Maar hierbij verkrijg ik telkens een fout. Weet iemand een ander stukje code hiervoor.