tüm vba içeriğini silmek

[peleryn]

Herkese Merhabalar;

Aşağıdaki kodlarla .xlt uzantılı şablonumdan hazırladığım yeni dosyayı istediğim klasöre .xls uzantısı ile kaydediyorum.

Forumda arama yaptım daha önce benzer bir iki örneğe rastlamıştım ama şimdi malesef ne yapsam bulamadım.

Üretilen .xls uzantılı dosyamdaki tüm vba içeriğinin kaldırılmış olmasını nasıl sağlayabilirim?

Sub kaydet()
On Error Resume Next
Dim Baslik As String
Baslik = "Kayıt yapacağınız klasörü seçiniz."
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.BrowseForFolder(0, Baslik, 50, &H0)
kaynak = Klasor.items.Item.Path
If Not Klasor Is Nothing Then
If InStr(1, kaynak, "{") > 0 Then GoTo Atla
If Len(kaynak) = 3 Then
kaynak = Mid(kaynak, 1, 2)
End If
On Error Resume Next
yer = kaynak & "\" & Sheets("PERFORMANS KAYIT").ComboBox2.Value & " " & Format([ba3], "mmmm.yy") & " " & Sheets("PERFORMANS KAYIT").ComboBox1.Value & ".xls"
Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FileExists(deg)
If a = True Then
MsgBox "Bu isimde bir dosya var"
Else
ActiveWorkbook.SaveAs Filename:=yer
End If

Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

Set Obj = Nothing
Set Klasor = Nothing
Exit Sub
hata: MsgBox Err.Description, vbExclamation, "Error #" & Err.Number
End Sub

 

[Necdet]

Merhaba,

Aşağıdaki kod işinize yarar mı inceleyiniz. Kodlar alıntıdır.

Sub Makroları_sil()
Dim i As Long, l As Long
Dim objDocument As Object
Set objDocument = ActiveWorkbook
If objDocument Is Nothing Then Exit Sub
i = 0
On Error Resume Next
i = objDocument.VBProject.VBComponents.Count
On Error GoTo 0
If i < 1 Then
Exit Sub
End If
With objDocument.VBProject
For i = .VBComponents.Count To 1 Step -1
On Error Resume Next
.VBComponents.Remove .VBComponents(i)
On Error GoTo 0
Next i
End With
With objDocument.VBProject
For i = .VBComponents.Count To 1 Step -1
l = 1
On Error Resume Next
l = .VBComponents(i).CodeModule.CountOfLines
.VBComponents(i).CodeModule.DeleteLines 1, l
On Error GoTo 0
Next i
End With
End Sub

 

[peleryn]

Hocam malesef kodlar çalışmadı..Örnek kod gelebilir diye dosya yüklemedim gerekirse yarın bir örnek dosya eklerim.

 

[uzmanamele]

merhaba

Necdet beyin kodlarının çalışması için "vba projesine güven" seçeneğinin işaretli olması gerekebilir.

 

[Necdet]

Tekrar merhaba,

Aşağıdaki kodlar http://www.vbaexpress.com/kb/getarticle.php?kb_id=93 adresinden alıntıdır. Denedim, ne var ne yok hepsini siliyor.

Option Explicit 
 
Sub DeleteAllCode() 
     
     'Trust Access To Visual Basics Project must be enabled.
     'From Excel: Tools | Macro | Security | Trusted Sources
     
    Dim x               As Integer 
    Dim Proceed         As VbMsgBoxResult 
    Dim Prompt          As String 
    Dim Title           As String 
     
    Prompt = "Are you certain that you want to delete all the VBA Code from " & _ 
    ActiveWorkbook.Name & "?" 
    Title = "Verify Procedure" 
     
    Proceed = MsgBox(Prompt, vbYesNo + vbQuestion, Title) 
    If Proceed = vbNo Then 
        MsgBox "Procedure Canceled", vbInformation, "Procedure Aborted" 
        Exit Sub 
    End If 
     
    On Error Resume Next 
    With ActiveWorkbook.VBProject 
        For x = .VBComponents.Count To 1 Step -1 
            .VBComponents.Remove .VBComponents(x) 
        Next x 
        For x = .VBComponents.Count To 1 Step -1 
            .VBComponents(x).CodeModule.DeleteLines _ 
            1, .VBComponents(x).CodeModule.CountOfLines 
        Next x 
    End With 
    On Error Goto 0 
     
End Sub

 

[Levent Menteşoğlu]

Aşağıda verdiğim prosedürde Necdet beyin verdiği örneğin kısaltılmış bir halidir.

Sub vbprojectsil()
For Each component In ActiveWorkbook.VBProject.VBComponents
If component.Type <> 100 Then
ActiveWorkbook.VBProject.VBComponents.Remove component
Else
Set modul = component.CodeModule
modul.DeleteLines 1, modul.CountOfLines
End If
Next
End Sub

 

[halit3]

kayıt yaparken bütün kodları ve nesneleri siliyor

Sub kayıtet()
yer = ThisWorkbook.Path & "\" & Cells(4, "C").Value & ".xls"
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FileExists(yer)
If a = True Then
MsgBox "Bu isimde bir dosya var"
Else
DosyaSistemi.CopyFile ThisWorkbook.FullName, yer
Dim Dosya
Dim wb As Workbook
Set wb = Workbooks.Open(yer)
ActiveSheet.DrawingObjects.Delete
For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBComp = ActiveWorkbook.VBProject.VBComponents(ModX.Name)
On Error Resume Next
ActiveWorkbook.VBProject.VBComponents.Remove VBComp
Set VBCodeMod = ThisWorkbook.VBProject.VBComponents(ModX.Name).CodeModule
VBCodeMod.DeleteLines 1, VBCodeMod.CountOfLines
Next
ActiveWorkbook.Save
ActiveWindow.Close
End If
End Sub

 

[halit3]

kodun kısaltılmışı

ActiveSheet.DrawingObjects.Delete
On Error Resume Next
Set VBCodeMod = ActiveWorkbook.VBProject.VBComponents(Sheets(I).Name).CodeModule
VBCodeMod.DeleteLines 1, VBCodeMod.CountOfLines
Next
Set VBCodeMod = ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
VBCodeMod.DeleteLines 1, VBCodeMod.CountOfLines
Sheets(1).Select
For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBComp = ActiveWorkbook.VBProject.VBComponents(ModX.Name)
On Error Resume Next
ActiveWorkbook.VBProject.VBComponents.Remove VBComp
Set VBCodeMod = ThisWorkbook.VBProject.VBComponents(ModX.Name).CodeModule

 

[halit3]

Sayın peleryn soruyu siz sorduğunuz için bir hatırlatma yapayım önceki mesajlarından anlıyorum not32 anti virüs proğramı kullanıyorsunuz yukarıdaki mesajlardaki kodları muhtemelen not32 prağramı virüs diye algılıyacaktır.

 

[Ali]

Aşağıdaki linktede benzer bir soru ve cevap var.

Makro ile sayfaya ait kodları silmek

.

 

[peleryn]

Tüm hocalarım ilginiz için çok teşekkür ederim.Alternatifleri deneyecek fırsat bulur bulmaz sonucu buradan paylaşırım.Hepinize tekrar teşekkür ederim.

 

[peleryn]

Merhabalar;

Levent hocamın 6.mesajda verdiği Necdet hocamın önerdiği kodların kısaltılmış haliyle sorunumu çözdüm.İlgilenen herkese teşekkür ederim.