坐标系转换.txt

该程序为VB程序,是用于计算出来的坐标需要进行坐标系转换使用.感谢站长

Public AcadApp As Object 'AcadApplication
Public Const Pi As Double = 3.1415926535359
Public Point(0 To 2) As Variant
Public Point1(0 To 2) As Double
Public Point2(0 To 2) As Double
Public Point3(0 To 2) As Double
Public Point4(0 To 2) As Double
Public Point5(0 To 2) As Double
Public Point6(0 To 2) As Double
Public Point7(0 To 2) As Double
Public Point8(0 To 2) As Double
Public Var(2) As Variant
Public XdataOut As Variant
Public XtypeOut As Variant

Public newUCS As Object 'AcadUCS
Public currUCS As Object 'AcadUCS
Public Layer0 As Object 'AcadLayer
Public Layer1 As Object 'AcadLayer
Public Layer2 As Object 'AcadLayer
Public Layer3 As Object 'AcadLayer

Public Sub LoadCAD()
On Error Resume Next
Set AcadApp = GetObject(, "AutoCAD.Application")
If Err Then
    Err.Clear
    Set AcadApp = CreateObject("AutoCAD.Application")
    If Err Then
        MsgBox "请安装相应版本的Auto CAD!        ", 48
        End
    End If
End If
AcadApp.Visible = True
AcadApp.WindowState = acMax

'lHwnd = GetParent(GetParent(AcadApp.ActiveDocument.hwnd))
'If lHwnd = 0 Then Exit Sub
'SetParent lHwnd, FCAD.hwnd
End Sub

Public Function WcsToUcs(Vdata As Variant) As Variant()
'On Error Resume Next
LoadCAD
'保存旧的坐标系统到currUCS
If AcadApp.ActiveDocument.GetVariable("UCSNAME") = "" Then
    With AcadApp.ActiveDocument
        Set currUCS = .UserCoordinateSystems.Add( _
                      .GetVariable("UCSORG"), _
                      .Utility.TranslateCoordinates(.GetVariable("UCSXDIR"), acUCS, acWorld, 0), _
                      .Utility.TranslateCoordinates(.GetVariable("UCSYDIR"), acUCS, acWorld, 0), _
                       "OriginalUCS")
    End With
Else
    Set currUCS = AcadApp.ActiveDocument.ActiveUCS  'current UCS is saved
End If
AcadApp.ActiveDocument.ActiveUCS = currUCS
Vdata = AcadApp.ActiveDocument.Utility.TranslateCoordinates(Vdata, acWorld, acUCS, False)
Var(0) = Vdata(0)
Var(1) = Vdata(1)
Var(2) = Vdata(2)

WcsToUcs = Var
End Function

Public Function UcsToWcs(Vdata As Variant) As Variant()
'On Error Resume Next
LoadCAD
'保存旧的坐标系统到currUCS
If AcadApp.ActiveDocument.GetVariable("UCSNAME") = "" Then
    With AcadApp.ActiveDocument
        Set currUCS = .UserCoordinateSystems.Add( _
                      .GetVariable("UCSORG"), _
                      .Utility.TranslateCoordinates(.GetVariable("UCSXDIR"), acUCS, acWorld, 0), _
                      .Utility.TranslateCoordinates(.GetVariable("UCSYDIR"), acUCS, acWorld, 0), _
                       "OriginalUCS")
    End With
Else
    Set currUCS = AcadApp.ActiveDocument.ActiveUCS  'current UCS is saved
End If
AcadApp.ActiveDocument.ActiveUCS = currUCS
Vdata = AcadApp.ActiveDocument.Utility.TranslateCoordinates(Vdata, acUCS, acWorld, False)
Var(0) = Vdata(0)
Var(1) = Vdata(1)
Var(2) = Vdata(2)
UcsToWcs = Var
End Function

'转换图元的函数
Public Function axEnt2lspEnt(entObj As Object) As String
    Dim entHandle As String
    entHandle = entObj.Handle
    axEnt2lspEnt = "(handent" & Chr(34) & entHandle & Chr(34) & ")"
End Function


'转换点的函数
Public Function axPoint2lspPoint(Pnt As Variant) As String
    axPoint2lspPoint = Pnt(0) & "," & Pnt(1) & ",0" ' & Pnt(2)
End Function