VBA.Mania

'----------------------------------------------------------
' Form Class : frmObiektyTypy
'----------------------------------------------------------
Option Explicit

Dim RsOb As ADODB.Recordset
Dim bRsReady As Boolean
Dim bObSelRsReady As Boolean

Private Sub UserForm_Initialize()
    Call PobierzRsDisconnected
End Sub
' xxxxx adodb error
Public Sub PobierzRsDisconnected()
    On Error GoTo Pobie_Error
    Dim strSql As String
    Dim Cn As ADODB.Connection
    Dim RsTemp As ADODB.Recordset

    Set Cn = New ADODB.Connection
    With Cn
        .ConnectionString = MojConnString()
        .CursorLocation = adUseClient
        .Open
    End With
    ' Typy
    strSql = "SELECT id_typob,nazwa_typob,opis_typob FROM tbltypy"
    Set RsTemp = Cn.Execute(strSql, , adCmdText)
    With RsTemp
        Set .ActiveConnection = Nothing    ' Disconnect
        If Not (.BOF And .EOF) Then
            Me.cmbTyp.Column() = .GetRows(adGetRowsRest, adBookmarkFirst)    ' do ComboBox
        End If
        .Close                         ' nie jest juz potrzebny
    End With
    ' Obiekty
    strSql = "SELECT id_ob, nazwa_ob,opis_ob, id_typob,Image_ob FROM tblobiekty"
    Set RsTemp = New ADODB.Recordset
    With RsTemp
        .CursorLocation = adUseClient: .LockType = adLockReadOnly: .CursorType = adOpenStatic
        .Open strSql, Cn
        Set .ActiveConnection = Nothing    ' Disconnect
        Set RsOb = New ADODB.Recordset
        Set RsOb = .Clone
        .Close
    End With
    bRsReady = True
    With Me.cmbTyp
        If .ListCount > 0 Then .ListIndex = 0
    End With

Pobie_Exit:
    On Error Resume Next
    Call CloseAnyRs(RsTemp)
    Call CloseAnyConnection(Cn)        'bo polaczenie nie juz ptrzebne
    Exit Sub

Pobie_Error:
    Call CloseAnyRs(RsOb)              ' gdyby byl blad zamykam rowniez ten RS
    MsgBox "Błąd : ( " & Err.Number & " ) " & Err.Description & vbCrLf & _
           "Procedura : " & "Pobie", vbExclamation
    Resume Pobie_Exit
End Sub

Private Sub RefreshObjList()
    On Error GoTo RefreObjList_Error
    ' filtrujemy na na clonie tymczasowym tylko do pobrania danych
    bObSelRsReady = False
    Dim RsClone As ADODB.Recordset
    With Me
        If .cmbTyp.ListIndex < 0 Then Exit Sub
        .ImageOb.Picture = LoadPicture("")
        .lblopis_typob.Caption = Me.cmbTyp.Column(2)
        .lstOb.Clear
        .lblOPisOb.Caption = ""
    End With

    If RsOb Is Nothing Then Exit Sub
    With RsOb
        If .State <> adStateOpen Then Exit Sub
        If (.EOF And .BOF) Then Exit Sub
    End With

    Set RsClone = RsOb.Clone(adLockReadOnly)
    With RsClone                       ' filtr na Clonie
        .Filter = "id_typob=" & CStr(Me.cmbTyp.Value)
        If Not (.EOF And .BOF) Then
            ' tylko 2 pola do ListBox
            Me.lstOb.Column() = .GetRows(adGetRowsRest, adBookmarkFirst, VBA.Array("id_ob", "nazwa_ob"))
        End If
    End With
    bObSelRsReady = True
    With Me.lstOb
        If .ListCount > 0 Then .ListIndex = 0
    End With

RefreObjList_Exit:
    On Error Resume Next
    Call CloseAnyRs(RsClone)           '2-gi clon musze zamknac zwolinic pamiec
    Exit Sub

RefreObjList_Error:
    MsgBox "Błąd : ( " & Err.Number & " ) " & Err.Description & vbCrLf & _
           "Procedura : " & "RefreObjList", vbExclamation
    Resume RefreObjList_Exit
End Sub

Private Sub cmbTyp_Click()
    If bRsReady = True Then RefreshObjList
End Sub

Private Sub lstOb_Click()
    If bObSelRsReady = False Then Exit Sub
    Dim strIdOb As String
    With Me
        .ImageOb.Picture = LoadPicture("")
        .lblOPisOb.Caption = ""
    End With
    With lstOb
        If .ListIndex < 0 Then Exit Sub
        strIdOb = CStr(.Value)
    End With
    If RsOb Is Nothing Then Exit Sub
    With RsOb                          ' w zasadzie tu tez mozna po Clone
        If .State <> adStateOpen Then Exit Sub
        If (.EOF And .BOF) Then Exit Sub
        .Find "id_ob=" & strIdOb, , adSearchForward, adBookmarkFirst    ' to jest po unikalnym id_ob
        If .EOF Then Exit Sub
        If Not IsNull(.Fields("opis_ob").Value) Then Me.lblOPisOb.Caption = .Fields("opis_ob").Value
        Call ImageToFile(.Fields("Image_ob"), Me.ImageOb)
    End With
End Sub

Private Sub UserForm_Terminate()
    Call CloseAnyRs(RsOb)
End Sub

'------ to moze byc w standard jesli jest gdzies jeszcze potrzebne -----------
Public Sub ImageToFile(Fld As ADODB.Field, CtlImage As MSForms.Image)
    On Error GoTo ImageToFile_Error
    If IsNull(Fld.Value) Then Exit Sub
    Dim strTmp As String
    Dim oStream As ADODB.Stream

    strTmp = ImagePath() & "Temp.bmp"
    Set oStream = New ADODB.Stream
    With oStream
        .Type = adTypeBinary
        .Open
        .Write Fld.Value
        .SaveToFile strTmp, adSaveCreateOverWrite
    End With
    CtlImage.Picture = LoadPicture(strTmp)    ' do Image Control

ImageToFile_Exit:
    On Error Resume Next
    Kill (strTmp)                      ' przed kill 3ba sprawdzic czy jest ...
    Call CloseAnyStream(oStream)
    Exit Sub

ImageToFile_Error:
    MsgBox "Błąd : ( " & Err.Number & " ) " & Err.Description & vbCrLf & _
           "Procedura : " & "ImageToFile", vbExclamation
    Resume ImageToFile_Exit
End Sub

Public Sub CloseAnyStream(objStream As ADODB.Stream)
    On Error Resume Next
    If Not objStream Is Nothing Then
        With objStream
            If .State = adStateOpen Then
                .Close
            End If
        End With
    End If
    Set objStream = Nothing
End Sub

Public Sub CloseAnyRs(oRs As ADODB.Recordset)
    On Error Resume Next
    If Not oRs Is Nothing Then
        With oRs
            If .State = adStateOpen Then .Close
        End With
    End If
    Set oRs = Nothing
End Sub

Public Sub CloseAnyConnection(oConn As ADODB.Connection)
    On Error Resume Next
    If Not oConn Is Nothing Then
        With oConn
            If .State = adStateOpen Then .Close
        End With
    End If
    Set oConn = Nothing
End Sub

Dim i As Integer
i = 0
With formularz.test
    .Clear
    Do
        .AddItem
        formularz.test(i, 0) = nazwaModulu.PobierzPrzechCmdParam.arrWynik(0,i)
        i = i + 1
        nazwaModulu.PobierzPrzechCmdParam.arrWynik.MoveNext
    Loop Until nazwaModulu.PobierzPrzechCmdParam.arrWynik.EOF
End With

Sub PobierzPrzechCmdParam()
' procedura - tresc z parametrem - nazwa ProcPolaTabeli
    'CREATE PROCEDURE ProcPolaTabeli
    '@Table_Name varchar(128)
    'AS
    'BEGIN
    ' SELECT *
    ' FROM SYSCOLUMNS
    ' WHERE (ID=object_id(@Table_Name))
    'End
    On Error GoTo Pobie_Error
    Dim arrWynik
    Dim lngRow As Long
    Dim lngCol As Long
    '----------
    Dim Cn As ADODB.Connection
    Set Cn = New ADODB.Connection
    With Cn
        .ConnectionString = MojConnString()
        .CursorLocation = adUseClient
        .Open
    End With
    Call PolaTabeliParamProc(Cn, "tblmoja", arrWynik)
    If IsArray(arrWynik) Then
        For lngRow = 0 To UBound(arrWynik, 2)
            For lngCol = 0 To UBound(arrWynik, 1)
                ' do okienka Immediate
                Debug.Print arrWynik(lngCol, lngRow)
            Next
        Next
    End If
Pobie_Exit:
    On Error Resume Next
    If Not Cn Is Nothing Then
        With Cn
            If .State = adStateOpen Then .Close
        End With
    End If
    Set Cn = Nothing
    Exit Sub
Pobie_Error:
    MsgBox "Błąd : ( " & Err.Number & " ) " & Err.Description & vbCrLf & _
           "Procedura : " & "Pobie", vbExclamation
    Resume Pobie_Exit
End Sub
'-------------------------------------------
Sub PolaTabeliParamProc(oCn As ADODB.Connection, ByVal sTableName As String, vWynik)
    On Error GoTo PolaTabel_Error

    Dim strProcName As String
    strProcName = "ProcPolaTabeli"

    Dim lngRecordsAffected As Long
    Dim Rs As ADODB.Recordset
    Dim Cmd As ADODB.Command
    Set Rs = New ADODB.Recordset
    Set Cmd = New ADODB.Command
    With Cmd
        Set .ActiveConnection = oCn
        .CommandText = strProcName
        .CommandType = adCmdStoredProc
        ' niektore sposoby
        ' tak:
        ' Set Rs = Cmd.Execute(lngRecordsAffected, "[" & sTableName & "]", adCmdStoredProc)
        ' lub tak
        ' Set Rs = .Execute(, VBA.Array("[" & sTableName & "]"))
        ' lub tak
        .Parameters.Append .CreateParameter("Table_Name", _
                                            adVarChar, adParamInput, _
                                            128, "[" & sTableName & "]")
        Set Rs = .Execute(lngRecordsAffected)
    End With
    With Rs
        If Not (.EOF And .BOF) Then
            vWynik = .GetRows(adGetRowsRest, adBookmarkFirst, .Fields("name").Name)
        End If
    End With

PolaTabel_Exit:
    On Error Resume Next
    If Not Rs Is Nothing Then
        With Rs
            If .State = adStateOpen Then .Close
        End With
    End If
    Set Rs = Nothing
    Set Cmd = Nothing
    Exit Sub
PolaTabel_Error:
    MsgBox "Błąd : ( " & Err.Number & " ) " & Err.Description & vbCrLf & _
           "Procedura : " & "PolaTabel", vbExclamation
    Resume PolaTabel_Exit
End Sub

Option Explicit

Dim lacz As New ADODB.Connection
Dim Rs As New ADODB.Recordset
Dim sSql As String

Sub lancz_db()

Dim sDbMSSQLconn As String
Dim lDbState As Long

On Error GoTo Error_Handling

sDbMSSQLconn = "Provider=sqloledb;Data Source=***\SQL***;Initial Catalog=***;Uid=***;Pwd=***;"
    'łączenie z bazą

lacz.Open sDbMSSQLconn
lDbState = lacz.State

'MsgBox "połączono z bazą"

   Debug.Print lacz

sSql = "use [baza]"
Rs.Open sSql, lacz          'wykonanie zapytania

ExitHere:

' lacz.Close
   Rs.Close

   Set lacz = Nothing

' Set rs = Nothing

   Exit Sub

Error_Handling:

   'jeżeli urzytkownik da cancel.

   If Err.Number = 91 Then

      Resume ExitHere

   End If

End Sub

Sub Pobierz()
    On Error GoTo Pobie_Error
    Dim arrWynik
    Dim lngRow As Long
    Dim lngCol As Long
    Dim Cn As ADODB.Connection
    Set Cn = New ADODB.Connection
    With Cn
        .ConnectionString = MojConnString()
        .CursorLocation = adUseClient
        .Open
    End With
    Call PolaTabeli(Cn, "tblmoja", arrWynik)
    If IsArray(arrWynik) Then
        For lngRow = 0 To UBound(arrWynik, 2)
            For lngCol = 0 To UBound(arrWynik, 1)
                ' do okienka Immediate
                Debug.Print arrWynik(lngCol, lngRow)
            Next
        Next
    End If
Pobie_Exit:
    On Error Resume Next
    If Not Cn Is Nothing Then
        With Cn
            If .State = adStateOpen Then .Close
        End With
    End If
    Set Cn = Nothing
    Exit Sub
Pobie_Error:
    MsgBox "Błąd : ( " & Err.Number & " ) " & Err.Description & vbCrLf & _
           "Procedura : " & "Pobie", vbExclamation
    Resume Pobie_Exit
End Sub
'--------------------------
Sub PolaTabeli(oCn As ADODB.Connection, ByVal sTableName As String, vWynik)
    On Error GoTo PolaTabel_Error
    Dim strSql As String
    strSql = "SELECT name FROM SYSCOLUMNS WHERE ID=object_id('[" & sTableName & "]')"
    Dim Rs As ADODB.Recordset
    Set Rs = New ADODB.Recordset
    With Rs
        Set .ActiveConnection = oCn
        .CursorLocation = adUseClient
        .Open strSql
        If Not (.EOF And .BOF) Then
            vWynik = .GetRows(adGetRowsRest, adBookmarkFirst, .Fields(0).Name)
        End If
    End With

PolaTabel_Exit:
    On Error Resume Next
    If Not Rs Is Nothing Then
        With Rs
            If .State = adStateOpen Then .Close
        End With
    End If
    Set Rs = Nothing
    Exit Sub
PolaTabel_Error:
    MsgBox "Błąd : ( " & Err.Number & " ) " & Err.Description & vbCrLf & _
           "Procedura : " & "PolaTabel", vbExclamation
    Resume PolaTabel_Exit
End Sub

Sub ISelct()
lancz_db
'''fiSelectSql ("[test]")
Dim kolumny(1 To 10) As String

'''''tutaj chcę przypisać nazwy kolumn pobranych po przez poniższą funkcję''''''
''''' np żeby to dzialało w taki sp kolumny(1) = fiSelectSql(1): kolumny(2) = fiSelectSql(2)
''''' lub po prostu potem to dać do pętli
'''' nie mam pomysu także jak dalej przekazać dane do zmiennej tabela
End Sub

'''' należalo by zmienić w jakiś sposób parametry wywołania
Function fiSelectSql(tabela As String) As String

Dim nazwy_kolumn As Collection

Set nazwy_kolumn = New Collection

' cmd.CommandText = "proc_" & tabela & "_select"
' cmd.CommandTimeout = 200

Dim sql As String
sql = "SELECT name FROM SYSCOLUMNS WHERE ID=object_id('" & tabela & "')"
rs.Open sql, lacz

While Not (rs.EOF)
    nazwy_kolumn.Add (rs(0))

    rs.MoveNext

Wend

Dim i, iCol As Integer
Dim kolumna(1 To 10) As String
iCol = nazwy_kolumn.Count

For i = 1 To iCol
        kolumna(i) = nazwy_kolumn.Item(i)

Next i


    rs.Close
    lacz.Close
    Set rs = Nothing

End Function