[求助]：启动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
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

zxhliu

楼主厉害，这样的文章竟然没有人来顶，希望那个以后常看到你的文章。