module1.bas

将路面检测数据输出到CAD

Attribute VB_Name = "Module1"
Option Explicit
Public acadObj As Object
Public newDimStyle As Object
Public AcadDoc As Object 'AutoCAD文档(图形文件)对象
Public moSpace As Object 'Model Space对象集合
Public paSpace As Object 'Paper Space对象集合


Public Function AcadOpen()
    '以下连接AutoCAD R14
    On Error Resume Next
    Set acadObj = GetObject(, "AutoCAD.Application")
    If Err Then
        Tgg.Message.Caption = "正在打开AutoCad,请稍候... ..."
        Set acadObj = CreateObject("AutoCAD.Application")
        Err.Clear
    End If
    acadObj.Visible = True
End Function

Public Function AcadLine(startPoint As Variant, endPoint As Variant, color As ACAD_COLOR, Lt As ACAD_LTYPE)
    Dim anObj As Object
    '绘制直线
    Set anObj = acadObj.ActiveDocument.ModelSpace.AddLine(startPoint, endPoint)
    anObj.color = color
    anObj.Linetype = Lt
    anObj.LinetypeScale = Val(Tgg.Ls.Text)
End Function

Public Function AcadDimAligned(startPoint As Variant, endPoint As Variant, location As Variant)
    Dim anObj As Object
    '定位目标
    Set anObj = acadObj.ActiveDocument.ModelSpace.AddDimAligned(startPoint, endPoint, location)
End Function

Public Function AcadText(textString As String, startPoint As Variant, Height As Variant, Angle As Variant)
    Dim anObj As Object
    '写入文本
    Set anObj = acadObj.ActiveDocument.ModelSpace.AddText(textString, startPoint, Height)
    anObj.Rotate startPoint, Angle '3.141592654 / 2
    'anObj.ScaleFactor = 0.7
End Function
Public Function AcadPLine(points As Variant)
    Dim anObj As Object
    '绘点creates a light weight polyline Object in model space
    Set anObj = acadObj.ActiveDocument.ModelSpace.AddPolyline(points)
End Function

Public Function AcadCircle(centerpoint As Variant, radius As Variant)
    Dim anObj As Object
    '绘制圆
    Set anObj = acadObj.ActiveDocument.ModelSpace.AddCircle(centerpoint, radius)
End Function

Public Function AcadLayer(LayerName As String, color As Integer)
    Dim anObj As Object
    '增加图层
    Set anObj = acadObj.ActiveDocument.Layers.Add(LayerName)
    anObj.color = color
    acadObj.ActiveDocument.ActiveLayer = anObj
End Function

Public Function AcadTextStyle(TextStyleName As String)
    '命名当前CAD字体
    Dim txtStyle As Object
    Dim currentTextStyle As Object
    
    Set txtStyle = acadObj.ActiveDocument.TextStyles.Add(TextStyleName)
    
'   这里改变字体
'    txtStyle.BigFontFile = "hztxt.shx"
'    txtStyle.fontFile = "romans.shx"
'
'    acadObj.ActiveDocument.ActiveTextStyle = txtStyle
End Function