在CAD中以真实比例尺看图

guohq

1. ''' <summary>
   
2.     ''' 以真实比例尺查看
   
3.     ''' </summary>
   
4.     ''' <param name="dScale">比例尺大小 如 2000 1000 等（大于0 的一个数）</param>
   
5.     ''' <remarks></remarks>
   
6.     Public Sub ViewWithRealScale(ByVal dScale As Double, ByVal cPt As Point2d)
   
7.         If dScale <= 0 Then
   
8.             Exit Sub
   
9.         End If
   
10. 
    
11.         Dim VtrRec As Point2d = Application.GetSystemVariable("screensize")
    
12.         Dim newVtr As New ViewTableRecord
    
13.         newVtr.CenterPoint = cPt
    
14. 
    
15.         Dim PixelHeight As Integer = 0, PixelWidth As Integer = 0
    
16.         GetPhysicalScreenSize(PixelWidth, PixelHeight)
    
17. 
    
18.         newVtr.Height = (PixelHeight * VtrRec.Y / My.Computer.Screen.Bounds.Height) * dScale / 1000.0
    
19. 
    
20.         Doc.Editor.SetCurrentView(newVtr)
    
21.         Doc.Editor.UpdateScreen()
    
22.     End Sub
    
23. 
    
24.     ''' <summary>
    
25.     ''' 访问使用设备描述表的设备数据
    
26.     ''' </summary>
    
27.     ''' <param name="hdc">设备上下文环境的句柄</param>
    
28.     ''' <param name="nIndex">指定返回项</param>
    
29.     ''' <returns></returns>
    
30.     ''' <remarks></remarks>
    
31.     <DllImport("GDI32.dll")> _
    
32.     Public Shared Function GetDeviceCaps(ByVal hdc As Integer, ByVal nIndex As Integer) As Integer
    
33.     End Function
    
34. 
    
35. 
    
36.     <DllImport("user32.dll")> _
    
37.     Public Shared Function GetDC(ByVal hwnd As Integer) As Integer
    
38.     End Function
    
39. 
    
40. 
    
41.     <DllImport("user32.dll")> _
    
42.     Public Shared Function ReleaseDC(ByVal hwnd As Integer, ByVal hdc As Integer) As Long
    
43.     End Function
    
44. 
    
45.     ''' <summary>
    
46.     ''' 返回桌面窗口的句柄
    
47.     ''' </summary>
    
48.     ''' <returns></returns>
    
49.     ''' <remarks></remarks>
    
50.     <DllImport("user32.dll")> _
    
51.     Public Shared Function GetDesktopWindow() As Integer
    
52.     End Function
    
53. 
    
54.     ''' <summary>
    
55.     ''' 获取显示器的物理尺寸
    
56.     ''' </summary>
    
57.     ''' <param name="iWidth">屏幕的宽度</param>
    
58.     ''' <param name="iHeight">屏幕的高度</param>
    
59.     ''' <remarks>单位：毫米</remarks>
    
60.     Public Shared Sub GetPhysicalScreenSize(ByRef iWidth As Integer, ByRef iHeight As Integer)
    
61.         '状态：20121106-1512测试通过
    
62.         Dim hDesktopWnd As Integer = GetDesktopWindow()
    
63.         Dim hdcCaps As Integer = GetDC(hDesktopWnd)
    
64.         iWidth = GetDeviceCaps(hdcCaps, 4)
    
65.         iHeight = GetDeviceCaps(hdcCaps, 6)
    
66.         ReleaseDC(hDesktopWnd, hdcCaps)
    
67.     End Sub

''' <summary><br />     ''' 以真实比例尺查看<br />     ''' </summary><br />     ''' <param name="dScale">比例尺大小 如 2000 1000 等（大于0 的一个数）</param><br />     ''' <remarks></remarks><br />     Public Sub ViewWithRealScale(ByVal dScale As Double, ByVal cPt As Point2d)<br />         If dScale <= 0 Then<br />             Exit Sub<br />         End If<br /> <br />         Dim VtrRec As Point2d = Application.GetSystemVariable("screensize")<br />         Dim newVtr As New ViewTableRecord<br />         newVtr.CenterPoint = cPt<br /> <br />         Dim PixelHeight As Integer = 0, PixelWidth As Integer = 0<br />         GetPhysicalScreenSize(PixelWidth, PixelHeight)<br /> <br />         newVtr.Height = (PixelHeight * VtrRec.Y / My.Computer.Screen.Bounds.Height) * dScale / 1000.0<br /> <br />         Doc.Editor.SetCurrentView(newVtr)<br />         Doc.Editor.UpdateScreen()<br />     End Sub<br /> <br />     ''' <summary><br />     ''' 访问使用设备描述表的设备数据<br />     ''' </summary><br />     ''' <param name="hdc">设备上下文环境的句柄</param><br />     ''' <param name="nIndex">指定返回项</param><br />     ''' <returns></returns><br />     ''' <remarks></remarks><br />     <DllImport("GDI32.dll")> _<br />     Public Shared Function GetDeviceCaps(ByVal hdc As Integer, ByVal nIndex As Integer) As Integer<br />     End Function<br /> <br /> <br />     <DllImport("user32.dll")> _<br />     Public Shared Function GetDC(ByVal hwnd As Integer) As Integer<br />     End Function<br /> <br /> <br />     <DllImport("user32.dll")> _<br />     Public Shared Function ReleaseDC(ByVal hwnd As Integer, ByVal hdc As Integer) As Long<br />     End Function<br /> <br />     ''' <summary><br />     ''' 返回桌面窗口的句柄<br />     ''' </summary><br />     ''' <returns></returns><br />     ''' <remarks></remarks><br />     <DllImport("user32.dll")> _<br />     Public Shared Function GetDesktopWindow() As Integer<br />     End Function<br /> <br />     ''' <summary><br />     ''' 获取显示器的物理尺寸<br />     ''' </summary><br />     ''' <param name="iWidth">屏幕的宽度</param><br />     ''' <param name="iHeight">屏幕的高度</param><br />     ''' <remarks>单位：毫米</remarks><br />     Public Shared Sub GetPhysicalScreenSize(ByRef iWidth As Integer, ByRef iHeight As Integer)<br />         '状态：20121106-1512测试通过<br />         Dim hDesktopWnd As Integer = GetDesktopWindow()<br />         Dim hdcCaps As Integer = GetDC(hDesktopWnd)<br />         iWidth = GetDeviceCaps(hdcCaps, 4)<br />         iHeight = GetDeviceCaps(hdcCaps, 6)<br />         ReleaseDC(hDesktopWnd, hdcCaps)<br />     End Sub

guohq

可以拿尺子在屏幕上试一下，很准的。前提：CAD中长度的单位为米

pengfei2010

请问这个是用vb.net编写的代码么？本人很想学习vb.net