Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Haziran 2008 Cuma

Data Base Management on UserForm's ListBox







'UserForm1

Option Explicit
Dim i As Single
Dim KaynakAdres As String
Dim No, Adet As Double

Private Sub UserForm_Initialize()
     On Error Resume Next
     Me.Caption = "[PBİD®] Data Base Management on UserForm's ListBox..."
     Adet = Application.WorksheetFunction.CountA(Range("B2:B65536"))
     If (Adet > 0) Then
          KaynakAdres = "Veri!A2:D" & (Adet + 1)
          With ListBox1
              .List() = Range(KaynakAdres).Value
              .ColumnCount = 4
              .ColumnWidths = "36;90;90;66"
              .Width = (36 + 90 + 90 + 66 + 12)
              .Height = 90.75
              .ListIndex = 0
          End With
     Else
          With ListBox1
               .ColumnCount = 4
               .ColumnWidths = "36;90;90;66"
               .Width = (36 + 90 + 90 + 66 + 12)
              .Height = 90.75
              .AddItem 1
              .List(0, 1) = ""
              .List(0, 2) = ""
              .List(0, 3) = ""
              Adet = .ListCount
              .ListIndex = 0
              No = 0
          End With
     End If
     TextBox1.Locked = True
End Sub

Private Sub UserForm_Activate()
     On Error Resume Next
     Do
          Label6.Caption = ListBox1.ListCount
          Vba.DoEvents
     Loop
End Sub

Private Sub UserForm_Terminate()
     On Error Resume Next
     Call KayıtGüncelle
End Sub

Private Sub ListBox1_Click()
     On Error Resume Next
     No = ListBox1.ListIndex
     TextBox1.Value = ListBox1.List(No, 0)
     TextBox2.Value = ListBox1.List(No, 1)
     TextBox3.Value = ListBox1.List(No, 2)
     TextBox4.Value = ListBox1.List(No, 3)
End Sub

Private Sub TextBox2_Change()
     On Error Resume Next
     No = ListBox1.ListIndex
     ListBox1.List(No, 1) = TextBox2.Value
End Sub

Private Sub TextBox3_Change()
     On Error Resume Next
     No = ListBox1.ListIndex
     ListBox1.List(No, 2) = TextBox3.Value
End Sub

Private Sub TextBox4_Change()
     On Error Resume Next
     No = ListBox1.ListIndex
     ListBox1.List(No, 3) = TextBox4.Value
End Sub

Private Sub CommandButton1_Click() 'Kayıt Ekle
     On Error Resume Next
     No = ListBox1.ListIndex
     With ListBox1
           .AddItem "", No
           .List(No, 1) = ""
           .List(No, 2) = ""
           .List(No, 3) = ""
           Adet = .ListCount
           .ListIndex = No
           For i = 0 To (Adet - 1)
                .List(i, 0) = (i + 1)
           Next i
           TextBox1.Value = .List(No, 0)
           TextBox2.Value = .List(No, 1)
           TextBox3.Value = .List(No, 2)
           TextBox4.Value = .List(No, 3)
      End With
End Sub

Private Sub CommandButton2_Click() 'Kayıt Sil
     On Error Resume Next
     If MsgBox("Silme işlemine devam etmek istiyormusunuz!" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbOKCancel, "[PBİD®] Lütfen Dikkat") = vbCancel Then Exit Sub
     No = ListBox1.ListIndex
     If (Adet > 0) Then
          TextBox1.Value = ""
          TextBox2.Value = ""
          TextBox3.Value = ""
          TextBox4.Value = ""
          With ListBox1
               .RemoveItem No
               Adet = .ListCount
               If (Adet > 0) Then
                    For i = 0 To (Adet - 1)
                         .List(i, 0) = (i + 1)
                    Next i
                    No = .ListIndex
                    TextBox1.Value = .List(No, 0)
                    TextBox2.Value = .List(No, 1)
                    TextBox3.Value = .List(No, 2)
                    TextBox4.Value = .List(No, 3)
               Else
                    .AddItem 1
                    .List(0, 1) = ""
                    .List(0, 2) = ""
                    .List(0, 3) = ""
                    Adet = .ListCount
                    .ListIndex = 0
                    No = 0
               End If
          End With
     End If
End Sub

Private Sub CommandButton3_Click() 'Güncelle      On Error Resume Next
     Call KayıtGüncelle
End Sub

Sub KayıtGüncelle()
     On Error Resume Next
     If MsgBox("Tüm veri tabanı değişecektir. Güncelleme işlemine devam etmek istiyormusunuz!" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbOKCancel, "[PBİD®] Lütfen Dikkat") = vbCancel Then Exit Sub
     With ListBox1
          Range("A2:D65536").ClearContents
          Adet = .ListCount
          KaynakAdres = "Veri!A2:D" & (Adet + 1)
          Range(KaynakAdres) = .List()
     End With
End Sub

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul