makroları silme!!!

[shenko]

Bir klasor içinde bulunan makrolu tüm dosyalarımın makrolarını iptal eden bir düğme yapmak istiyorum. Yalnız iptal işlemini yapmadan önce bir anahtar soru sormasını ve bu soruya yanlış cevap verilirse klasor içindeki butun makrolu dosyaların makrolarını silmesini istiyorum.Böle birşey mümkünmü?

Eğer mümkünse bunu zaman aşımlı olarak ayarlamak mümkünmü? Mesela haftada bir kez kendi kendine aktif olması???

 

[Haluk]

Dosyalarda ve/veya VBA kısmında şifre yoksa, yapılır ...

 

[shenko]

Peki yardımcı olabilirmisiniz sayın haluk?

 

[Haluk]

Sayın shenko;

Vaktim müsait olduğu bir zaman ilgilenebilirim ama şu sıralar biraz yoğunum ...

 

[shenko]

Ozaman müsait bir zamanda cevaplarınızı beklicez sayın haluk.

Başka fikri olan veya yardımcı olmak isteyen üstadlarımızında cevaplarını bekliyorum. Saygılar...

 

[Haluk]

Merhaba;

Bu iş için aşağıdaki kodların hepsini (Test isimli prosedürü ve CreateFileList isimli fonksiyonu) bir module kopyaladıktan sonra Test isimli prosedürü çalıştırın.

Bu kod, kodlarda geçen C:\TestFolder klasörü ve bunun içindeki tüm alt klasörlerdeki dosyalardaki kod modüllerinin içini temizledikten sonra, modülleri siler.

Sub Test()
    '
    ' 06/12/2006
    '  Raider ®
    '
    Dim MyPath As String, MyExt As String
    Dim IncludeSubFolder As Boolean
    Dim i As Long
    Dim MyMod As Object, TheMod As Object
    Dim StartLine As Long, NumLines As Long
    MyPath = "C:\TestFolder"
    MyExt = "*.xls"
    IncludeSubFolder = True
    FileNamesList = CreateFileList(MyPath, MyExt, IncludeSubFolder)
    Application.ScreenUpdating = False
    For i = 1 To UBound(FileNamesList)
        Set MyWB = Workbooks.Open(FileNamesList(i))
        For Each MyMod In Workbooks((MyWB.Name)).VBProject.VBComponents
            Set TheMod = Workbooks(MyWB.Name).VBProject.VBComponents(MyMod.Name).CodeModule
            StartLine = TheMod.CountOfDeclarationLines + 1
            NumLines = TheMod.CountOfLines
            TheMod.DeleteLines StartLine, NumLines
            If Not MyMod.Type = 100 Then Workbooks((MyWB.Name)).VBProject.VBComponents.Remove MyMod
        Next
        MyWB.Close SaveChanges:=True
    Next
    Application.ScreenUpdating = False
    Set TheMod = Nothing
    Set MyWB = Nothing
End Sub
'
Function CreateFileList(ThePath As String, FileFilter As String, IncludeSubFolder As Boolean) As Variant
    Dim FileList() As String, FileCount As Long
    CreateFileList = ""
    Erase FileList
    With Application.FileSearch
        .NewSearch
        .LookIn = ThePath
        .Filename = FileFilter
        .LastModified = msoLastModifiedAnyTime
        .SearchSubFolders = IncludeSubFolder
        If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) = 0 Then Exit Function
        ReDim FileList(.FoundFiles.Count)
            For FileCount = 1 To .FoundFiles.Count
                FileList(FileCount) = .FoundFiles(FileCount)
            Next
    End With
    CreateFileList = FileList
    Erase FileList
End Function

 

[Haluk]

Not:

Eğer Office2000'in üzerinde bir versiyon kullanıyorsanız, Excel'in güvenlik ayarlarında (Tools >> Macro >> Security - Araçlar >> Makro >> Güvenlik) "VB projelerine erişime izin ver.." gibilerinden bir seçenek olması lazım, bunu onaylamanız gerekebilir.

 

[shenko]

Peki otomatik olarak her pazartesi saat 10 da çalışacak bir uyarı kutucuğu yapsak ve kutucukta şifre sorulsa, eğer şifre yanlış yazılırsa sizin yapmış olduğunuz makroyu çalıştırsa doğru yazılırsa makroyu çalıştırmasa.

Böyle bişi yapmak mumku???

 

[Haluk]

Mümkün ...

Ama, kullanıcının makroları etkinleştirerek dosyayı açacağını nasıl garanti edeceksiniz ?

 

[shenko]

Makroları etkinleştirdiğini var sayarsak!

 

[Haluk]

Dosyanın açıldığı gün Pazartesi ve saat 10:00' dan daha ileri ise, aşağıdaki revize kod çalışır.

Dosyanın her Pazartesi günü otomatik açılması için Windows'un Scheduled Tasks (Tanımlanmış/Zamanlanmış Görevler) özelliğini kullanırsınız ...

Sub Auto_Open()
    Call Test
End Sub
'
Sub Test()
    '
    ' 06/12/2006
    '  Raider ®
    '
    Dim MyPath As String, MyExt As String
    Dim IncludeSubFolder As Boolean
    Dim i As Long
    Dim MyMod As Object, TheMod As Object
    Dim StartLine As Long, NumLines As Long
    If Weekday(Date) = vbMonday And Time >= TimeValue("10:00:00") Then
    MyPath = "C:\TestFolder"
    MyExt = "*.xls"
    IncludeSubFolder = True
    FileNamesList = CreateFileList(MyPath, MyExt, IncludeSubFolder)
    Application.ScreenUpdating = False
    For i = 1 To UBound(FileNamesList)
        Set MyWB = Workbooks.Open(FileNamesList(i))
        For Each MyMod In Workbooks((MyWB.Name)).VBProject.VBComponents
            Set TheMod = Workbooks(MyWB.Name).VBProject.VBComponents(MyMod.Name).CodeModule
            StartLine = TheMod.CountOfDeclarationLines + 1
            NumLines = TheMod.CountOfLines
            TheMod.DeleteLines StartLine, NumLines
            If Not MyMod.Type = 100 Then Workbooks((MyWB.Name)).VBProject.VBComponents.Remove MyMod
        Next
        MyWB.Close SaveChanges:=True
    Next
    Application.ScreenUpdating = False
    End If
    Set TheMod = Nothing
    Set MyWB = Nothing
End Sub
'
Function CreateFileList(ThePath As String, FileFilter As String, IncludeSubFolder As Boolean) As Variant
    Dim FileList() As String, FileCount As Long
    CreateFileList = ""
    Erase FileList
    With Application.FileSearch
        .NewSearch
        .LookIn = ThePath
        .Filename = FileFilter
        .LastModified = msoLastModifiedAnyTime
        .SearchSubFolders = IncludeSubFolder
        If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) = 0 Then Exit Function
        ReDim FileList(.FoundFiles.Count)
            For FileCount = 1 To .FoundFiles.Count
                FileList(FileCount) = .FoundFiles(FileCount)
            Next
    End With
    CreateFileList = FileList
    Erase FileList
End Function