Public Sub AlignMsToVp()
Dim Vp As AcadPViewport
Dim VpsCol As New Collection
Dim Ent As AcadEntity
Dim oBref As AcadBlockReference
Dim M1, M2, P1, P2, CenPt(2) As Double
Dim Mdist As Double, PDist As Double
ThisDrawing.ActiveSpace = acPaperSpace
'Get the viewport
For Each Ent In ThisDrawing.PaperSpace
If TypeOf Ent Is AcadPViewport Then
VpsCol.Add Ent
End If
Next
'The first Vp is the layout itself
If VpsCol.countVpsCol(1).ObjectID Then
Set Vp = VpsCol(2)
Else
Set Vp = VpsCol(1)
End If
If ThisDrawing.MSpace = False Then
Vp.Display True
ThisDrawing.MSpace = True
End If
'Define your modelspace area
'Here you need a blockref called "MyLayoutArea"
'That is a rectangle on defpoints
Dim Ss As AcadSelectionSet
Set Ss = sset(2, "MyLayoutArea")
Ss(0).GetBoundingBox M1, M2
Vp.GetBoundingBox P1, P2
Mdist = M2(0) - M1(0)
PDist = P2(0) - P1(0)
ThisDrawing.MSpace = True
CenPt(0) = (M2(0) + M1(0)) / 2: CenPt(1) = (M2(1) + M1(1)) / 2
Vp.StandardScale = acVpCustomScale
'This is how it is done, set the ZoomCenter
ThisDrawing.Application.ZoomCenter CenPt, 1
Vp.CustomScale = PDist / Mdist
ThisDrawing.MSpace = False
End Sub
太快了，布莱科！你什么时候睡觉？
同时，网站上的ZIPped绘图文件已被Acad2004类型文件取代。
选择要在视口中显示的对象：类似于：
Dim algobj As AcadEntity
Dim LowX As Long, HighX As Long
Dim LowY As Long, HighY As Long
Dim BBoxMin, BBoxMax
LowX = 2147483647: HighX = -2147483647
LowY = 2147483647: HighY = -2147483647
For Each algobj In ThisDrawing.ModelSpace
If algobj.Layer = "Plattegrond" Or algobj.Layer = "ISO-projectie" Then
algobj.GetBoundingBox BBoxMin, BBoxMax
If BBoxMin(0)HighX Then HighX = BBoxMax(0)
If BBoxMin(1)HighY Then HighY = BBoxMax(1)
End If
Next
这将生成公共边界框的XY坐标。但是我看到你正在代码中做类似的事情。我明天会尝试你的解决方案。 好的，Bryco，你帮我解决了我的主要问题，我在其他地方找到了一些外围问题的解决方案。现在我想我可以把这些拼凑起来了。
再次感谢！ 我很高兴你把这一切都放在一起，哈瓦诺，这听起来像是一个雄心勃勃的项目。
页:
1
[2]