• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Belirlenen Süre Kadar Bekledikten Sonra Kapatma

A

Allback

Katılım
21 Eylül 2011
Mesajlar
115
Excel Vers. ve Dili
Office 365 - İngilizce
Merhaba,

Ağda ortak kullanılan bir dosyamız var. Açık olan bu dosyada, belirlenen süre kadar işlem yapılmazsa otomatik kapanmasını istiyorum.

Otomatik kapanmayı buldum ama dosya açıldığı andan itibaren saymaya başladığı için süre dolduğunda işlem yaparken bile kapanabiliyor.

Yardımcı olabilecek kimse var mı?
 
Son düzenleme:
Kod: 
'*******************************************
'**                ¯/ /¯/ / ¯/              **
'** MuratOSMA ©  /¯  / / / ¯/  ExcelVBA.Net  **
'**              ¯   ¯    ¯                **
'*******************************************
    
Option Explicit
Private Const Gecikme As Date = 5 / 86400
Private Const Onerilen_Zaman As Date = 10 * 60 / 86400
Private Süre As Variant
Private Temps As Date
Private Zaman As Date

Private Sub TimeSlot(Optional Reset As Boolean)
    On Error Resume Next
    Application.OnTime Temps, Procedure:="ThisWorkbook.TimeSlot", Schedule:=False
    If IsMissing(Reset) Or (Reset = False) Then
        If (Zaman <= Gecikme) Then
            ThisWorkbook.Close True
        End If
        Zaman = Zaman - Gecikme
    Else
        Zaman = Süre
    End If
    Temps = Now + Gecikme
    Application.OnTime Temps, Procedure:="ThisWorkbook.TimeSlot"
    ActiveWindow.Caption = Split(ActiveWindow.Caption, " [")(0) & " [" & Zaman & "]"
End Sub

Private Sub Workbook_Open()
    Do
        Süre = Application.InputBox("Varsayılan zaman önerilmektedir " & Onerilen_Zaman & ". " & _
        "Girdi formatı '00:00:00'" & vbCrLf & vbCrLf & _
        "Kalan süre yukarıda gösterilecektir. " & vbCrLf, _
        "Saati ayarlayın", Type:=2)
    Loop Until (Süre = False) Or IsDate(Süre)
    Süre = IIf(IsDate(Süre), Süre, Onerilen_Zaman)
    TimeSlot True
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    TimeSlot True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.OnTime Temps, Procedure:="ThisWorkbook.TimeSlot", Schedule:=False
End Sub
This Workbook kısmına yapıştırın.
 
Paylaşım için teşekkürler
 
hexadesimal' Alıntı:
Kod: 
'*******************************************
'**                ¯/ /¯/ / ¯/              **
'** MuratOSMA ©  /¯  / / / ¯/  ExcelVBA.Net  **
'**              ¯   ¯    ¯                **
'*******************************************
    
Option Explicit
Private Const Gecikme As Date = 5 / 86400
Private Const Onerilen_Zaman As Date = 10 * 60 / 86400
Private Süre As Variant
Private Temps As Date
Private Zaman As Date

Private Sub TimeSlot(Optional Reset As Boolean)
    On Error Resume Next
    Application.OnTime Temps, Procedure:="ThisWorkbook.TimeSlot", Schedule:=False
    If IsMissing(Reset) Or (Reset = False) Then
        If (Zaman <= Gecikme) Then
            ThisWorkbook.Close True
        End If
        Zaman = Zaman - Gecikme
    Else
        Zaman = Süre
    End If
    Temps = Now + Gecikme
    Application.OnTime Temps, Procedure:="ThisWorkbook.TimeSlot"
    ActiveWindow.Caption = Split(ActiveWindow.Caption, " [")(0) & " [" & Zaman & "]"
End Sub

Private Sub Workbook_Open()
    Do
        Süre = Application.InputBox("Varsayılan zaman önerilmektedir " & Onerilen_Zaman & ". " & _
        "Girdi formatı '00:00:00'" & vbCrLf & vbCrLf & _
        "Kalan süre yukarıda gösterilecektir. " & vbCrLf, _
        "Saati ayarlayın", Type:=2)
    Loop Until (Süre = False) Or IsDate(Süre)
    Süre = IIf(IsDate(Süre), Süre, Onerilen_Zaman)
    TimeSlot True
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    TimeSlot True
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.OnTime Temps, Procedure:="ThisWorkbook.TimeSlot", Schedule:=False
End Sub
This Workbook kısmına yapıştırın.
Genişletmek için tıkla ...

Hocam ne kadar süre işlem yapılmazsa kapanıyor? Bir de; kapatırken kaydediyor mu?
 
Girişte süreyi siz belirliyorsunuz.Evet kaydediyor.(Kod içeriğinde de mevcut ancak belirtmeden geçmeyeyim.Kodlar Murat OSMA Beye aittir)
 
hexadesimal' Alıntı:
Girişte süreyi siz belirliyorsunuz.Evet kaydediyor.(Kod içeriğinde de mevcut ancak belirtmeden geçmeyeyim.Kodlar Murat OSMA Beye aittir)
Genişletmek için tıkla ...

Size de, Osman Bey'e de çok teşekkürler. Elinize sağlık.

Peki hocam,

Programın kullanıcı kodu ve şifreyle girilen bir programa örneğin 1 yıllık bir süre tanımlayıp 1 yılın sonunda kullanıma kapatarak "Kullanım süreniz doldu!" uyarısı verdirmek mümkün mü?
 
Merhaba,

Paylaşımınız için teşekkürler fakat ben bu makroyu çalıştıramadım. Dosya açılışında süreyi soruyor ve yazılan süreyi yukarı yazıyor ama 10 saniye sonra "TimeSlot" makrosu çalıştırılamıyor. Makro bu çalışma kitabında olmayabilir veya tüm makrolar devre dışı bırakılmış olabilir" hatası veriyor

Dosyayı kapatmak istediğimde de "1004" hata kodunu verip aşağıdaki satırı hatalı gösteriyor.

Kod: 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Application.OnTime Temps, Procedure:="ThisWorkbook.TimeSlot", Schedule:=False
End Sub

Çalışan excel örneği paylaşabilecek var mı?
 
Başlığı açılan bu konuda ben bir çözüme ulaşamadım.
Dosya içinde zaten farklı macrolar var açılış ekranında süre falan sormadan arka planda dosyada belirli bir süre işlem yapmayınca kapatacak bir makro elinde olan varsa vede yardımcı olursa çok sevinirim...
 
Modül oluşturup aşağıdaki kodları ekleyin.
Kod: 
Dim CloseTime As Date
Sub TimeSetting()
    CloseTime = Now + TimeValue("00:00:30")
    On Error Resume Next
    Application.OnTime EarliestTime:=CloseTime, _
      Procedure:="SavedAndClose", Schedule:=True
End Sub
Sub TimeStop()
    On Error Resume Next
    Application.OnTime EarliestTime:=CloseTime, _
      Procedure:="SavedAndClose", Schedule:=False
 End Sub
Sub SavedAndClose()
    ActiveWorkbook.Close Savechanges:=True
End Sub


Aşağıdaki kodları ise Bu çalışma kitabı yada ThisWorkbook kısmına ekleyin
Kod: 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call TimeStop
End Sub

Private Sub Workbook_Open()
    Call TimeSetting
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
   Call TimeStop
   Call TimeSetting
End Sub
 
dgdizayn' Alıntı:
Modül oluşturup aşağıdaki kodları ekleyin.
Kod: 
Dim CloseTime As Date
Sub TimeSetting()
    CloseTime = Now + TimeValue("00:00:30")
    On Error Resume Next
    Application.OnTime EarliestTime:=CloseTime, _
      Procedure:="SavedAndClose", Schedule:=True
End Sub
Sub TimeStop()
    On Error Resume Next
    Application.OnTime EarliestTime:=CloseTime, _
      Procedure:="SavedAndClose", Schedule:=False
End Sub
Sub SavedAndClose()
    ActiveWorkbook.Close Savechanges:=True
End Sub


Aşağıdaki kodları ise Bu çalışma kitabı yada ThisWorkbook kısmına ekleyin
Kod: 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call TimeStop
End Sub

Private Sub Workbook_Open()
    Call TimeSetting
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
   Call TimeStop
   Call TimeSetting
End Sub
Genişletmek için tıkla ...
Merhaba bu işlemi USERFORM için nasıl yapabiliriz USERFORM açık olacak USERFORM ve kitabı kaydet kapat olsun istiyoruz
 
dgdizayn' Alıntı:
Modül oluşturup aşağıdaki kodları ekleyin.
Kod: 
Dim CloseTime As Date
Sub TimeSetting()
    CloseTime = Now + TimeValue("00:00:30")
    On Error Resume Next
    Application.OnTime EarliestTime:=CloseTime, _
      Procedure:="SavedAndClose", Schedule:=True
End Sub
Sub TimeStop()
    On Error Resume Next
    Application.OnTime EarliestTime:=CloseTime, _
      Procedure:="SavedAndClose", Schedule:=False
End Sub
Sub SavedAndClose()
    ActiveWorkbook.Close Savechanges:=True
End Sub


Aşağıdaki kodları ise Bu çalışma kitabı yada ThisWorkbook kısmına ekleyin
Kod: 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call TimeStop
End Sub

Private Sub Workbook_Open()
    Call TimeSetting
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
   Call TimeStop
   Call TimeSetting
End Sub
Genişletmek için tıkla ...
Merhaba hocam. acaba açık olan excel kitabını belirlediğimiz saat dakikada kendisini otomatik olarak kapatmasını sağlayacak kodlar hakkında yardımcı olabilir misiniz?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst