Option Explicit
'Public powr As String
Private Sub Modyfikuj_Click()
Dim Odp As Integer
Dim Klu As String 'Long
Dim Rec As String
Dim Pol As String
Rec = ActiveCell.Value
Pol = Cells(2, ActiveCell.Column).Value
Klu = Cells(ActiveCell.Row, 1).Value
Odp = MsgBox("Ostrożnie z tą siekierką Eugeniuszu !!!" & vbNewLine _
& "Klucz:          " & Klu & vbNewLine & "Pole:            " & Pol & vbNewLine & "Wartość:     " & Rec & vbNewLine _
& "Odpalić Update ???  Tak - jeden record    Nie - do końca tabeli", vbYesNoCancel)
If Odp = 6 Then
Update Pol
ElseIf Odp = 7 Then
Fast_Update Pol
End If
End Sub
Private Function Update(Pol As String)
Dim Klu As String 'Long
Dim Rec As String
Dim oCon As ADODB.Connection
Dim oRS As ADODB.Recordset
Set oCon = New ADODB.Connection
Set oRS = New ADODB.Recordset
oCon.Open Sheets("zap").Cells(1, Sheets("zap").Cells(1, 2))
Klu = Cells(ActiveCell.Row, 1).Value
Rec = ActiveCell.Value
If Rec = "" Then
oRS.Open "update " & Range("B1") & " set " & Pol & " = Null where " & Range("A2") & " = '" & Klu & "'", oCon
Else
oRS.Open "update " & Range("B1") & " set " & Pol & " = '" & Rec & "' where " & Range("A2") & " = '" & Klu & "'", oCon
End If
Set oRS = Nothing
oCon.Close
ActiveCell.Offset(1, 0).Select
End Function
Private Function Fast_Update(Pol As String)
Dim Klu As Long
Dim Rec As String
Dim oCon As ADODB.Connection
Dim oRS As ADODB.Recordset
Set oCon = New ADODB.Connection
Set oRS = New ADODB.Recordset
oCon.Open Sheets("zap").Cells(1, Sheets("zap").Cells(1, 2))
'*******************************************************************************
While Not IsEmpty(Cells(ActiveCell.Row, 1))
Klu = Cells(ActiveCell.Row, 1).Value
Rec = ActiveCell.Value
If Rec = "" Then
oRS.Open "update " & Range("B1") & " set " & Pol & " = Null where " & Range("A2") & " = '" & Klu & "'", oCon
Else
oRS.Open "update " & Range("B1") & " set " & Pol & " = '" & Rec & "' where " & Range("A2") & " = '" & Klu & "'", oCon
End If
ActiveCell.Offset(1, 0).Select
Wend
'*******************************************************************************
Set oRS = Nothing
oCon.Close
End Function

Private Sub Nowy_Arkusz_Click()
Columns("A:XFD").Select
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Paste

    ActiveSheet.Rows("1:1").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True
End Sub

Private Sub Tabela_Dane_Click()
Dim i As Integer
Range("A2:AFD1048576").ClearContents
Dim oCon As ADODB.Connection
Dim oRS As ADODB.Recordset
Set oCon = New ADODB.Connection
Set oRS = New ADODB.Recordset
'oCon.Open "Driver={PostgreSQL Unicode};Server=cp-saams1;Database=saams;Uid=appuser;Pwd=saamsadmin@1"
On Error GoTo Err1:
'oCon.Open Sheets("zap").Cells(1, Sheets("zap").Cells(1, 2))
oCon.Open Sheets("zap").Cells(1, Sheets("zap").Cells(1, 2))
On Error GoTo Err2:
'*******************************************************************************

oRS.Open "" & Range("A1"), oCon

'*******************************************************************************
Range("A3").CopyFromRecordset oRS
For i = 0 To oRS.Fields.Count - 1
Range("A2").Offset(0, i).Value = oRS.Fields(i).Name
Next i
Set oRS = Nothing
oCon.Close
Exit Sub
Err2:
Set oRS = Nothing
oCon.Close
Sheets("zap").Select
Sheets("zap").Range(Range("C1")).Select
MsgBox "Blad w zapytania SQL"
Exit Sub
Err1:
Sheets("zap").Select
Sheets("zap").Range("C1").Select
MsgBox "Blad ustawienia tunelu i/lub polaczenia do bazy"
End Sub


Private Sub Usun_Click()
If ActiveCell.Column = 1 Then
Dim Odp As Integer
Dim Klu As Long
Klu = Cells(ActiveCell.Row, 1).Value
Odp = MsgBox("Ostrożnie z tą siekierką Eugeniuszu !!!" & vbNewLine _
& "Klucz:      " & Klu & "          Tabela " & Range("J1") & vbNewLine _
& "Odpalić Delete do końca tabeli???  Tak - jeden record    Nie - do końca tabeli", vbYesNoCancel)
If Odp = 6 Then
Del_SAAMS Klu
ElseIf Odp = 7 Then
Fast_Del_SAAMS Klu
End If
End If
End Sub
Private Function Del_SAAMS(Klu As Long)
Dim oCon As ADODB.Connection
Dim oRS As ADODB.Recordset
Set oCon = New ADODB.Connection
Set oRS = New ADODB.Recordset
oCon.Open Sheets("zap").Cells(1, Sheets("zap").Cells(1, 2))
'*******************************************************************************

oRS.Open "delete from " & Range("B1") & " where " & Range("A2") & " = '" & ActiveCell.Value & "'", oCon

'*******************************************************************************
ActiveCell.Offset(1, 0).Select
Set oRS = Nothing
oCon.Close
End Function
Private Function Fast_Del_SAAMS(Klu As Long)
Dim oCon As ADODB.Connection
Dim oRS As ADODB.Recordset
Set oCon = New ADODB.Connection
Set oRS = New ADODB.Recordset
oCon.Open Sheets("zap").Cells(1, Sheets("zap").Cells(1, 2))
While Not IsEmpty(ActiveCell)
'*******************************************************************************

oRS.Open "delete from " & Range("B1") & " where " & Range("A2") & " = '" & ActiveCell.Value & "'", oCon

'*******************************************************************************
ActiveCell.Offset(1, 0).Select
Wend
Set oRS = Nothing
oCon.Close
End Function

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If ActiveCell.Column = 3 And ActiveCell.Row = 1 Then
Sheets("zap").Select
Sheets("zap").Range(Range("C1")).Select
End If
End Sub
Private Sub Xml_Click()
Sheets("Xml").Range("A1:AFD1048576").ClearContents
Sheets("Xml").Range("A1:AFD1048576").Font.ColorIndex = xlAutomatic
Sheets("Xml").Range("A1") = ActiveSheet.Name & "|" & ActiveCell.Address
Dim zta, wta As String
Dim p, k, i As Long
zta = ActiveCell
wta = ""
p = 1
k = 1
i = 1
While k > 0
k = InStr(p, zta, ">") Or InStr(p, zta, "|")
If k <> 0 Then
wta = Mid(zta, p, k - p + 1)

wta = Replace(wta, vbCrLf, "")
wta = Trim(wta)
i = i + 1
Sheets("Xml").Cells(i, 1) = i
Sheets("Xml").Cells(i, 2) = wta
p = k + 1
End If
Wend
Sheets("Xml").Select
End Sub