Userform ile Access veritabanına kayıt yapmak istiyorum.

[s.savas]

Merhaba arkadaşlar.
Nette gezinirken personel izin takibi amacıyla yazılmış bir program denk geldi.
Bütün veriler access veritabanında tutuluyor, excelde userform aracılığı ile de veritabanına bağlanılıyor.
Ancak yazılımcı yeni kayıt yapma özelliğini bilinçli olarak eksik bırakmış.
Mantık olarak çok yerinde bir yöntem kullanmış. Excelde hiç bir veri tutulmadığı için şişme, kasma vs bir sorun teşkil etmiyor.
Amacım kişinin yazmış olduğu kodları veya programı sahiplenmek değildir. Alışılagelmiş excelde yapılmış programlarımı aynı mantıkla yeniden düzenleyebilmek ve access ile beraber sql'in nimetlerinden faydalanmak.
Programın algoritması şu şekilde;
Userform access database'ine bir şifre ile bağlanıyor.

Sub DbKontrol()
Dim Yoll As String
    If Yoll = "" Then Yoll = ThisWorkbook.Path
    DatabasePath = Yoll & "\database.mdb"
    If Dir(DatabasePath) = "" Then
        On Error Resume Next
        MsgBox DatabasePath & " bulunamadı, programdan çıkılacak !", vbCritical, "....!"
        Application.DisplayAlerts = False
        Application.Visible = True
        Application.Workbooks.Close
    End If
End Sub

Sub DbAc()
Dim Yoll As String
    If Yoll = "" Then Yoll = ThisWorkbook.Path
    DatabasePath = Yoll & "\database.mdb"
    On Error Resume Next
    Set adoCN = CreateObject("ADODB.Connection")
If Val(Application.Version) >= 12 Then
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0;Jet OLEDB:Database Password=Şifre;"
Else
    'adoCN.Provider = "Microsoft.Jet.OLEDB.4.0"
    adoCN.Provider = "Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Database Password=Şifre;"
End If
    adoCN.ConnectionString = DatabasePath
    adoCN.Open
End Sub

Database bağlantısından sonra değiştir, sil işlemleri yapılabiliyor.

Sub kaydet()
Dim i As Integer
Dim kaydetmodu As String
Dim basliklar()
Dim degerler(50) As Variant

    degerler(0) = UserForm1.Controls("TextBoxPerIDX").Value: If degerler(0) = "" Then Exit Sub
    degerler(1) = UserForm1.Controls("TextBox1").Value
'Call DbAc

    strlog = "Select personel.idx, personel.ad From personel Where personel.idx=" & degerler(0)
    
    Set RS = CreateObject("ADODB.recordset")
    RS.Open strlog, adoCN, 1    ', 3
    'Set RS = adoCN.Execute(strlog)
    If RS.RecordCount > 0 Then
        sor = MsgBox("Var olan " & degerler(1) & " personel noya ait kayıt değiştirilecek." & Chr(10) & "Devam edeyim mi ?", vbYesNo + vbInformation + vbDefaultButton2, "Dikkat")
        If sor = vbNo Then Exit Sub
        kaydetmodu = "degistir"
    End If
    RS.Close
    Set RS = Nothing
    
basliklar = Array("idx", "per_no", "ad", "soyad", "ilk_soyad", "tc_kimlik_no", "cinsiyet", "dogum_tarihi", "dogum_yeri", "baba_ad", "ana_ad", "ise_giris_tarihi", "is_cikis_tarihi", "hafta_tatili", "statu", "medeni_hali", "ssk_no", "dept", "gorev", "tahsil", "meslek", "ev_tel", "is_tel", "cep_tel", "eposta", "adres", "adres_il", "adres_ilce", "kan_grubu", "nfs_seri", "nfs_no", "nfs_kay_il", "nfs_kay_ilce", "nfs_kay_mah_koy", "cilt_no", "aile_sno", "sira_no", "aciklama")

        For i = 2 To 37
            Select Case i
            Case 6, 13, 14, 15, 17, 18, 19, 28
                degerler(i) = UserForm1.Controls("ComboBox" & i).Value
            Case Else
                degerler(i) = UserForm1.Controls("TextBox" & i)
            End Select
        Next i
        
If degerler(1) = "" Or degerler(2) = "" Or degerler(3) = "" Then MsgBox "Personel No, Adı ve Soyadı boş olamaz..": Exit Sub
If degerler(7) = "" Or degerler(11) = "" Then MsgBox "Doğum tarihi ve İşe Giriş tarihi boş olamaz..": Exit Sub
If degerler(14) = "" Or degerler(17) = "" Then MsgBox "Statü ve Bölüm boş olamaz..": Exit Sub

    strlog = "Select personel.idx, personel.ad From personel Where personel.per_no='" & degerler(1) & "'"
    Set RS = CreateObject("ADODB.recordset")
    RS.Open strlog, adoCN, 1    ', 3
    'Set RS = adoCN.Execute(strlog)
    If RS.RecordCount > 0 Then
        RS.MoveFirst
        Do While Not RS.EOF
            If RS("idx") <> Val(degerler(0)) Then MsgBox "Aynı Personel Numarası ile kayıtlı bir kişi var!": Exit Sub
        RS.MoveNext
        Loop
    End If
    RS.Close
    Set RS = Nothing

If kaydetmodu = "degistir" Then
    strSQL = "UPDATE personel SET " & "personel." & basliklar(1) & " = '" & degerler(1) & "'"
    For i = 2 To 37
        Select Case i
            Case 7, 11, 12
                If degerler(i) = "" Then
                strSQL = strSQL & ", " & "personel." & basliklar(i) & " =NULL"
                Else
                strSQL = strSQL & ", " & "personel." & basliklar(i) & " = '" & degerler(i) & "'"
                End If
            Case Else
                strSQL = strSQL & ", " & "personel." & basliklar(i) & " = '" & degerler(i) & "'"
        End Select
    Next i
        strSQL = strSQL & " WHERE personel.idx=" & degerler(0)
Else
   ' ............. kodlar
   '.............. kodlar
    MsgBox "Mesaj....", , "......."
End If
'MsgBox strSQL
On Error Resume Next
adoCN.Execute (strSQL)
'Call DbKapat
End Sub

Burada yeni kayıt işlemleri yapılması gerekiyor.
Zamanı müsait olan arkadaşların yardımlarını rica ediyorum.

 

[s.savas]

Arkadaşlar legal olmayan veya sakıncalı bir talep yaptığımı düşünüyorsanız konuyu silebilirim.
Konu geliştirilmeye değer, access veritabanı ile excelin birlikte çalışabileceği güzel bir uygulama.