图层名对应批量修改
'Auto2004 使用C:\新旧图层名对照设定文件.INI 文件中设定的对应关系对当前图形文件图层更名
'可对含有中文的DWG档图层名修改以便UG读入
'INI文件中 [NEW_NAME]项目下为需修改的新图层名； [OLD_NAME]项目下为需修改的旧图层名
'Change_row_count ＝ 9 代表需修改的新旧图层行数
'使用的宏文件源代码如下： 作者 逍昇wensanren
Option Explicit
Private Declare Function GetPrivateProfileString Lib "kernel32" _
Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal nSize As Long, _
ByVal lpFileName As String) As Long
Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias _
"GetVolumeInformationA" (ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Integer, _
lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long
Sub replayer()
On Error Resume Next
Const IniFile_Path = "C:\新旧图层名对照设定文件.INI"
Const ForReading = 1, ForWriting = 2, ForAppending = 3, TristateFalse = 0
'TristateFalse
0 以 ASCII 格式打开文件
Dim fs, f As Object
Dim i, u, j, RowCount As Integer
Dim ent As AcadEntity
Dim Layerobj As AcadLayer
Dim oldname, newname, OLDNAMEFLAG, NEWNAMEFLAG, OldStr, NewStr, TMPSTR As String
Dim Msg, Style, Title, Response, MyString
Msg = "[新图层名] 替代 [旧图层名] ?"
' 定义信息。
'Msg = "汉字 -> 字母(ASCII) ?"
Style = vbYesNo + vbCritical + vbDefaultButton2
' 定义按钮。
Title = "MsgBox Demonstration"
' 定义标题。
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then
' 用户按下“是”。[新图层名]替代[旧图层名]
OLDNAMEFLAG = "OLD_NAME"
NEWNAMEFLAG = "NEW_NAME"
Else
' 用户按下“否”。[旧图层名]替代[新图层名]
OLDNAMEFLAG = "NEW_NAME"
NEWNAMEFLAG = "OLD_NAME"
End If
RowCount = CLng(ReadIniFile(IniFile_Path, "Change_row_count", "Change_row_count", "9"))
'Change_row_count
For u = 1 To RowCount
OldStr = "Lay" + Trim(Str(u))
NewStr = "Lay" + Trim(Str(u))
oldname = ReadIniFile(IniFile_Path, OLDNAMEFLAG, OldStr, "")
newname = ReadIniFile(IniFile_Path, NEWNAMEFLAG, NewStr, "XXX")
MyString = ""
For i = 0 To ThisDrawing.Application.Documents.Count - 1
ThisDrawing.Application.Documents.Item(i).Activate
For j = 0 To ThisDrawing.Layers.Count - 1
Set Layerobj = ThisDrawing.Layers.Item(oldname)
Layerobj.Name = newname
Next
MyString = MyString & Chr(13) & newname & " <- " & oldname & " " ' 最后一个被替代的
Next
Next
MsgBox ("替代完毕:" + Chr(13) + "最后一个为 " + MyString)
End Sub
Public Function ReadIniFile(ByVal strIniFile As String, _
ByVal strSECTION As String, ByVal strKey As String, gstrNull As String) As String
Dim strBuffer As String
Dim intPos As Integer
Const gintMAX_SIZE = 256
strBuffer = Space$(gintMAX_SIZE)
If GetPrivateProfileString(strSECTION, strKey, gstrNull, strBuffer, gintMAX_SIZE, strIniFile) > 0 Then
ReadIniFile = strBuffer
Else
ReadIniFile = gstrNull
End If
End Function
新旧图层名对照设定文件.INI （内容如下）
[OLD_NAME] 旧图层名
Lay1 =定义点
Lay2 =中心线
Lay3 =注释
[NEW_NAME] 新图层名
Lay1 =DefinPoint
Lay2 =CenterLine
Lay3 = Note
[Change_row_count]
Change_row_count = ３ |
发表于 2006-10-16 13:37:14
QQ好友和群
QQ空间
腾讯微博
腾讯朋友
收藏
淘帖
赞一下！
发表于 2006-10-18 09:06:26
发表于 2006-10-25 07:07:09
发表于 2006-10-25 09:28:19
