Help!! Ik probeer een programmatje te schrijven dat een rechthoek met een offset van 10mm om geselecteerde objecten (polylijnen) tekend, maar ik ben eigenlijk een beetje vastgelopen. Kunnen jullie mij weer een beetje op gang helpen??
De code hieronder
'Formulier met een knop selecteren
Private Sub btnSelectond_Click()
frmRechthoekCNC.Hide
' vorm om te selecteren wordt dmv een polyline getekend
Dim dblVierkant(0 To 7) As Double
Dim plVorm As AcadLWPolyline
dblVierkant(0) = 50
dblVierkant(1) = 50
dblVierkant(2) = 100
dblVierkant(3) = 25
dblVierkant(4) = 125
dblVierkant(5) = 150
dblVierkant(6) = 50
dblVierkant(7) = 125
Set plVorm = ThisDrawing.ModelSpace.AddLightWeightPolyline(dblVierkant)
plVorm.Closed = True
plVorm.Update
'Hier begint straks het programmavoegt een selectieset toe
Dim ssetObj As AcadSelectionSet
Set ssetObj = ThisDrawing.SelectionSets.Add("selectie")
' Voeg objecten toe aan de selectieset
ssetObj.SelectOnScreen
'Tekend de nieuwe rechthoek
Dim dblrechthoek(0 To 7) As Double
Dim plOmtrek As AcadLWPolyline
Dim dblRechthoekmin(0 To 2) As Double
Dim dblRechthoekmax(0 To 2) As Double
dblRechthoekmin = fncRechthoekmin
dblRechthoekmax = fncRechthoekmax
dblrechthoek(0) = dblRechthoekmin(0) - 10
dblrechthoek(1) = dblRechthoekmin(1) - 10
dblrechthoek(2) = dblRechthoekmax(0) + 10
dblrechthoek(3) = dblRechthoekmin(1) - 10
dblrechthoek(4) = dblRechthoekmax(0) + 10
dblrechthoek(5) = dblRechthoekmax(1) + 10
dblrechthoek(6) = dblRechthoekmin(0) - 10
dblrechthoek(7) = dblRechthoekmax(1) + 10
Set plOmtrek = ThisDrawing.ModelSpace.AddLightWeightPolyline(dblrechthoek)
plOmtrek.Closed = True
plOmtrek.Update
ssetObj.Delete
End Sub
'Zoekt de onderste linkse punt op van de selectie
Public Function fncRechthoekmin(ssetObj As AcadSelectionSet) As Variant
Dim acadobj As AcadObject
Dim varminExt As Variant
Dim varmaxExt As Variant
Dim test As Boolean
Dim varMinpnt As Variant
test = False
For Each acadobj In sset
acadobj.GetBoundingBox minExt, maxExt
If test = False Then
pbas = minExt
test = True
End If
If varminExt(0) < varMinpnt(0) Then varMinpnt(0) = varminExt(0) 'x mini
If varminExt(1) < varMinpnt(1) Then varMinpnt(1) = varminExt(1) 'y mini
Next acadobj
puntRechthoekmin(0) = varMinpnt(0)
puntRechthoekmin(1) = varMinpnt(1)
Exit Function
End Function
'Zoekt de bovenste rechtse punt op van de selectie
Public Function fncRechthoekmax(ssetObj As AcadSelectionSet) As Variant
Dim acadobj As AcadObject
Dim varminExt As Variant
Dim varmaxExt As Variant
Dim test As Boolean
Dim varMaxpnt As Variant
test = False
For Each acadobj In sset
acadobj.GetBoundingBox minExt, maxExt
If test = False Then
pbas = minExt
test = True
End If
If varmaxExt(0) < varMaxpnt(0) Then varMaxpnt(0) = varmaxExt(0) 'x max
If varmaxExt(1) < varMaxpnt(1) Then varMaxpnt(1) = varmaxExt(1) 'y max
Next acadobj
puntRechthoekmax(0) = varMaxpnt(0)
puntRechthoekmax(1) = varMaxpnt(1)
Exit Function
End Function
De fncRechthoekmax en min blijven leeg na het selecteren van de vorm.
Alvast bedankt voor het bekijken,
Martijn
Waarom zet je de ojecten niet highlighted en dan later weer op normaal?:
acadobj.Highlight = True
acadobj.Highlight = Fales
Beste Martijn,
Heb je aan ad_ssBox van http://www.activedwg.com/html/_page.php?title=VBA&page=VBA iets?
Met vriendelijke groet, HofCAD CSI.
Dat Highlight weet ik eigenlijk het bestaan 'nog' niet van, maar ga ik zeker even naar kijken. De link van Hofcad staat bijna precies wat ik probeer te maken, alleen een stuk korter, maar hier ga ik zeker even met stoeien.
Allebei weer super bedankt,
Martijn