Buda sayın berduş hocamızın yardımıyla olan bir kod ile yaptım.
Yani formdaki sub lara ve function lara ulaşma olayı.
Bu dosyadada ne kadar sürükle bırak yapılırsa yavaşlıyor garip
Giüncel ve hızlı çalışan dosya ektedir.
Class kodlar;
Option Compare Database
Public WithEvents opt As ListView
Dim adbulLstvew
Private Sub Class_Terminate()
Set opt = Nothing
End Sub
Private Sub opt_ItemClick(ByVal Item As MSComctlLib.ListItem)
veri = opt.SelectedItem
End Sub
Private Sub opt_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
Form_Form2.güncelle adbul, veri
End Sub
Public Property Get adbul() As Variant
adbul = adbulLstvew
End Property
Public Property Let adbul(ByVal Value As Variant)
adbulLstvew = Value
End Property
Form Kodlar;
Option Compare Database
Private Kontrol As New Collection
Const ii As Byte = 20
Public Sub FillEmployees(ad As String)
On Error GoTo ErrorHandler
'set variables
Dim rst As New ADODB.Recordset
Dim lstItem As ListItem
Dim strSQL As String
strSQL = "SELECT * FROM Tablo2 WHERE id1=" & Format(Right(ad, 2), "00")
rst.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
With Me(ad)
'Set ListView style
.View = lvwReport
'This is not supported by ListView 5
.GridLines = True
.FullRowSelect = True
'Clear Header and ListItems
.ListItems.Clear
.ColumnHeaders.Clear
End With
'Set up Column headers
With Me(ad).ColumnHeaders
.Add , , "id", 0, lvwColumnLeft
.Add , , "Adı Soyadı", 2000, lvwColumnLeft
.Add , , "Görevi", 2600, lvwColumnLeft
End With
' Add items and subitems to list control.
rst.MoveFirst
If rst.EOF <> True Then
Do
Set lstItem = Me(ad).ListItems.Add()
lstItem.Text = rst!ID
lstItem.SubItems(1) = Nz(rst!adisoyadi)
lstItem.SubItems(2) = Nz(rst!görevi)
rst.MoveNext
Loop Until rst.EOF
End If
'close recordset
rst.Close
DoCmd.Echo True
ErrorHandlerExit:
Set rs = Nothing
Exit Sub
ErrorHandler:
If Err = 3021 Then ' no current record
Resume Next
Else
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume ErrorHandlerExit
End If
rst.Close
Set rs = Nothing
strSQL = vbNullString
End Sub
Private Sub Form_Current()
Dim ctl As Variant
Dim i As Variant
Dim TxtOpt As ClsLstvew
For i = 0 To ii
Set TxtOpt = New ClsLstvew
Select Case i
Case 0
TxtOpt.adbul = Me.Controls("L00").Name
Set TxtOpt.opt = Controls("L00").Object
Case 1 To 9
TxtOpt.adbul = Me.Controls("L0" & i).Name
Set TxtOpt.opt = Controls("L0" & i).Object
Case Else
TxtOpt.adbul = Me.Controls("L" & i).Name
Set TxtOpt.opt = Controls("L" & i).Object
End Select
Kontrol.Add TxtOpt
Next
For i = 0 To ii
Call FillEmployees("L" & Format(i, "00"))
Next
DoCmd.Maximize
End Sub
Private Sub Komut43_Click()
DoCmd.Quit
End Sub
Public Function güncelle(asd As String, ByVal asde As Integer)
Dim i As Variant
Dim rstkayit As New ADODB.Recordset
Dim strSQL As String
strSQL = "UPDATE Tablo2 SET id1 =" & Right(asd, 2) & " WHERE id =" & asde & ";"
CurrentProject.Connection.Execute strSQL
For i = 0 To ii
Call FillEmployees("L" & Format(i, "00"))
Next
End Function
Modül kod;
Option Compare Database
Public veri As String
şimdi geldi sıra
listelerden sadece içeriği değişen 2 tanesinin güncellenmesine
20 kutu için 40 tane ayrı kod vardı o zaman hangisinden geldiğini kolayca bulup
For i = 0 To ii
Call FillEmployees("L" & Format(i, "00"))
Next
içerisine if yazarak
For i = 0 To ii
if(target = i OR source = i) then
Call FillEmployees("L" & Format(i, "00"))
end if
Next
sadece 2 liste kutusu güncelleniyordu
bunu nasıl yapabiliriz
sadece ilgili liste kutularının güncellenmesi için şunları ekledim (ok ile işaretli satırlar)
Public veri As String
Public sourceListViewNumber As Integer <--------
Public targetListViewNumber As Integer <--------
Private Sub opt_ItemClick(ByVal Item As MSComctlLib.ListItem)
sourceListViewNumber = CInt(Mid(adbul, 2)) <--------
veri = opt.SelectedItem
End Sub
Private Sub opt_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
targetListViewNumber = CInt(Mid(adbul, 2)) <--------
Form_Form2.güncelle adbul, veri
End Sub
For i = 0 To ii
If (sourceListViewNumber = i Or targetListViewNumber = i) Then <--------
Call FillEmployees("L" & Format(i, "00"))
End If <--------
Next
Rica ederim verdiğiniz linkteki dosyada öyle kodlar yok biliyorum.
Sorun çözüldü mü?
