Belirlenen Süre Kadar Bekledikten Sonra Kapatma

Allback · 6 Haziran 2017

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ı?

Hakan ERDOST · 6 Haziran 2017

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.

anemis · 6 Haziran 2017

Paylaşım için teşekkürler

BedriA · 6 Haziran 2017

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.

Hocam ne kadar süre işlem yapılmazsa kapanıyor? Bir de; kapatırken kaydediyor mu?

Hakan ERDOST · 6 Haziran 2017

Girişte süreyi siz belirliyorsunuz.Evet kaydediyor.(Kod içeriğinde de mevcut ancak belirtmeden geçmeyeyim.Kodlar Murat OSMA Beye aittir)

BedriA · 6 Haziran 2017

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)

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ü?

simyaci64 · 7 Haziran 2017

çok güzel otomatik kapatma kodu

Allback · 7 Haziran 2017

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ı?

uzeyir.celikel · 3 Temmuz 2018

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...

dgdizayn · 18 Mart 2022

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

aywaz1986 · 30 Aralık 2022

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

Merhaba bu işlemi USERFORM için nasıl yapabiliriz USERFORM açık olacak USERFORM ve kitabı kaydet kapat olsun istiyoruz

Belirlenen Süre Kadar Bekledikten Sonra Kapatma

Allback

Hakan ERDOST

Destek Ekibi

anemis

BedriA

Hakan ERDOST

Destek Ekibi

BedriA

simyaci64

Allback

uzeyir.celikel

dgdizayn

aywaz1986