图层名对应批量修改

wensanren

'Auto2004 使用C:\新旧图层名对照设定文件.INI　文件中设定的对应关系对当前图形文件图层更名
* \/ B7 @( y: a'可对含有中文的DWG档图层名修改以便ug读入
'INI文件中　[NEW_NAME]项目下为需修改的新图层名；　[OLD_NAME]项目下为需修改的旧图层名
4 m  n3 Z, s1 ^9 K2 ~: ?! J$ g! C6 u'Change_row_count　＝　9 代表需修改的新旧图层行数
" J9 R' P( z0 V+ w9 M' H+ N'使用的宏文件源代码如下：　作者　逍昇wensanren
Option Explicit
Private Declare Function GetPrivateProfileString Lib "kernel32" _
" k3 j% b/ u2 u1 X1 y8 B
0 q% X( Y0 N. WAlias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, _

: S& W6 V: }- k, g. s7 Q  UByVal lpKeyName As Any, ByVal lpDefault As String, _

) I$ ]# r$ B2 O' DByVal lpReturnedString As String, ByVal nSize As Long, _

9 F* ^/ Q1 V2 K5 q; fByVal lpFileName As String) As Long
Private Declare Function GetVolumeInformation Lib "kernel32.dll" Alias _

"GetVolumeInformationA" (ByVal lpRootPathName As String, _
9 z. n% U. [9 f9 Q/ L8 U& U- I! L6 f
- i# U! |9 ]4 Q0 P# T) JByVal lpVolumeNameBuffer As String, ByVal nVolumeNameSize As Integer, _
. p: ~/ l# l3 l4 A% y
lpVolumeSerialNumber As Long, lpMaximumComponentLength As Long, _
* r: G9 x( a. V  Q
lpFileSystemFlags As Long, ByVal lpFileSystemNameBuffer As String, _
' C0 |# h, B3 N7 w9 g
ByVal nFileSystemNameSize As Long) As Long
6 t+ L& a+ Q# T) P- u" [8 kSub replayer()
* e- j& Y& ~5 AOn Error Resume Next
) ~- W! E3 Z5 TConst IniFile_Path = "C:\新旧图层名对照设定文件.INI"
Const ForReading = 1, ForWriting = 2, ForAppending = 3, TristateFalse = 0
/ A+ c0 K  S; D5 E" D6 [. v'TristateFalse
0 以 ASCII 格式打开文件
Dim fs, f As Object
, A: d4 F4 t1 a2 cDim i, u, j, RowCount As Integer
, S) h; R4 W8 q( eDim ent As AcadEntity
Dim Layerobj As AcadLayer
Dim oldname, newname, OLDNAMEFLAG, NEWNAMEFLAG, OldStr, NewStr, TMPSTR As String
* E# w6 B0 ~  E- k1 ]
Dim Msg, Style, Title, Response, MyString
Msg = "[新图层名]　替代　[旧图层名] ?"
' 定义信息。
3 ~/ S% d+ ]; H'Msg = "汉字 -> 字母(ASCII) ?"
Style = vbYesNo + vbCritical + vbDefaultButton2
' 定义按钮。
9 b7 {" ?/ }* I( l8 c0 UTitle = "MsgBox Demonstration"
' 定义标题。
6 p/ s! [( S/ u1 _5 Q! c8 \: c4 J
, O: Y; D9 J/ z/ R( x2 tResponse = MsgBox(Msg, Style, Title)
5 {/ {) t4 l5 X5 T( F% ], gIf Response = vbYes Then
4 N' }8 o8 p$ {- x' 用户按下“是”。[新图层名]替代[旧图层名]
: Y7 U* r0 k9 b& n3 E( C; n
  R; g  d' U2 A) R) r/ V, FOLDNAMEFLAG = "OLD_NAME"
1 S. Z$ D$ O4 I) I
; r8 e1 ^( z7 A1 q" _NEWNAMEFLAG = "NEW_NAME"
3 d4 @, ~, b3 s# G$ x% _5 H- v, k; w  v   
6 m9 M0 }1 l# G( ?: l( NElse
' 用户按下“否”。[旧图层名]替代[新图层名]
% e' {+ x2 g0 C) f) d7 u# X# e
OLDNAMEFLAG = "NEW_NAME"

NEWNAMEFLAG = "OLD_NAME"
/ V2 s. S: ?  z' t5 i: GEnd If
% A' V0 \7 ?' _  k/ n% _  TRowCount = CLng(ReadIniFile(IniFile_Path, "Change_row_count", "Change_row_count", "9"))
8 _) U+ c$ K1 e5 Q  ^$ R'Change_row_count
For u = 1 To RowCount
OldStr = "Lay" + Trim(Str(u))
NewStr = "Lay" + Trim(Str(u))
4 u2 [; X- Z0 h, W7 A  T6 doldname = ReadIniFile(IniFile_Path, OLDNAMEFLAG, OldStr, "")
6 N2 T. r& M. S6 u3 Knewname = ReadIniFile(IniFile_Path, NEWNAMEFLAG, NewStr, "XXX")
* `0 i2 E* g+ U5 J7 `$ h# m- hMyString = ""
For i = 0 To ThisDrawing.Application.Documents.Count - 1
4 i, d" W* J2 K) ~# ^. fThisDrawing.Application.Documents.Item(i).Activate
) }. e2 e$ R. w5 H' qFor j = 0 To ThisDrawing.Layers.Count - 1
: A. s; j6 h/ E' f  O& `Set Layerobj = ThisDrawing.Layers.Item(oldname)
Layerobj.Name = newname
4 ]- L5 g( G3 g( YNext
7 P8 S9 f! K- b( AMyString = MyString & Chr(13) & newname & " <- " & oldname & " " ' 最后一个被替代的
Next
: B, P- a  j  ~; u
Next
MsgBox ("替代完毕:" + Chr(13) + "最后一个为　" + MyString)

1 O6 q/ g: ^2 YEnd Sub
4 F" M6 ]- A8 Z5 |2 R! [
, D6 _$ m" g4 x0 `5 m9 r, aPublic 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
0 }( A* V* O/ t3 nConst gintMAX_SIZE = 256
) k: W5 a  k2 e- d% k. J! ~strBuffer = Space$(gintMAX_SIZE)
If GetPrivateProfileString(strSECTION, strKey, gstrNull, strBuffer, gintMAX_SIZE, strIniFile) > 0 Then
ReadIniFile = strBuffer
Else
# z0 q8 Y8 u" {) ^7 A( _
- X1 W7 m3 b( X8 v6 x6 JReadIniFile = gstrNull
2 V0 n8 M3 o7 K, z' WEnd If
; t9 {" J0 W  y- b* d" [1 PEnd Function
$ e+ ?1 ?' C1 k
7 @! S, @7 u+ y9 R7 c新旧图层名对照设定文件.INI （内容如下）
; {: G6 i  Y  z( e9 p, v[OLD_NAME] 旧图层名
$ j0 ~* T" F9 m% G) TLay1 =定义点
( u" I  U1 t1 Q+ |7 Y/ G: `6 lLay2 =中心线
Lay3 =注释

[NEW_NAME] 新图层名
Lay1 =DefinPoint
Lay2 =CenterLine
$ o8 }0 F5 K  \Lay3 = Note
' e( a: _- E* A1 J9 b9 p+ c
5 Q7 R2 P, v; r: A: v[Change_row_count]
7 u8 \5 Y- B2 I# UChange_row_count = ３