Sub scdm() '刪除代碼及窗體
Application.DisplayAlerts = False
Application.VBE.CommandBars(1).Controls("工具(T)").Controls("VBAProject 屬性(E)...").Execute
Application.SendKeys "123456"
Application.SendKeys "{ENTER}"
Application.SendKeys "{ESC}"
Dim t, i
t = DateAdd("s", 2, Now)
Do Until Now > t
DoEvents
Loop
For i = 1 To ThisWorkbook.VBProject.VBComponents.Count
ThisWorkbook.VBProject.VBComponents(i).CodeMole.DeleteLines 1, _
ThisWorkbook.VBProject.VBComponents(i).CodeMole.CountOfLines
Next
Dim Vbc As Object
For Each Vbc In Application.ThisWorkbook.VBProject.VBComponents
Select Case Vbc.Type
Case 1, 2, 3
With Application.VBE.ActiveVBProject.VBComponents
.Remove .Item(Vbc.Name)
End With
End Select
Next
End Sub
把按密碼的動作加進去就成了，上面第4句就是密碼123456，你改成你的密碼
2. excel表自殺用VBA如何編寫
可以考慮sky的建議，但意義不大，別人一定要打開你的文件，將將宏安全性設置為高，這樣文件也不會自殺的
3. excel文檔用VBA加密了，打開時提示「注意：檢查文件路徑錯誤，文件將自動刪除」，請問如何解密此文件
這是因為作者對文檔進行了加密，這種加密估計是在workopen事件中寫入的代碼，要破解vba密碼一般用Advanced VBA Password Recovery ，但是作者再打開文件時進行了文件路徑的檢查所以，你要先在打開文件的時候禁用「宏」，然後配合Advanced VBA Password Recovery軟體估計可以搞定。
4. 在EXCEL中，需要一個在某一個日期就自殺的工作溥VBA代碼
Private Sub Workbook_Open()
Dim counter As Long, term As Long, chk
chk = GetSetting("hhh", "budget", "使用次數", "")
If chk = "" Then
term = 50 '限制使用50次
MsgBox "本工作簿只能使用" & term & "次" & vbCrLf & "超過次數將自動銷毀!", vbExclamation
SaveSetting "hhh", "budget", "使用次數", term
Else
counter = Val(chk) - 1
MsgBox "你還能使用" & counter & "次,請及時注冊!", vbExclamation
SaveSetting "hhh", "budget", "使用次數", counter
If counter <= 0 Then
DeleteSetting "hhh", "budget", "使用次數"
killme
End If
End If
End Sub
Public Sub killme()
Application.DisplayAlerts = False
ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill ActiveWorkbook.FullName
ThisWorkbook.Close False
End Sub
源代碼供參考。時間函數 now()，指定日期 #2011-12-31# ，希望你自己能改好程序。
後面的這個應該無法實現，因為輸入密碼時還未執行到宏代碼啊。
5. excel2013關於VBA密碼破解的教程
在 Excel 中可能有些重要數據需要修改，但遺憾的是忘記了密碼。這個時候就需要進行對文件密碼的破解。下面是我帶來的關於excel2013關於VBA密碼破解的教程，歡迎閱讀!
excel2013關於VBA密碼破解的教程教程1：將你要破解的Excel文件關閉，切記一定要關閉呀!然後新建一個Excel文件
教程2：打開新建的這個Excel，按下alt+F11，打開vb界面，新建一個模塊，如圖所示
教程3：將代碼復制到這個模塊中，代碼如下：
Private Sub VBAPassword() '你要解保護的Excel文件路徑
Filename = Application.GetOpenFilename("Excel文件(*.xls & *.xla & *.xlt),*.xls;*.xla;*.xlt", , "VBA破解")
If Dir(Filename) = "" Then
MsgBox "沒找到相關文件,清重新設置。"
Exit Sub
Else
FileCopy Filename, Filename & ".bak" '備份文件。
End If
Dim GetData As String * 5
Open Filename For Binary As #1
Dim CMGs As Long
Dim DPBo As Long
For i = 1 To LOF(1)
Get #1, i, GetData
If GetData = "CMG=""" Then CMGs = i
If GetData = "[Host" Then DPBo = i - 2: Exit For
Next
If CMGs = 0 Then
MsgBox "請先對VBA編碼設置一個保護密碼...", 32, "提示"
Exit Sub
End If
Dim St As String * 2
Dim s20 As String * 1
'取得一個0D0A十六進制字串
Get #1, CMGs - 2, St
'取得一個20十六制字串
Get #1, DPBo + 16, s20
'替換加密部份機碼
For i = CMGs To DPBo Step 2
Put #1, i, St
Next
'加入不 配對 符號
If (DPBo - CMGs) Mod 2 <> 0 Then
Put #1, DPBo + 1, s20
End If
MsgBox "文件解密成功......", 32, "提示"
Close #1
End Sub
教程3：然後點擊運行按鈕，如圖所示，綠色的小三角就是
教程4：你會看到，打開了一個文件夾，找到我們要破解的這個文件，然後點擊打開
教程5：稍等幾分鍾你就會看到破解成功的提示了
6. 如何破解EXCEL VBA密碼
關於破解EXCEL VBA工程密碼的方法,以下代碼非常有效,首先建一新EXCEL文件,在工作表標簽處右點>>查看代碼>>復制以下代碼>>按F8執行在彈出窗中選你要你破解工程密碼的EXCEL文件 >>再按F5執行即可.
PrivateSubVBAPassword()
'你要解保護的Excel文件路徑
Filename=Application.GetOpenFilename("Excel文件（*.xls&*.xla&*.xlt）,*.xls;*.xla;*.xlt",,"VBA破解")
IfDir(Filename)=""Then
MsgBox"沒找到相關文件,清重新設置。"
ExitSub
Else
FileCopyFilename,Filename&".bak"'備份文件。
EndIf
DimGetDataAsString*5
OpenFilenameForBinaryAs#1
DimCMGsAsLong
DimDPBoAsLong
Fori=1ToLOF(1)
Get#1,i,GetData
IfGetData="CMG="""ThenCMGs=i
IfGetData="[Host"ThenDPBo=i-2:ExitFor
Next
IfCMGs=0Then
MsgBox"請先對VBA編碼設置一個保護密碼...",32,"提示"
ExitSub
EndIf
IfProtect=FalseThen
DimStAsString*2
Dims20AsString*1
'取得一個0D0A十六進制字串
Get#1,CMGs-2,St
'取得一個20十六制字串
Get#1,DPBo+16,s20
'替換加密部份機碼
Fori=CMGsToDPBoStep2
Put#1,i,St
Next
'加入不配對符號
If(DPBo-CMGs)Mod2<>0Then
Put#1,DPBo+1,s20
EndIf
MsgBox"文件解密成功......",32,"提示"
EndIf
Close#1
EndSu
如果上面代碼不能運行或出錯,請用以下代碼重試.
PrivateSubVBAPassword()
'你要解保護的Excel文件路徑
Filename=Application.GetOpenFilename("Excel文件（*.xls&*.xla&*.xlt）,*.xls;*.xla;*.xlt",,"VBA破解")
IfDir(Filename)=""Then
MsgBox"沒找到相關文件,清重新設置。"
ExitSub
Else
FileCopyFilename,Filename&".bak"'備份文件。
EndIf
DimGetDataAsString*5
OpenFilenameForBinaryAs#1
DimCMGsAsLong
DimDPBoAsLong
Fori=1ToLOF(1)
Get#1,i,GetData
IfGetData="CMG="""ThenCMGs=i
IfGetData="[Host"ThenDPBo=i-2:ExitFor
Next
IfCMGs=0Then
MsgBox"請先對VBA編碼設置一個保護密碼...",32,"提示"
ExitSub
EndIf
DimStAsString*2
Dims20AsString*1
'取得一個0D0A十六進制字串
Get#1,CMGs-2,St
'取得一個20十六制字串
Get#1,DPBo+16,s20
'替換加密部份機碼
Fori=CMGsToDPBoStep2
Put#1,i,St
Next
'加入不配對符號
If(DPBo-CMGs)Mod2<>0Then
Put#1,DPBo+1,s20
EndIf
MsgBox"文件解密成功......",32,"提示"
Close#1
EndSub
7. VBA文件自殺問題
你的代碼沒有問題，在我的電腦上能成功自殺，建議你取消過程裡面的第一行：
On Error Resume Next
看看執行過程中是否報錯，報錯的時候拷屏記錄錯誤原因，然後選擇「調試」按鈕，看看停留在哪一行，結合錯誤說明和程序代碼思考，如果有困難請粘貼兩者。