İşlem Yoksa Belirlenen Süre Sonra Kapatma

gicimi · 8 Ağu 2019

Merhaba;

Arşivde bu şekilde bir çalışmaya rastladım.

Ortak alandaki bir excel dosyasına Modul ekleyerek. kodlardan faydalanabilir miyim. Kodlarda herhangi bir değişiklik yapmalıyım.

VBA:

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

muhsar · 8 Ağu 2019

hocam hangi satırlar düzenlenecek sonuca ulaşırsanız paylaşırmısınız,teşekkür ederim

Feyzullah · 8 Ağu 2019

Buyrun

muhsar · 8 Ağu 2019

hocam ;süre dolduğunda kitabı kapatırken kaydedip kapatması mümkünmü,ben kontrol ettiğimde kapatıyor fakat kayıt etmiyor

muhsar · 8 Ağu 2019

hocam özür yanlış bakmışım,elinize sağlık çok teşekkür ederiz

muhsar · 8 Ağu 2019

Kod:

Private Sub Workbook_Open()
UserNameForm.Show
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Select Case seviye
Case "yetki0"
    MsgBox "Tanımsız yetkilendirme!", vbCritical, "Program kapatılacak!"
    Cancel = True
    'ThisWorkbook.Close False
End Select
End Sub

hocam mevcut çalışma kitabımdaki bu çalışma kitabı bölümündeki yukardaki kodların altına

Kod:

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

bu kodları eklediğimde hata veriyor ve çalışmıyor,,araya yazılması gerekn bir kodmu var acaba

Feyzullah · 9 Ağu 2019

Private Sub Workbook_BeforeClose ve Workbook_Open kodlarını birleştir.

muhsar · 9 Ağu 2019

hocam birleştirmek için çok uğraştım ama en son geldiğim nokta bu hata ile son buldu,rica etsem kontrol edebilirmisiniz.

Kod:

Private Sub Workbook_Open()
UserNameForm.Show
    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_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Select Case seviye
Case "yetki0"
    MsgBox "Tanımsız yetkilendirme!", vbCritical, "Program kapatılacak!"
    Cancel = True
    'ThisWorkbook.Close False

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_BeforeClose(Cancel As Boolean)
    Application.OnTime Temps, Procedure:="ThisWorkbook.TimeSlot", Schedule:=False
    End Sub


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 Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    TimeSlot True
End Sub

Feyzullah · 10 Ağu 2019

Dosyanızı ekleyin bakalım.

muhsar · 10 Ağu 2019

HOCAM KULLANICI ADI:MUHARREM
ŞİFRE:1111

Feyzullah · 12 Ağu 2019

Aşağıdaki kodlarını kullanın. (Mevcut kodlarını silin)

VBA:

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:="BuÇalışmaKitabı.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:="BuÇalışmaKitabı.TimeSlot"
    ActiveWindow.Caption = Split(ActiveWindow.Caption, " [")(0) & " [" & Zaman & "]"
End Sub

Private Sub Workbook_Open()
UserNameForm.Show
    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:="BuÇalışmaKitabı.TimeSlot", Schedule:=False
End Sub


Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Select Case seviye
Case "yetki0"
    MsgBox "Tanımsız yetkilendirme!", vbCritical, "Program kapatılacak!"
    Cancel = True
    'ThisWorkbook.Close False
End Select
End Sub

muhsar · 12 Ağu 2019

hocam hakkınızı helal edin,çok teşekkür ediyorum,çalıştı kodlar

tukayf · 12 Ağu 2019

Sn. Feyzullah dosya için teşekkürler. Peki dosyada işlem yapılmadığında kapanacak süreyi kullanıcıya sormak yerine kodun içerisine 2 dk gibi bir rakam yazabilir miyiz. Bunun için ne gibi değişiklik yapmak gerekir.

Feyzullah · 13 Ağu 2019

WorkBookOpen kısmında Sure değişkenini değiştirmek gerekiyor.
Aşağıdaki Kodu Kullanın.

VBA:

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 = "00:02:00" '' SAAT:DAKİKA:SANİYE   Süresini aynı formatta değiştirin.
    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

muhsar · 13 Ağu 2019

elinize sağlık teşekkür ederiz

tukayf · 13 Ağu 2019

Çok teşekkürler. İyi bayramlar.

mars2 · 14 Ağu 2019

Çok teşekkürler. İyi bayramlar.

mars2 · 19 Ağu 2019

Çok teşekkürle

Feyzullah · 19 Ağu 2019

İyi Çalışmalar.

assenucler · 13 Mar 2025

Teşekkürler.

	Belirlenen Konumdaki Dosyaları Mail Atma cakarem 13 Ocak 2024 Makro Soruları
	Belirlenen Hücrelerde Yapıştırmayı İptal Etme Feyzullah 13 Mar 2025 Makro Soruları
	Sayfada Belirlenen Hücre Aralığını Kaydetme Akif59 14 Mar 2025 Makro Soruları
	Belirlenen Aralığı ListBox Aktarma berkbaba 14 Mar 2025 Makro Soruları
	Dosya Açıldığında Makro ile Belirlenen Hücreye Gitme Epakambalaj 14 Mar 2025 Makro Soruları