[原创]打印函数

lennie

2. Public Function P_DWG(ByVal ZX As String, ByVal YS As String, Optional ByVal P_Option _
3.     As Integer = 1, Optional ByVal Paper_Units As String = "毫米", Optional ByVal CustomScale As Long = 0, Optional _
4.     ByVal Plot_Device As String = "", Optional ByVal Style_Sheet As String = "", Optional ByVal CanonicalMedia As _
5.     String = "", Optional ByVal File_Path As String = "", Optional ByVal Number_Copies As Integer = 1, Optional ByVal _
6.     Plot_Origin As String = ",", Optional ByVal Degree As String = "自 动") As Long
7. 'P_DWG 返回值：
8. '   1       操作成功
9. '   0       操作被用户中断
10. '   -1      接口使用错误
11. '   -2      函数内部错误
12. On Error GoTo Err_handle
13.     Dim FilePath As String
14.     FilePath = File_Path
15.     If Plot_Device <> "" Then
16.         If ThisDrawing.ActiveLayout.ConfigName <> Plot_Device Then ThisDrawing.ActiveLayout.ConfigName = Plot_Device
17.     End If
18.     If Style_Sheet <> "" Then
19.         If ThisDrawing.ActiveLayout.StyleSheet <> Style_Sheet Then ThisDrawing.ActiveLayout.StyleSheet = Style_Sheet
20.     End If
21.     If CanonicalMedia <> "" Then
22.         If ThisDrawing.ActiveLayout.CanonicalMediaName <> CanonicalMedia Then ThisDrawing.ActiveLayout.CanonicalMediaName = CanonicalMedia
23.     End If
24.     If Not Exists(Left(FilePath, InStrRev(FilePath, ""))) And P_Option = 2 Then
25.         P_DWG = -2
26.         Exit Function
27.     End If
28.     If Val(ThisDrawing.Application.Version) >= 16.2 Then
29.         ThisDrawing.SetVariable "BACKGROUNDPLOT", 0
30.     End If
31.     '获取后缀名
32.     Dim Extension As String
33.     Extension = ".plt"
34.     If InStr(1, Plot_Device, "png", 1) Then Extension = ".png"
35.     If InStr(1, Plot_Device, "tif", 1) Then Extension = ".tif"
36.    
37.     '设置打印区域
38.     Dim P1(0 To 1) As Double
39.     Dim P2(0 To 1) As Double
40.     P1(0) = Val(ZX)
41.     P1(1) = Val(Right(ZX, Len(ZX) - InStr(ZX, ",")))
42.     P2(0) = Val(YS)
43.     P2(1) = Val(Right(YS, Len(YS) - InStr(YS, ",")))
44. '    Dim W As Double
45. '    Dim H As Double
46. '    W = P2(0) - P1(0)
47. '    H = P2(1) - P1(1)
48. '    P1(0) = P1(0) - 0.001 * W
49. '    P1(1) = P1(1) - 0.001 * H
50. '    P2(0) = P2(0) + 0.001 * W
51. '    P2(1) = P2(1) + 0.001 * H
52.     ThisDrawing.ActiveLayout.SetWindowToPlot P1, P2
53.     ThisDrawing.ActiveLayout.PlotType = acWindow
54.      '设置旋转角度
55.     Select Case Degree
56.         Case "自 动"
57.             Dim zW As Double
58.             Dim zH As Double
59.             Dim tW As Double
60.             Dim tH As Double
61.             Dim str1 As String
62.             Dim str2 As String
63.             zW = Abs(Val(ZX) - Val(YS))
64.             str1 = Right(ZX, Len(ZX) - InStr(ZX, ","))
65.             str2 = Right(YS, Len(YS) - InStr(YS, ","))
66.             zH = Abs(Val(str1) - Val(str2))
67.             ThisDrawing.ActiveLayout.GetPaperSize tW, tH
68.             If ((tW > tH) And (zW > zH)) Or ((tW < tH) And (zW < zH)) Then
69.                 ThisDrawing.ActiveLayout.PlotRotation = ac0degrees
70.             Else
71.                 ThisDrawing.ActiveLayout.PlotRotation = ac90degrees
72.             End If
73.         Case "  0度"
74.             ThisDrawing.ActiveLayout.PlotRotation = ac0degrees
75.         Case " 90度"
76.             ThisDrawing.ActiveLayout.PlotRotation = ac90degrees
77.         Case "180度"
78.             ThisDrawing.ActiveLayout.PlotRotation = ac180degrees
79.         Case "270度"
80.             ThisDrawing.ActiveLayout.PlotRotation = ac270degrees
81.         Case Else
82.             P_DWG = -1
83.             ThisDrawing.SetVariable "BACKGROUNDPLOT", 2
84.             Exit Function
85.     End Select
86.     '设置打印比例，Paper_Units控制尺寸单位
87.     Select Case Paper_Units
88.         Case "英寸"
89.             ThisDrawing.ActiveLayout.PaperUnits = acInches
90.         Case "毫米"
91.             ThisDrawing.ActiveLayout.PaperUnits = acMillimeters
92.         Case "像素"
93.             ThisDrawing.ActiveLayout.PaperUnits = acPixels
94.         Case Else
95.             P_DWG = -1
96.             ThisDrawing.SetVariable "BACKGROUNDPLOT", 2
97.             Exit Function
98.     End Select
99.     If CustomScale < 0 Then
100.         P_DWG = -1
101.         ThisDrawing.SetVariable "BACKGROUNDPLOT", 2
102.         Exit Function
103.     End If
104.     If CustomScale = 0 Then
105.         ThisDrawing.ActiveLayout.StandardScale = acScaleToFit
106.     Else
107.         ThisDrawing.ActiveLayout.SetCustomScale 1, CustomScale
108.     End If
109.     '设置偏移量
110.     Dim NewValue(0 To 1) As Double
111.     If Plot_Origin = "," Or Plot_Origin = "0,0" Then
112.         ThisDrawing.ActiveLayout.CenterPlot = True
113.     Else
114.         NewValue(0) = Val(Plot_Origin)
115.         NewValue(1) = Val(Right(Plot_Origin, Len(Plot_Origin) - InStr(Plot_Origin, ",")))
116.         ThisDrawing.ActiveLayout.PlotOrigin = NewValue
117.     End If    '设置打印份数
118.     ThisDrawing.Plot.NumberOfCopies = Number_Copies
119.     '区分打印的类型
120.     Select Case P_Option
121.         Case 0  '空操作
122.             P_DWG = 1
123.             Exit Function
124.         Case 1      '打印到设备
125.             If ThisDrawing.Plot.PlotToDevice Then P_DWG = 1 Else P_DWG = 0
126.         Case 2      '打印到文件
127.             If Exists(FilePath & Extension) Then
128.                 If MsgBox(FilePath & Extension & " 已经存在。是否覆盖原文件？", vbYesNo, "覆盖文件") = vbYes Then
129.                     If ThisDrawing.Plot.PlotToFile(FilePath & Extension) Then P_DWG = 1 Else P_DWG = 0
130.                 End If
131.             Else
132.                 If ThisDrawing.Plot.PlotToFile(FilePath & Extension) Then P_DWG = 1 Else P_DWG = 0
133.             End If
134.         Case 3      '打印预览
135.             ThisDrawing.Plot.DisplayPlotPreview acFullPreview
136.             P_DWG = 1
137.         Case Else
138.             P_DWG = -1
139.     End Select
140.     If Val(ThisDrawing.Application.Version) >= 16.2 Then
141.         ThisDrawing.SetVariable "BACKGROUNDPLOT", 2
142.     End If
143.     Exit Function
144. Err_handle:
145.     Select Case Err.Number
146.         Case -2145386493        '打印单位设置错误
147.             P_DWG = -1
148.         Case Else
149.             P_DWG = -2
150.     End Select
151. End Function

Public Function P_DWG(ByVal ZX As String, ByVal YS As String, Optional ByVal P_Option _     As Integer = 1, Optional ByVal Paper_Units As String = "毫米", Optional ByVal CustomScale As Long = 0, Optional _     ByVal Plot_Device As String = "", Optional ByVal Style_Sheet As String = "", Optional ByVal CanonicalMedia As _     String = "", Optional ByVal File_Path As String = "", Optional ByVal Number_Copies As Integer = 1, Optional ByVal _     Plot_Origin As String = ",", Optional ByVal Degree As String = "自 动") As Long 'P_DWG 返回值： '   1       操作成功 '   0       操作被用户中断 '   -1      接口使用错误 '   -2      函数内部错误 On Error GoTo Err_handle     Dim FilePath As String     FilePath = File_Path     If Plot_Device <> "" Then         If ThisDrawing.ActiveLayout.ConfigName <> Plot_Device Then ThisDrawing.ActiveLayout.ConfigName = Plot_Device     End If     If Style_Sheet <> "" Then         If ThisDrawing.ActiveLayout.StyleSheet <> Style_Sheet Then ThisDrawing.ActiveLayout.StyleSheet = Style_Sheet     End If     If CanonicalMedia <> "" Then         If ThisDrawing.ActiveLayout.CanonicalMediaName <> CanonicalMedia Then ThisDrawing.ActiveLayout.CanonicalMediaName = CanonicalMedia     End If     If Not Exists(Left(FilePath, InStrRev(FilePath, ""))) And P_Option = 2 Then         P_DWG = -2         Exit Function     End If     If Val(ThisDrawing.Application.Version) >= 16.2 Then         ThisDrawing.SetVariable "BACKGROUNDPLOT", 0     End If     '获取后缀名     Dim Extension As String     Extension = ".plt"     If InStr(1, Plot_Device, "png", 1) Then Extension = ".png"     If InStr(1, Plot_Device, "tif", 1) Then Extension = ".tif"         '设置打印区域     Dim P1(0 To 1) As Double     Dim P2(0 To 1) As Double     P1(0) = Val(ZX)     P1(1) = Val(Right(ZX, Len(ZX) - InStr(ZX, ",")))     P2(0) = Val(YS)     P2(1) = Val(Right(YS, Len(YS) - InStr(YS, ","))) '    Dim W As Double '    Dim H As Double '    W = P2(0) - P1(0) '    H = P2(1) - P1(1) '    P1(0) = P1(0) - 0.001 * W '    P1(1) = P1(1) - 0.001 * H '    P2(0) = P2(0) + 0.001 * W '    P2(1) = P2(1) + 0.001 * H     ThisDrawing.ActiveLayout.SetWindowToPlot P1, P2     ThisDrawing.ActiveLayout.PlotType = acWindow      '设置旋转角度     Select Case Degree         Case "自 动"             Dim zW As Double             Dim zH As Double             Dim tW As Double             Dim tH As Double             Dim str1 As String             Dim str2 As String             zW = Abs(Val(ZX) - Val(YS))             str1 = Right(ZX, Len(ZX) - InStr(ZX, ","))             str2 = Right(YS, Len(YS) - InStr(YS, ","))             zH = Abs(Val(str1) - Val(str2))             ThisDrawing.ActiveLayout.GetPaperSize tW, tH             If ((tW > tH) And (zW > zH)) Or ((tW < tH) And (zW < zH)) Then                 ThisDrawing.ActiveLayout.PlotRotation = ac0degrees             Else                 ThisDrawing.ActiveLayout.PlotRotation = ac90degrees             End If         Case "  0度"             ThisDrawing.ActiveLayout.PlotRotation = ac0degrees         Case " 90度"             ThisDrawing.ActiveLayout.PlotRotation = ac90degrees         Case "180度"             ThisDrawing.ActiveLayout.PlotRotation = ac180degrees         Case "270度"             ThisDrawing.ActiveLayout.PlotRotation = ac270degrees         Case Else             P_DWG = -1             ThisDrawing.SetVariable "BACKGROUNDPLOT", 2             Exit Function     End Select     '设置打印比例，Paper_Units控制尺寸单位     Select Case Paper_Units         Case "英寸"             ThisDrawing.ActiveLayout.PaperUnits = acInches         Case "毫米"             ThisDrawing.ActiveLayout.PaperUnits = acMillimeters         Case "像素"             ThisDrawing.ActiveLayout.PaperUnits = acPixels         Case Else             P_DWG = -1             ThisDrawing.SetVariable "BACKGROUNDPLOT", 2             Exit Function     End Select     If CustomScale < 0 Then         P_DWG = -1         ThisDrawing.SetVariable "BACKGROUNDPLOT", 2         Exit Function     End If     If CustomScale = 0 Then         ThisDrawing.ActiveLayout.StandardScale = acScaleToFit     Else         ThisDrawing.ActiveLayout.SetCustomScale 1, CustomScale     End If     '设置偏移量     Dim NewValue(0 To 1) As Double     If Plot_Origin = "," Or Plot_Origin = "0,0" Then         ThisDrawing.ActiveLayout.CenterPlot = True     Else         NewValue(0) = Val(Plot_Origin)         NewValue(1) = Val(Right(Plot_Origin, Len(Plot_Origin) - InStr(Plot_Origin, ",")))         ThisDrawing.ActiveLayout.PlotOrigin = NewValue     End If    '设置打印份数     ThisDrawing.Plot.NumberOfCopies = Number_Copies     '区分打印的类型     Select Case P_Option         Case 0  '空操作             P_DWG = 1             Exit Function         Case 1      '打印到设备             If ThisDrawing.Plot.PlotToDevice Then P_DWG = 1 Else P_DWG = 0         Case 2      '打印到文件             If Exists(FilePath & Extension) Then                 If MsgBox(FilePath & Extension & " 已经存在。是否覆盖原文件？", vbYesNo, "覆盖文件") = vbYes Then                     If ThisDrawing.Plot.PlotToFile(FilePath & Extension) Then P_DWG = 1 Else P_DWG = 0                 End If             Else                 If ThisDrawing.Plot.PlotToFile(FilePath & Extension) Then P_DWG = 1 Else P_DWG = 0             End If         Case 3      '打印预览             ThisDrawing.Plot.DisplayPlotPreview acFullPreview             P_DWG = 1         Case Else             P_DWG = -1     End Select     If Val(ThisDrawing.Application.Version) >= 16.2 Then         ThisDrawing.SetVariable "BACKGROUNDPLOT", 2     End If     Exit Function Err_handle:     Select Case Err.Number         Case -2145386493        '打印单位设置错误             P_DWG = -1         Case Else             P_DWG = -2     End Select End Function

lennie

有人看了我的Flash向我要源码 就放到这里吧 顺便赚点积分

不是专业人员 很多地方写得不专业 请见谅

函数参数说明：

zx,ys打印区域左下点坐标(用string传递主要是参数表太长了，呵呵，很不专业 有空的话可以改成数组)

P_Option 打印方式
   0 不操作（仅设置打印区域）
   1 打印到设备
   2打印到文件

其他参数应该很容易看懂的。另外Degree= "自 动" 就是可以根据打印区域的高宽比自动选纸张大小。

halop

用什么写的啊？

3xxx

这个记下了研究一下。