田草CAD工具箱—>自动绘制PKPM轴线网 -

PKPM窗口激活后应在英文输入法状态下，才可以使用,而且要在AutoCAD的编辑模式下使用。

(更新2009-9-1)

1、解决绘制坐标在pkpm绘图区之外。
2、解决轴线数据取整不精确问题。
3、发现错误可以中途退出。
4、制作了一个Flash教程。

用下面的从cad中提取直线数据：使用田草工具箱中的统计工具，里面有一个可以提取直线数据的。

按此在新窗口打开图片

用下面的在pkpm中进行自动输入数据：

下面是自动绘制的一段视频：

下面是程序文件：

点击下载此文件

在AutoCAD中提取轴线数据的VBA程序：

点击下载此文件

安装方法
AotoCAD->工具->加载应用程序-> 启动->内容

然后再cad的命令行输入 -vbarun Ldata
就可以读取轴线的数据了。最好在读取轴线数据之前将轴线移到(0,0,0)点附近。

[本日志由 tiancao1001 于 2019-07-13 04:57 PM 编辑]

分享到： QQ空间新浪微博腾讯微博微信更多

tiancao1001 于 2009-02-22 11:25 PM 发表评论：

Sub XXX()
   On Error GoTo ErrControl

    Dim SSet As AcadSelectionSet
    Set SSet = CreateSelectionSet("XXX")
    Dim fType, fData
    BuildFilter fType, fData, 0, "LWPolyline"

    '选择矩形
    SSet.SelectOnScreen fType, fData

    Dim PL As AcadLWPolyline
    Dim New_Pl  As Variant
    Dim Pmin As Variant
    Dim Pmax As Variant
    Dim L As Double
    Dim H As Double
    For Each PL In SSet
        '偏移矩形
        New_Pl = PL.offset(100)
        '偏移后的矩形角点
        New_Pl(0).GetBoundingBox Pmin, Pmax
        L = Pmin(0) - Pmax(0) '矩形长
        H = Pmax(1) - Pmax(1) '矩形宽
        '在矩形内部写上长x宽
        TxtHatch Format(L, "0.00") & "x" & Format(H, "0.00"), Pmin, Pmax, 0
        PL.Delete
    Next
ErrControl:

End Sub
Public Function TxtHatch(ByVal Str As String, ByVal P1 As Variant, P2 As Variant, a As Double) As AcadText
    Dim Txt As AcadText
    Dim TxtH As Double
    Dim TxtL As Double
    Dim RecL As Double
    Dim RecH  As Double
    Dim Center1(2) As Double
    Dim Pmin As Variant, Pmax As Variant
    If Abs(P1(0) - P2(0)) = 0 Or Abs(P1(1) - P2(1)) = 0 Then Exit Function
    If a = 0 Then
        RecL = Abs(P1(0) - P2(0))
        RecH = Abs(P1(1) - P2(1))
    Else
        RecL = Abs(P1(1) - P2(1))
        RecH = Abs(P1(0) - P2(0))
    End If
    Center1(0) = (P1(0) + P2(0)) / 2
    Center1(1) = (P1(1) + P2(1)) / 2
    Center1(2) = (P1(2) + P2(2)) / 2
    Set Txt = ThisDrawing.ModelSpace.AddText(Str, Point3D(0, 0, 0), 2.5)
    Txt.GetBoundingBox Pmin, Pmax
    TxtL = Abs(Pmin(0) - Pmax(0))
    TxtH = Abs(Pmin(1) - Pmax(1))
    If RecL / TxtL <= RecH / TxtH Then
        Txt.ScaleEntity Pmin, RecL / TxtL
    Else
        Txt.ScaleEntity Pmin, RecH / TxtH
    End If
    Txt.Alignment = acAlignmentMiddleCenter
    Txt.Move Txt.TextAlignmentPoint, Center1
    Txt.Rotate Center1, a * Atn(1) * 4 / 180
    Set TxtHatch = Txt
End Function

tiancao1001 于 2009-02-21 10:08 AM 发表评论：

你好当然可以。稍后给你献上。
感谢支持，

longer1000 于 2009-02-21 09:14 AM 发表评论：

你好!能否编写这样一个cad工具--自动编写矩形编号的程序。
设想方法如下：
选择批量的矩形，再向矩形中心方向偏移相同的数值，删除原选择的矩形，最后在偏移的矩形内填写相应的长度*宽度。
在此表示谢意

田草于 2008-01-21 12:15 AM 发表评论：

现在还有二问题：

1、读取的轴线不在PKPM的屏幕中间，导致绘制不出来，要移动PKPM坐标，才能正确绘制。
2、还有就是在有些时候，会出现第一跟轴线或最后一根绘制错误。

田草于 2007-11-15 11:04 PM 发表评论：

这个程序可能只有我pkpm好用，这个于版本有问题，pkpm的本身又有cad编辑方式和pkpm编辑方式，pkpm自己本身的窗体控件的焦点就很乱，我没法写出通用的。

田草于 2007-08-08 04:49 PM 发表评论：

这个怪名肯定是老妖的。

你学习c++干嘛？

这个也不难，不过我还是用vb 偶尔用c++

dylan_sue 于 2007-08-07 08:34 PM 发表评论：

老苗，kolapyka是谁啊？应该是咱们班的，强的了，凌晨两点半还在线上！