软件简介：刚刚完工，在我的小容量Mir.DB上测试通过。
没有安装ActivePerl的请下载.exe版本：
http://renshouren.com/download/myfile/DelStditems2.exe
物品清理套装（批量清除指定物品工具、批量清除复制物品工具、清空所有物品保留等级等属性工具）下载：
http://renshouren.com/download/myfile/DelStditems.rar


#!/usr/bin/perl
my $copy = qq~
#################################
#
# 传奇复制物品自动批量删除工具
# 较耗费系统资源，请先做好备份并停止游戏服务器运行
#
# 本工具需要系统安装perl解析器,将此源码保存为.pl文件，直接运行
#
#################################

~;
print $copy;

print "请回车确认操作开始：";
;
print "\n正在读入数据库，这可能需要几秒种，请稍等..\n";
my $MIRDB = 'D:/MirServer/mud2/DBSrv200/FDB/Mir.DB';

open (MIR,$MIRDB);
binmode(MIR);
my @mir = ;
my $mir = join("",@mir);
undef(@mir);
my (%stditem,%stditem2);
my $insert = "\x00" x 24;
substr($mir,0,124) = '';
my $i = int(length($mir) / 3164);
my $i0 = $i;
print "成功读取$i个角色数据，准备操作...\n";
my $i2 = 0;
while ($i){$i --;
print "搜索并检查第$i2个角色的物品...","\n";
my $this = substr($mir,0,3164);
substr($mir,0,3164) = '';
my $i3 = 49;
my $this1 = substr($this,484,1176);
my $this2 = substr($this,1964,960);
while($i3){
$i3 --;
substr($this1,0,24) = '';
my $a = substr($this1,0,4);
next if $a eq "\x00\x00\x00\x00";
$stditem2{&GetAscByBin($a)} = 1 if exists($stditem{$a});
$stditem{$a} = 1;
}
$i3 = 40;
while($i3){
$i3 --;
substr($this2,0,24) = '';
my $a = substr($this2,0,4);
next if $a eq "\x00\x00\x00\x00";
$stditem2{&GetAscByBin($a)} = 1 if exists($stditem{$a});
$stditem{$a} = 1;
}
$i2 ++;
}

close MIR;

&deleteitem(%stditem2);
#***************************
sub deleteitem
{
my %stditem2 = @_;print "\n";
$stditem2{0} = undef;
open (MIR,"+<$MIRDB");
binmode(MIR);
my @mir = ;
my $mir = join("",@mir);
undef(@mir);
my $insert = "\x00" x 24;
substr($mir,0,124) = '';
my $i = int(length($mir) / 3164);
print "已经得到复制品列表，接下来将准备删除复制物品，请等待...\n";
my ($i2,$i4) = (0,0);
while ($i){$i --;
print "搜索并处理第$i2个角色的物品...","\n";
my $this = substr($mir,0,3164);
substr($mir,0,3164) = '';
seek(MIR,3164 * $i2 + 124,0);
seek(MIR,484 + 24,1);
my $i3 = 49;
my $this1 = substr($this,484,1176);
my $this2 = substr($this,1964,960);
while($i3){
$i3 --;my $seek;
substr($this1,0,24) = '';
my $a = substr($this1,0,4);
if ($stditem2{&GetAscByBin($a)}){$seek = 1;print MIR $insert;$i4 ++;}
seek(MIR,24,1) unless $seek;
}
$i3 = 40;
seek(MIR,304,1);

while($i3){
$i3 --;my $seek;
substr($this2,0,24) = '';
my $a = substr($this2,0,4);
if ($stditem2{&GetAscByBin($a)}){$seek = 1;print MIR $insert;$i4 ++;}
seek(MIR,24,1) unless $seek;
}
$i2 ++;
}

close MIR;

print "总共删除 $i4 件复制物品，按回车退出程序。";
;


}


#***********
sub GetAscByBin
{
my $res = shift;
my $res2 = 0;
my $len = length($res);
while($len){
$len --;
$res2 += ord(substr($res,$len,1)) * (2 ** (8 * $len));
}
return $res2;
}
#********
sub GetStrByNum
{
my ($num,$len) = @_;

my $i = 1;
my $res;
while ($i){
my $a = 2 ** ($i * 8);
last if $a > $num;
$i ++;
}
$len = $i unless $len;
&error("不能转换数字，因为长度超过限定。") if $i > $len;
my $i2 = $len - $i;
while ($i){
my $a = 2 ** (($i - 1) * 8);
my $this = int ($num / $a);
$res = chr($this) . $res;
$num = $num % $a;
$i --;
}
$res .= "\x00" x $i2;
return $res;
}
########## END SCRIPT #############