• DİKKAT

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

Kayıt başarılı olduğunda c:\kayit.xls ye bilgi kaydı

  • Konbuyu başlatan Konbuyu başlatan desk
  • Başlangıç tarihi Başlangıç tarihi
ozgretmen üstadım kod harika işte budur dedirtiyor fakat 100 tane dosyaya bunları ekleyeceğim form olmadan tek bir bölüme tek bir kod halinde eklersem daha kısa sürede bitiririm tek bir kod haline getirmeme yardımcı olurmusun.
 
desk' Alıntı:
ozgretmen üstadım kod harika işte budur dedirtiyor fakat 100 tane dosyaya bunları ekleyeceğim form olmadan tek bir bölüme tek bir kod halinde eklersem daha kısa sürede bitiririm tek bir kod haline getirmeme yardımcı olurmusun.
Genişletmek için tıkla ...
Aşağıdaki şekilde dener misin ?
Kod: 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
sifre = InputBox("KAYIT İÇİN ŞİFRE GİRMELİSİNİZ", _
"Yetkili Kişi", "Kaydetmek İçin Şifre girin")
Workbooks.Open Filename:="C:\kayit.xls"
If Val(sifre) = Val(Workbooks("kayit.xls").Sheets("kayit").Range("A1").Value) Then
satir = [A65536].End(3).Row + 1
Cells(satir, "A") = Mid(Environ(5), WorksheetFunction.Find("=", Environ(5)) + 1, Len(Environ(5)))
Cells(satir, "B") = Format(Date, "d mmmm yyyy dddd")
Cells(satir, "C") = Format(Now, "hh:mm:ss")
ActiveWorkbook.Save
Application.DisplayAlerts = False
ActiveWindow.Close
MsgBox "Kayıt işlemi tamamlandı", vbInformation, "KAYIT BAŞARILI OLDU"
Else
ActiveWorkbook.Save
Application.DisplayAlerts = False
ActiveWindow.Close
MsgBox "Yanlış şifre girdiniz." & Chr(13) & _
"Dosya kaydedilemedi", vbCritical, "Hatalı Şifre Girdiniz"
Cancel = True
End If
End Sub
 
'iyi günler öncelikle yukarıdaki yazdığım kodlarda eksiklik olmuş aşağıdaki gibi kodu denerseniz çalışır sizin belki işleminiz oldu ancak bu formu takip eden kişiler için yukarıdaki makronun çalışmasının iyi olacağı düşüncesindeyim

Private Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpTampon As String, nsize As Long) As Long
Private Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nsize As Long) As Long
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
sifre = InputBox("KAYIT İÇİN ŞİFRE GİRMELİSİNİZ", _
"Yetkili Kişi", "Kaydetmek İçin Şifre girin")
If sifre = "123456" Then
ara = Chr$(9)
Dim Bilgisayar As String * 100
Dim Bilgisayar1 As Long
Bilgisayar1 = 100
GetComputerName Bilgisayar, Bilgisayar1
Dim Kullanıcı As String * 100
Dim Kullanıcı1 As Long
Kullanıcı1 = 100
GetUserName Kullanıcı, Kullanıcı1
Bilgisayar_Adi = "Bu bilgisayarın Adı :" & Left(Bilgisayar, Bilgisayar1) & " "
Kullanıcı_Oturumunun_Adı = "Kullanıcı Oturumunun Adı :" & Left(Kullanıcı, Kullanıcı1 - 1) & " "
Kullanici_Adi = "Kullanıcı adı :" & Application.UserName & " "
tarih = "Tarih :" & Format(Date, "d mmmm yyyy dddd") & " "
saat = "Saat :" & Format(Now, "hh:mm:ss")
yaz = Bilgisayar_Adi & ara & Kullanıcı_Oturumunun_Adı & ara & Kullanici_Adi & ara & tarih & ara & saat

Open ThisWorkbook.Path & "\kayit.xls" For Append As #1
Print #1, yaz
Close #1
MsgBox "Kayıt işlemi tamamlandı", vbInformation, _
"KAYIT BAŞARILI OLDU"

Else
MsgBox "Yanlış şifre girdiniz." & Chr(13) & _
"Dosya kaydedilemedi", vbCritical, "Hatalı Şifre Girdiniz"
Cancel = True
End If
End Sub
 

Ekli dosyalar

ozgretmen üstad. bir sorunla karşılaştım kullandığım makine server makinası d: sürücüsü olarak bende görünüyor fakat ağda herkeze z: olarak açık bunu nasıl aşabilirim.? Birde kayıt ettiği dosyanın ismini üçüncü sütun olarak nasıl yazdırabilirim.
 
bu klasör yolu problemini nasıl halledeceğim.
 
klasör yolu sana negibi lazım burada kayıt işlemimi yapılıcık
 
Ağda herkez kullanacak bu excel dosyalarını fakat server makinası benim makinam D: ama başkaları ağdan bağlı olduğu için Z: onlara Z: görünüyor böylelikle ben ulaşırsam D:\kayit.xls yaparsam kodu ben çalıştırabiliyorum. Z:\kayit.xls yaptığımda ağdakiler ulaşibiliyor fakat ben çalıştıramıyorum bu sefer. Kayıt işlemini tam gerçekleştiremiyorum.
 
bilgisayarların hepsinin adı farklı değilmi
 
senin bilgisayarın adını yaz buraya Application.UserName bir formül yapalım
senin bilgisayarında d sürücüsü görsün diğerlerinde z sürücüsünü görsün
 
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "/Kayit/kayit.xls"

Şöyle çözüm buldum sonuçta her klasörün altında olacağına göre sanırım oldu. Fakat kayit.xls ye şifre koydum bunu nasıl aşabilirim.?
 
ŞÖYLE BİR ŞEY YAPTIM OLURMU

dosyaadi = ThisWorkbook.Path & "\kayit.xls"
diğerdosya = Len(dosyaadi)
On Error Resume Next
If Application.UserName = "buraya senin bilgisayarının adını yazacaksın" Then
dosyaadi
Else
dosyaadi1 = "Z" & Mid(dosyaadi, 2, diğerdosya)
End If
 
halit3 üstadım dosya yolu konusunu çözdüm kayit.xls ye verdiğim şifreyi nasıl geçirtebilirim. ve kayıt ettiğim dosyadaki dosya ismini nasıl D sütununa yazdırabilirim.
 
sen dosyanın son halini bir gönder bakayım
 
aşağıdaki kodla yazmış olduğun şifreyi okutabilirsin

dosyaadi = ThisWorkbook.Path & "\kayit.xls"
Dim tel As String * 100
Open dosyaadi For Random As #1 Len = Len(tel)
Get #1, 1, tel
Close #1
MsgBox tel
 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
sifre = InputBox("DİKKAT.!!! KAYIT İŞLEMİ İÇİN ŞİFRE GİRMELİSİNİZ!!!", _
"<<KAYIT ŞİFRE BÖLÜMÜ>>", "Kaydetmek İçin Lütfen Şifre giriniz.!!!")
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "/Kayit/kayit.xls"
If (sifre) = (Workbooks("kayit.xls").Sheets("Sayfa1").Range("A1").Value) Then
satir = [A65536].End(3).Row + 1
Cells(satir, "A") = Mid(Environ(5), WorksheetFunction.Find("=", Environ(5)) + 1, Len(Environ(5)))
Cells(satir, "B") = Format(Date, "d mmmm yyyy dddd")
Cells(satir, "C") = Format(Now, "hh:mm:ss")
ActiveWorkbook.Save
Application.DisplayAlerts = False
ActiveWindow.Close
MsgBox "Kayıt işlemi tamamlandı", vbInformation, "KAYIT BAŞARILI OLDU"
Else
ActiveWorkbook.Save
Application.DisplayAlerts = False
ActiveWindow.Close
MsgBox "Yanlış şifre girdiniz." & Chr(13) & _
"Dosya kaydedilemedi", vbCritical, "Hatalı Şifre Girdiniz"
Cancel = True
End If
End Sub

Şu haliyle gayet güzel çalışıyor fakat kayit.xls ye diyelimki şifre 111 koydum bunu nasıl geçmesini sağlayacağım sorum bu .! Ayrıca D sütununa yani kayit.xls nin D sütununa kayıt kaydet butonunu çalıştırdığım dosya nın adını yazdırmak istiyorum.
 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
sifre = InputBox("DİKKAT.!!! KAYIT İŞLEMİ İÇİN ŞİFRE GİRMELİSİNİZ!!!", _
"<<KAYIT ŞİFRE BÖLÜMÜ>>", "Kaydetmek İçin Lütfen Şifre giriniz.!!!")
Workbooks.Open Filename:=ThisWorkbook.Path & "\" & "/Kayit/kayit.xls", Password:="111"
If (sifre) = (Workbooks("kayit.xls").Sheets("Sayfa1").Range("A1").Value) Then
satir = [A65536].End(3).Row + 1
Cells(satir, "A") = Mid(Environ(5), WorksheetFunction.Find("=", Environ(5)) + 1, Len(Environ(5)))
Cells(satir, "B") = Format(Date, "d mmmm yyyy dddd")
Cells(satir, "C") = Format(Now, "hh:mm:ss")
ActiveWorkbook.Save
Application.DisplayAlerts = False
ActiveWindow.Close
MsgBox "Kayıt işlemi tamamlandı", vbInformation, "KAYIT BAŞARILI OLDU"
Else
ActiveWorkbook.Save
Application.DisplayAlerts = False
ActiveWindow.Close
MsgBox "Yanlış şifre girdiniz." & Chr(13) & _
"Dosya kaydedilemedi", vbCritical, "Hatalı Şifre Girdiniz"
Cancel = True
End If
End Sub

ŞİFREYİDE GEÇTİM bir tek çalıştığım dosyanın adının kayit.xls nin D sütununa yazılması kaldı.
 
Cells(satir, "D") = Replace(ThisWorkbook.Name, ".xls", "")

Onuda başardım çok tşk ederim herkeze özellikle ozgretmen ve halit3 ustalara.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst