关于打印

weixin7944 · 发表于 2006-8-22 22:08:00

一段关于打印的程序：
Sub Example_Plot()
Dim ptmin As Variant, ptmax As Variant
Dim ent As AcadEntity
Dim i As Integer
For Each ent In ThisDrawing.ModelSpace
If TypeOf ent Is AcadBlockReference Then
If StrComp(ent.Name, "TK", vbTextCompare) = 0 Then
ent.GetBoundingBox ptmin, ptmax
ReDim Preserve ptmin(0 To 1)
ReDim Preserve ptmax(0 To 1)
ThisDrawing.ActiveLayout.SetWindowToPlot ptmin, ptmax
Dim currentPlot As AcadPlot
Set currentPlot = ThisDrawing.Plot
currentPlot.PlotToDevice "d:\wxa3.pc3"
i = i + 1
End If
End If
Next ent

End Sub
程序运行后，没有任何反应！不知道为什么，请高手指点！

alin · 发表于 2006-8-23 11:45:00

First you must have a block named "TK" in current drawing and a PC3 file name wxa.pc3 in D drive, then
Sub Example_Plot()
Dim ptmin As Variant, ptmax As Variant
Dim ent As AcadEntity
Dim i As Integer
For Each ent In ThisDrawing.ModelSpace
If TypeOf ent Is AcadBlockReference Then
If StrComp(ent.Name, "TK", vbTextCompare) = 0 Then
ent.GetBoundingBox ptmin, ptmax
ReDim Preserve ptmin(0 To 1)
ReDim Preserve ptmax(0 To 1)
ThisDrawing.ActiveLayout.SetWindowToPlot ptmin, ptmax
Dim currentPlot As AcadPlot
Set currentPlot = ThisDrawing.Plot
ThisDrawing.ActiveLayout.PlotType = acWindow
currentPlot.PlotToDevice "d:\wxa3.pc3"
i = i + 1
End If
End If
Next ent

End Sub

weixin7944 · 发表于 2006-8-23 20:08:00

谢谢！该问题已解决。但是，新的问题又产生了：在d:\wxa3.pc3中已经设置了图纸的打印笔表，该笔表设置了各种颜色的线宽并设置了打印后全部为黑色（即黑白打印）。该笔表手动打印时效果正常。但是用上面的程序自动打印时，却没有体现出笔表的作用，打印出来为彩色的，无线宽区别的。

weixin7944 · 发表于 2006-8-24 22:12:00

新编了一个程序如下：
Private Sub cmdOk_Click()
Dim i As Integer
Dim ii As Integer
Dim zz As Integer
Dim drn As String
Dim drn1 As String
Dim ptmin As Variant, ptmax As Variant
Dim ent As AcadEntity
Dim x As Integer
If lstFile.ListCount = 0 Then
MsgBox "请添加所要操作的图形！"
Exit Sub
End If
frmMain.hide
For i = 0 To lstFile.ListCount - 1
drn1 = lstFile.List(i)
Application.Documents.Open drn1
For Each ent In ThisDrawing.PaperSpace
If TypeOf ent Is AcadBlockReference Then
If StrComp(ent.Name, "TITLE", vbTextCompare) 0 Then
ent.GetBoundingBox ptmin, ptmax
Exit For
End If
End If
Next ent
ReDim Preserve ptmin(0 To 1)
ReDim Preserve ptmax(0 To 1)
Dim currentPlot As AcadPlot
Set currentPlot = ThisDrawing.Plot
ThisDrawing.ActiveLayout.SetWindowToPlot ptmin, ptmax
ThisDrawing.ActiveLayout.PlotType = acWindow
If ComboBox1.Text = "ScaleToFit" Then
ThisDrawing.ActiveLayout.StandardScale = acScaleToFit
MsgBox TextBox2.Text
ThisDrawing.ActiveLayout.StyleSheet = TextBox2.Text
Else
ThisDrawing.ActiveLayout.StandardScale = ac1_1
ThisDrawing.ActiveLayout.StyleSheet = TextBox2.Text
End If

currentPlot.PlotToDevice TextBox1.Text
Application.ActiveDocument.Close True, drn1
Next i
End Sub
程序运行到ThisDrawing.ActiveLayout.StyleSheet = TextBox2.Text处时出现错误，提示为INVALID INPUT.而TextBox2.Text的内容是笔表ctb文件的完整路径。删去此行时，程序运行完毕，但无笔表设置。请问为什么？

关于打印

发表回复

精选推荐