[VBA函数]：如何编这样一个程序？

wunanyx

在vba中转换坐标很麻烦，我想用一条线（2d的线）和一个点就确定坐标系（2d的转换，非3d的，z始终为0），就像cad命令里的ucs  “e” 选择一条直线，用选择点做原点的那种！

efan2000

也很简单啊，自己做一个函数。以下的函数基本实现了这个功能，不过实际应用中自己还要完善一下。

2. 
   
3.   [FONT=courier new]
   
4. 
   
5. Sub SetUCS(ByVal Origin As Variant, ByVal LineObj As AcadLine)
   
6.     Dim ucsObj As AcadUCS
   
7.    
   
8.     On Error Resume Next
   
9.    
   
10.     '先求出原点在直线上的投影。
    
11.     Dim Ang As Double
    
12.     Ang = ThisDrawing.Utility.AngleFromXAxis(LineObj.StartPoint, Origin)
    
13.     Dim Dis As Double
    
14.     Dis = Sqr((LineObj.StartPoint(0) - Origin(0)) ^ 2 + (LineObj.StartPoint(1) - Origin(1)) ^ 2)
    
15.     Dim NewOrigin As Variant
    
16.     NewOrigin = ThisDrawing.Utility.PolarPoint(LineObj.StartPoint, LineObj.Angle, Dis * Cos(LineObj.Angle - Ang))
    
17. 
    
18.     '再求出与直线垂直的一个点。
    
19.     Dim NewyAxisPoint As Variant
    
20.     NewyAxisPoint = ThisDrawing.Utility.PolarPoint(NewOrigin, LineObj.Angle + ThisDrawing.Utility.AngleToReal(90, acDegrees), 1)
    
21.    
    
22.     Set ucsObj = ThisDrawing.UserCoordinateSystems.Add(NewOrigin, LineObj.StartPoint, NewyAxisPoint, "MyUCS")
    
23. 
    
24.     ThisDrawing.ActiveUCS = ucsObj
    
25. End Sub
    
26. 
    
27. Sub Test()
    
28. 
    
29.     Dim Origin(0 To 2) As Double
    
30.     Dim xAxisPoint(0 To 2) As Double
    
31.     Dim yAxisPoint(0 To 2) As Double
    
32.    
    
33.     Origin(0) = 2: Origin(1) = 2: Origin(2) = 0
    
34.     xAxisPoint(0) = 3: xAxisPoint(1) = 2: xAxisPoint(2) = 0
    
35.     yAxisPoint(0) = 2: yAxisPoint(1) = 3: yAxisPoint(2) = 0
    
36.    
    
37.     Dim LineObj As AcadLine
    
38.     Set LineObj = ThisDrawing.ModelSpace.AddLine(xAxisPoint, yAxisPoint)
    
39.    
    
40.     Call SetUCS(Origin, LineObj)
    
41. End Sub
    
42. 
    
43.   [/FONT]
    

<br />   [FONT=courier new]<br /> <br /> Sub SetUCS(ByVal Origin As Variant, ByVal LineObj As AcadLine)<br />     Dim ucsObj As AcadUCS<br />     <br />     On Error Resume Next<br />     <br />     '先求出原点在直线上的投影。<br />     Dim Ang As Double<br />     Ang = ThisDrawing.Utility.AngleFromXAxis(LineObj.StartPoint, Origin)<br />     Dim Dis As Double<br />     Dis = Sqr((LineObj.StartPoint(0) - Origin(0)) ^ 2 + (LineObj.StartPoint(1) - Origin(1)) ^ 2)<br />     Dim NewOrigin As Variant<br />     NewOrigin = ThisDrawing.Utility.PolarPoint(LineObj.StartPoint, LineObj.Angle, Dis * Cos(LineObj.Angle - Ang))<br /> <br />     '再求出与直线垂直的一个点。<br />     Dim NewyAxisPoint As Variant<br />     NewyAxisPoint = ThisDrawing.Utility.PolarPoint(NewOrigin, LineObj.Angle + ThisDrawing.Utility.AngleToReal(90, acDegrees), 1)<br />     <br />     Set ucsObj = ThisDrawing.UserCoordinateSystems.Add(NewOrigin, LineObj.StartPoint, NewyAxisPoint, "MyUCS")<br /> <br />     ThisDrawing.ActiveUCS = ucsObj<br /> End Sub<br /> <br /> Sub Test()<br /> <br />     Dim Origin(0 To 2) As Double<br />     Dim xAxisPoint(0 To 2) As Double<br />     Dim yAxisPoint(0 To 2) As Double<br />     <br />     Origin(0) = 2: Origin(1) = 2: Origin(2) = 0<br />     xAxisPoint(0) = 3: xAxisPoint(1) = 2: xAxisPoint(2) = 0<br />     yAxisPoint(0) = 2: yAxisPoint(1) = 3: yAxisPoint(2) = 0<br />     <br />     Dim LineObj As AcadLine<br />     Set LineObj = ThisDrawing.ModelSpace.AddLine(xAxisPoint, yAxisPoint)<br />     <br />     Call SetUCS(Origin, LineObj)<br /> End Sub<br /> <br />   [/FONT]<br />

lijiao

最初由 wunanyx 发布
[B]在vba中转换坐标很麻烦，我想用一条线（2d的线）和一个点就确定坐标系（2d的转换，非3d的，z始终为0），就像cad命令里的ucs  “e” 选择一条直线，用选择点做原点的那种！ [/B]

在VBA中，绝大多数方法都要求世界坐标系，如果采用UCS，就需要转换，如果采用WCS，不就可以去掉这些烦恼吗？