哪位大侠能帮我看一下，程序问题出在何处？
程序思路：根据图框的四个角点范围区定比例打印图幅。Public Sub 图纸批打印() '取图框四个角点坐标
Call SelectionSets.CreatSelectionSets_图框
Dim SSetColl As AcadSelectionSets
Set SSetColl = ThisDrawing.SelectionSets
Dim ssetObj_tq, Ssetobj_ptx, Ssetobj_data, Ssetobj_ptfwx As AcadSelectionSet
Set ssetObj_tq = SSetColl.Item("图框")
Dim SsetCount, IAs Integer
Dim blkRefobj As AcadBlockReference
Dim InsPnt
Dim PntA(0 To 1) As Double
Dim PntB(0 To 1) As Double
Dim AngelRot, BlockScaleX, BlockScaleY, Dist As Double
SsetCount = ssetObj_tq.Count
For I = 0 To SsetCount - 1
Set blkRefobj = ssetObj_tq(I)
InsPnt = blkRefobj.InsertionPoint
AngelRot = blkRefobj.Rotation
BlockScaleX = blkRefobj.XScaleFactor
BlockScaleY = blkRefobj.YScaleFactor
If StrComp(UCase(blkRefobj.Name), "TK48A", 1) = 0 Then
PntA(0) = InsPnt(0)
PntA(1) = InsPnt(1)
PntB(0) = PntA(0) + 865 * BlockScaleX * Cos(AngelRot) + 392 * BlockScaleX * Cos(AngelRot + 3.1415926 / 2)
PntB(1) = PntA(1) + 865 * BlockScaleY * Sin(AngelRot) + 392 * BlockScaleY * Sin(AngelRot + 3.1415926 / 2)
PntA(0) = PntA(0) + 1 * BlockScaleX * Cos(AngelRot + 204.3791667 * 3.1415926 / 180)
PntA(1) = PntA(1) + 1 * BlockScaleY * Sin(AngelRot + 204.3791667 * 3.1415926 / 180)
PntB(0) = PntB(0) + 1 * BlockScaleX * Cos(AngelRot + 24.3791667 * 3.1415926 / 180)
PntB(1) = PntB(1) + 1 * BlockScaleY * Sin(AngelRot + 24.3791667 * 3.1415926 / 180)
Else
PntA(0) = InsPnt(0)
PntA(1) = InsPnt(1)
PntB(0) = PntA(0) + 820 * BlockScaleX * Cos(AngelRot) + 578 * BlockScaleX * Cos(AngelRot + 3.1415926 / 2)
PntB(1) = PntA(1) + 820 * BlockScaleY * Sin(AngelRot) + 578 * BlockScaleY * Sin(AngelRot + 3.1415926 / 2)
PntA(0) = PntA(0) + 1 * BlockScaleX * Cos(AngelRot + 215.1791667 * 3.1415926 / 180)
PntA(1) = PntA(1) + 1 * BlockScaleY * Sin(AngelRot + 215.1791667 * 3.1415926 / 180)
PntB(0) = PntB(0) + 1 * BlockScaleX * Cos(AngelRot + 35.1791667 * 3.1415926 / 180)
PntB(1) = PntB(1) + 1 * BlockScaleY * Sin(AngelRot + 35.1791667 * 3.1415926 / 180)
End If
Dim lineobj1 As AcadLine
Dim f(0 To 2) As Double
Dim s(0 To 2) As Double
f(0) = PntA(0): f(1) = PntA(1): f(2) = 0
s(0) = PntB(0): s(1) = PntB(1): s(2) = 0
Set lineobj1 = ThisDrawing.ModelSpace.AddLine(f, s)
ThisDrawing.SendCommand "_Dview" & vbCr & vbCr & "TW" & vbCr & -AngelRot * 180 / 3.1415926 & vbCr & vbCr
ThisDrawing.Regen acActiveViewport
Select Case BlockScaleX
Case 0.5
ThisDrawing.Layouts("Model").SetCustomScale 2, 1
Case 1
ThisDrawing.Layouts("Model").SetCustomScale 1, 1
Case 2
ThisDrawing.Layouts("Model").SetCustomScale 1, 2
End Select
ThisDrawing.Layouts("Model").PlotRotation = ac0degrees
Dim width As Double
Dim height As Double
ThisDrawing.Layouts("Model").GetPaperSize width, height
If width < 875 Then
MsgBox "图纸宽度设置不对，查看绘图仪设置"
Exit Sub
End If
Dim originalValue As Variant
Dim newValue(0 To 1) As Double
originalValue = ThisDrawing.Layouts("Model").PlotOrigin
newValue(0) = 0
newValue(1) = 0
ThisDrawing.Layouts("Model").PlotOrigin = newValue
ThisDrawing.ActiveLayout.SetWindowToPlot PntA, PntB
ThisDrawing.ActiveLayout.PlotType = acWindow
ThisDrawing.Plot.DisplayPlotPreview acFullPreview
'ThisDrawing.Plot.PlotToDevice '"D:\Program Files\AutoCAD 2002\Plotters\HP DesignJet 500 42_HPGL2 Card.pc3"
Next I
MsgBox "打印完毕，共有" & SsetCount & "幅"
Public Sub CreatSelectionSets_图框()
Dim SSetColl As AcadSelectionSets
Set SSetColl = ThisDrawing.SelectionSets
Dim Ssetobj As AcadSelectionSet
Dim I As Integer
If SSetColl.Count <> 0 Then
For I = 0 To SSetColl.Count - 1
Set Ssetobj = SSetColl.Item(I)
If StrComp(Ssetobj.Name, "图框", 1) = 0 Then
Ssetobj.Delete
Exit For
End If
Next
End If
Set Ssetobj = SSetColl.Add("图框")
Dim FilterType, FilterData As Variant
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
Dim mode As Integer
mode = acSelectionSetAll
gpCode(0) = "2"
dataValue(0) = "tk48a"
FilterType = gpCode
FilterData = dataValue
Ssetobj.Select mode, , , FilterType, FilterData
If Ssetobj.Count = 0 Then
dataValue(0) = "tk68a"
FilterData = dataValue
Ssetobj.Select mode, , , FilterType, FilterData
End If
' MsgBox " 共有" & Ssetobj.Count & "个"
End Sub
页:
[1]