[求助]启动CAD时自动添加日期关闭时自动删除

黄玉宏

各位高手和斑主：你们好！

有一个问题想请教各位，我做了一个图纸模板，想自动添加当前日期。现在自动添加日期已解决了，可出现了每次打开时均添加一次日期的情况，这样就在同一地方有多个日期的情况。不知怎样在关闭CAD文档时自动删除添加的日期(还有别的其它有用的单行文字，不能删除)。以下是我写的自动添加代码，请各位帮助解决关闭时自动删除日期(单行文字)的问题，拜托了！

Private Sub AcadDocument_Activate()  '自动添加日期(单行文字)

Dim TextObj As AcadText

Dim TextString As String

Dim InsPnt(0 To 2) As Double

Dim Height As Double

Set FontStyle = ThisDrawing.TextStyles.Add("宋体长型0.67")

FontStyle.SetFont "宋体", False, False, 0, 0

If Not Err Then ThisDrawing.ActiveTextStyle = FontStyle

FontStyle.Height = 6

FontStyle.Width = 0.4

ThisDrawing.ActiveTextStyle = FontStyle

InsPnt(0) = 259: InsPnt(1) = 1.8: InsPnt(2) = 0

Height = 6.5

TextString = Format(ConvertJulianDate(ThisDrawing.GetVariable("DATE")), "YYYY.MM.DD")

Set TextObj = ThisDrawing.ModelSpace.AddText(TextString, InsPnt, Height)

End Sub

Public Function ConvertJulianDate(julianDate As Double) As Date    '加载在模块中

ConvertJulianDate = julianDate - 2415019

End Function

 

黄玉宏　　2006.5.31

xinghesnak

给你提一个思路（没有验证过）；可以把生成的文字的句柄存在系统变量里，然后在关闭事件里删除句柄对应的对象。。。。你试一试行不行，不行的话你再回个帖子吧！

黄玉宏

谢谢2楼的回复，可是我没有你所说的那种水平，我是5.3日才开始学CADVBA的，当初学习是为了编制一个多段线绘制公路横断面程序，现在程序已结束了，但水平提高不快。不知各位能否帮忙实现我的愿望！再次谢谢！

黄玉宏　二○○六年五月三十一日

xinghesnak

Private Sub AcadDocument_Activate() 

Dim TextObj As AcadText

Dim TextString As String

Dim InsPnt(0 To 2) As Double

Dim Height As Double

Set FontStyle = ThisDrawing.TextStyles.Add("ËÎÌ峤ÐÍ0.67")

FontStyle.SetFont "ËÎÌå", False, False, 0, 0

If Not Err Then ThisDrawing.ActiveTextStyle = FontStyle

FontStyle.Height = 6

FontStyle.Width = 0.4

ThisDrawing.ActiveTextStyle = FontStyle

InsPnt(0) = 259: InsPnt(1) = 1.8: InsPnt(2) = 0

Height = 6.5

TextString = Format(ConvertJulianDate(ThisDrawing.GetVariable("DATE")), "YYYY.MM.DD")

 

Set TextObj = ThisDrawing.ModelSpace.AddText(TextString, InsPnt, Height)

ThisDrawing.SetVariable "USERS2", TextObj.Handle

End Sub

Public Function ConvertJulianDate(julianDate As Double) As Date   

ConvertJulianDate = julianDate - 2415019

End Function

Private Sub AcadDocument_BeginSave(ByVal FileName As String)

On Error Resume Next
ThisDrawing.HandleToObject(ThisDrawing.GetVariable("USERS2")).Delete
On Error GoTo 0
End Sub

这里没有提重复文字的问题，我现在也没有确切的方法判断原来的那个位置是否存在你创建过的时间文字。要是通过插入点＋块类型判断可能也不准确。这个方面你自己想想吧！

xinghesnak

呵呵！不知道字体怎么显示不出来。。。。

黄玉宏

感谢xinghesnak回复，字体问题我在CAD2006版上未发现。这个问题我自己也刚刚用选择集解决，现拿出来与大家一起讨论。

Private Sub AcadDocument_Activate()

Dim TextObj As AcadText

Dim TextString As String

Dim InsPnt(0 To 2) As Double

Dim Height As Double

Set FontStyle = ThisDrawing.TextStyles.Add("宋体长型0.67")

FontStyle.SetFont "宋体", False, False, 0, 0

If Not Err Then ThisDrawing.ActiveTextStyle = FontStyle

FontStyle.Height = 6

FontStyle.Width = 0.4

ThisDrawing.ActiveTextStyle = FontStyle

InsPnt(0) = 259: InsPnt(1) = 1.8: InsPnt(2) = 0

Height = 6.5

s = Format(ConvertJulianDate(ThisDrawing.GetVariable("DATE")), "YYYY.MM.DD")

TextString = s

Set TextObj = ThisDrawing.ModelSpace.AddText(TextString, InsPnt, Height)

End Sub

Private Sub AcadDocument_Deactivate()

Dim SSetObj As AcadSelectionSet

Set SSetObj = ThisDrawing.SelectionSets.Add("DelDateText")

'创建过滤器Text(单行文本)、Mtext(多行文本)

Dim fType(0) As Integer

Dim fData(0) As Variant

fType(0) = 0

fData(0) = "Text,Mtext"

'选择全部的Text、Mtext

SSetObj.Select acSelectionSetAll, , , fType, fData

If SSetObj.Count <> 0 Then

Dim i As Integer

For i = 0 To SSetObj.Count - 1

'Text和Mtext中显示的是TextString

If SSetObj(i).TextString = s Then SSetObj(i).Delete

Next

End If

SSetObj.Delete

Set SSetObj = Nothing

End Sub

'以下加载在模块内：

Public s As String  '申明S(存放当前日期)全局字符变量,这点很重要。两过程共用此变量！

Public Function ConvertJulianDate(julianDate As Double) As Date

ConvertJulianDate = julianDate - 2415019

End Function

感谢明经通道！感谢晓东CAD！　黄玉宏　2006.6.1

 

xinghesnak

说一下你的程序中的三个问题：

1，你在程序中用的是AcadDocument的Activate和Deactivate时间，这两个事件表示激活或者不激活当前图形。而不是你要的打开图形，或者关闭图形。建议用BeforeClose事件。

2。你用过滤器的时候，只检测到含有日期的文字，假如你的图形中还含有同样的的日期文字，那就一并删了。会不会造成你的程序将来有问题？建议再增加检测条件，来减小误删除的可能性。

3。在Activate事件中无条件的添加日期文字，会造成大量的文字迭放在一起。所以建议在Addtext之前先检测指定位置有没有日期文字再进行添加

以上只是我个人的看法，可能你的程序有自己适用的环境，仅供参考吧！

黄玉宏

谢谢xinghesnak，诚如你所言，我的程序有特定的使用环境。关于 Activate和Deactivate事件，我是先做VB后做ExcelVBA再做CADVBA的，这两个事件确实应如此用。打开CAD必然激发Activate事件(在Excel中修改系统本身一般放在此事件中)，关闭CAD也必然激发Deactivate事件(恢复对Excel系统的修改放在此事件中，而千万不能放在BeforeClose事件中,因关闭中途还可再次使用取消命令)。我对CAD的编程绝大多数是在Excel中，因其有强大的数据查询、复制、筛选等功能，一般可只是交CAD看作是其一个高级绘图控件。向你学习主，衷心感谢你助人为乐的精神！

黄玉宏　　二○○六年六月二日

luojie110

VBA的编程很

dong20030432

使用扩展数据给日期对象添加特殊标记，就能避免误删除问题，检测不到时就创建新对象即可。