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

黄玉宏 发表于 2006-5-31 10:08:00

各位高手和斑主：你们好！
有一个问题想请教各位，我做了一个图纸模板，想自动添加当前日期。现在自动添加日期已解决了，可出现了每次打开时均添加一次日期的情况，这样就在同一地方有多个日期的情况。不知怎样在关闭CAD文档时自动删除添加的日期(还有别的其它有用的单行文字，不能删除)。以下是我写的自动添加代码，请各位帮助解决关闭时自动删除日期(单行文字)的问题，拜托了！
Private Sub AcadDocument_Activate()  '自动添加日期(单行文字)<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>
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
<o:p> </o:p>
黄玉宏　　2006.5.31

xinghesnak 发表于 2006-5-31 16:57:00

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

黄玉宏 发表于 2006-5-31 18:26:00

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

xinghesnak 发表于 2006-6-1 11:38:00

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 发表于 2006-6-1 11:38:00

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

黄玉宏 发表于 2006-6-1 15:43:00

感谢<A name=16416>xinghesnak</A>回复，字体问题我在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
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p> </o:p>

xinghesnak 发表于 2006-6-2 08:42:00

说一下你的程序中的三个问题：
1，你在程序中用的是AcadDocument的Activate和Deactivate时间，这两个事件表示激活或者不激活当前图形。而不是你要的打开图形，或者关闭图形。建议用BeforeClose事件。
2。你用过滤器的时候，只检测到含有日期的文字，假如你的图形中还含有同样的的日期文字，那就一并删了。会不会造成你的程序将来有问题？建议再增加检测条件，来减小误删除的可能性。
3。在Activate事件中无条件的添加日期文字，会造成大量的文字迭放在一起。所以建议在Addtext之前先检测指定位置有没有日期文字再进行添加
以上只是我个人的看法，可能你的程序有自己适用的环境，仅供参考吧！

黄玉宏 发表于 2006-6-2 13:45:00

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

luojie110 发表于 2017-12-20 17:25:54

VBA的编程很

dong20030432 发表于 2018-5-3 12:05:58

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

页: [1]

明经CAD社区's Archiver

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