VBA.Mania

'----------------------------------------------------------
' Form Class module : frmAdo2LisString
' przypuscmy 2 kontrolki ListBox
' bez referencji do ADO !!!!
'----------------------------------------------------------
Option Explicit
Dim bIni As Boolean
Dim CnF As Object      ' OBJECT

Sub SQL2List(objList As MSForms.ListBox, ObjCnL As Object, ByVal sSql As String)
    On Error GoTo TableMdb2_Error
    Dim arrList
    Dim Rs As Object
    If SetRs(ObjCnR:=ObjCnL, ObjRs:=Rs, sRsSql:=sSql) = False Then Exit Sub
    With Rs
        ' juz mozna odlaczyc jesli tylko ogladamy
        Set .ActiveConnection = Nothing
        If (.BOF And .EOF) Then GoTo TableMdb2_Exit
        .MoveFirst: arrList = .GetRows(, adBookmarkFirst)
    End With
    With objList
        .MultiSelect = fmMultiSelectSingle: .ColumnCount = UBound(arrList, 2)
        .Column() = arrList: .ColumnWidths = "0;"    ' ukrywam sobie 1-sza kolumna z id_pozycja, np...
    End With

TableMdb2_Exit:
    On Error Resume Next
    ' co najmniej taka obsluga bledow jest konieczna poza tym dla listy mozna zamknac RS
    Call CloseRs(ObjRsC:=Rs)
    Exit Sub

TableMdb2_Error:
    ' komunikatu byc nie musi lecz dobra praktyka jest aby byl
    ' a info o tresci i procedurze w korej wystapil blad do plik logerror aplikacji
    ' tez powinno byc aby user moglo go Ci przeslac i abys wiedzial gdzie szukac
    MsgBox "Błąd : ( " & Err.Number & " ) " & Err.Description & vbCrLf & _
           "Procedura : " & "TableMdb2", vbExclamation
    Resume TableMdb2_Exit
End Sub

Private Sub lstAdo_1_Click()
    ' przykladowo
    Dim i As Long
    With ActiveControl
        If .ColumnCount > 0 Then
            For i = 0 To .ColumnCount - 1
                MsgBox .Column(i)
            Next
        End If
    End With
End Sub

Private Sub UserForm_Activate()
    If Not bIni Then
        If OpenConn(ObjCn:=CnF, sSciezkaBaza:=SciezkaBaza()) Then
            Call SQL2List(objList:=Me.lstAdo_1, _
                          ObjCnL:=CnF, _
                          sSql:="SELECT * FROM tbl_lista_1 ")
            'w tabeli powyzej sa pola np:id_pozycja, nazwa_pozycja, jakies_inne_pole
            Call SQL2List(objList:=Me.lstAdo_2, _
                          ObjCnL:=CnF, _
                          sSql:="SELECT * FROM tbl_lista_2 ")
            bIni = True
        End If
    End If
    ' jesli niepotrzebny a sadze ze nie nie znam szczegolow aplikacji
    Call CloseConn(ObjCnC:=CnF)
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Call CloseConn(ObjCnC:=CnF)
End Sub

'----------------------------------------------------------
' Standard Module : common_mod
' mozna uzyc w innych modulach czy klasach
'----------------------------------------------------------
Option Explicit

Public Const adUseClient = 3
Public Const adOpenForwardOnly = 0
Public Const adLockReadOnly = 1
Public Const adCmdText = 1
Public Const adStateOpen = 1
Public Const adBookmarkFirst = 1

Public Function OpenConn(ObjCn As Object, ByVal sSciezkaBaza As String) As Boolean
    On Error GoTo OpenConn_Error

    Dim strConn As String
    strConn = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
              "Data Source=" & sSciezkaBaza & ";" & "Persist Security Info=False"
    Set ObjCn = CreateObject("ADODB.Connection")
    With ObjCn
        .CursorLocation = adUseClient: .Open strConn
    End With
    OpenConn = True

OpenConn_Exit:
    Exit Function

OpenConn_Error:
    Call CloseConn(ObjCnC:=ObjCn)
    OpenConn = False
    MsgBox "Błąd : ( " & Err.Number & " ) " & Err.Description & vbCrLf & _
           "Procedura : " & "OpenConn", vbExclamation
    Resume OpenConn_Exit
End Function

Public Function SetRs(ObjCnR As Object, ObjRs As Object, ByVal sRsSql As String) As Boolean
    On Error GoTo SetRs_Error
    Set ObjRs = CreateObject("ADODB.Recordset")
    ObjRs.Open sRsSql, ObjCnR, adOpenForwardOnly, adLockReadOnly, adCmdText
    SetRs = True
SetRs_Exit:
    Exit Function

SetRs_Error:
    Call CloseRs(ObjRsC:=ObjRs)
    MsgBox "Błąd : ( " & Err.Number & " ) " & Err.Description & vbCrLf & _
           "Procedura : " & "SetRs", vbExclamation
    Resume SetRs_Exit
End Function

Public Sub CloseRs(ObjRsC As Object)
    If Not ObjRsC Is Nothing Then
        With ObjRsC
            If .State = adStateOpen Then .Close
        End With
    End If
    Set ObjRsC = Nothing
End Sub

Public Sub CloseConn(ObjCnC As Object)
    If Not ObjCnC Is Nothing Then
        With ObjCnC
            If .State = adStateOpen Then .Close
        End With
    End If
    Set ObjCnC = Nothing
End Sub