Option Base 1
Public cn As Object, FieldList(), FieldCount, SR

Sub CloseDB()

cn.Close
Set cn = Nothing
If DBUsed = "Net" Then CloseLink
End Sub
Sub OpenDB()
' Define Connection
connstr = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & _
";Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
Set cn = CreateObject("ADODB.Connection") 'C:\Users\p751993\Documents
'sconnect = "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & ThisDB '& ";Persist Security Info=False;Mode=Share Exclusive" stops other users
cn.Open connstr
End Sub
Function GetData(strSQL, Qx)
Dim a(1, 1)
'works with a select query to the DB then re-orders and returns data
Dim rs As New ADODB.Recordset
Dim TT() As Variant
GetData = a
rs.Open strSQL, cn
If rs.EOF Then Exit Function
Xdata = rs.GetRows
Xcols = UBound(Xdata)
Xrows = UBound(Xdata, 2)
ReDim TT(Xrows + 1, Xcols + 1)
For rdx = 0 To Xrows
For cdx = 0 To Xcols
TT(rdx + 1, cdx + 1) = Xdata(cdx, rdx)
Next cdx
Next rdx
If Qx = 1 Then
With rs
For cdx = 0 To .Fields.Count - 1
TT(0, cdx) = .Fields(cdx).Name
Next cdx
End With
End If

GetData = TT
rs.Close
End Function

Sub DoSQL(strSQL)

cn.Execute strSQL
CloseDB
End Sub
Function MSDateToSQL(Adate) As String
'SQL Recognises a string "YYYY-MM_DD" as a date
SQ = Chr(39)
MSDateToSQL = SQ & Format(Adate, "YYYY-mm-dd") & SQ
End Function
Sub AddNewRecord(NewData, XTable, rdx)
Dim rs As New ADODB.Recordset
'MsgBox "cannot add new Record"
'Exit Sub
OpenDB
ColRef = XTable & ".ID"
strSQL = "Select MAX(" & ColRef & ") FROM " & XTable & ";"
ThisWorkbook.Sheets("Start").Range("a30") = strSQL
Set rs = cn.Execute(strSQL)
X_ID = rs.Fields(0)
rs.Close
strSQL = "Select * FROM " & XTable & " WHERE ID = " & X_ID

rs.Open strSQL, cn, adOpenKeyset, adLockOptimistic
rs.AddNew
For idx = 2 To UBound(NewData, 2)
rs(idx - 1) = NewData(rdx, idx)
Next idx
rs.Update
rs.Close
CloseDB
End Sub

Sub DataFromDB(DBTable)
strSQL = "SELECT * FROM " & DBTable & ";"
OpenDB
CurrentDData = GetData(strSQL)

CloseDB
End Sub
Sub UpdateRecord(NewDData, DBTable, rx)
Dim rs As New ADODB.Recordset
X_ID = NewDData(rx, 1)

strSQL = "Select * FROM " & DBTable & " WHERE ID = " & X_ID & " ;"
OpenDB
rs.Open strSQL, cn, adOpenKeyset, adLockOptimistic

For idx = 2 To UBound(NewDData, 2)
rs(idx - 1) = NewDData(rx, idx)
Next idx
rs.Update
rs.Close
CloseDB
End Sub

Sub OpenLink()
Dim fso As New Scripting.FileSystemObject
SR = "\\15.76.94.164\cdfmanagement$"
'If fso.DriveExists(SR) = True Then Exit Sub
hh = fso.GetDriveName(SR)
SL = ""
SU = "CDFUser"
SP = "UserAccess124!"
SR = "\\15.76.94.164\cdfmanagement$"
'admin is Password1

Set objNetwork = CreateObject("WScript.Network")
objNetwork.MapNetworkDrive SL, SR, False, SU, SP
Set objNetwork = Nothing
End Sub

Sub CloseLink()
Dim fso As New Scripting.FileSystemObject
'removes the link to the shared folder
'SR = "\\15.76.94.164\cdfmanagement$"

Set objNetwork = CreateObject("WScript.Network")
Set NN = objNetwork.EnumNetworkDrives

If NN.Length > 0 Then
objNetwork.RemoveNetworkDrive SR, True
End If
SR = ""

End Sub

Sub Checkexists()
Dim fso As New Scripting.FileSystemObject
strURL = "\\15.76.94.164\cdfmanagement$"

'Check to see if the file share exists!
If fso.DriveExists(strURL) = True Then
'The file exists!
FileExists = True
MsgBox "Exists"
Else
MsgBox " No Connections"

End If
End Sub

Sub SaveFile(fname, fileref)
Dim fso As New Scripting.FileSystemObject
OpenLink
Newfname = SR & "\CDF_Documents\" & fileref
fso.CopyFile fname, Newfname
CloseLink
End Sub

Sub testsavefile()
fname = "C:\Users\davidge\Documents\CDF Process\Payment\Kates Invoices_Oct16\Invoices_Oct16\VA16A70770 - P1Q316-SYN-1438.pdf"
fileref = "P1Q316-SYN-1438v2.pdf"
SaveFile fname, fileref
End Sub

Function DoParamQuery(QName, PRef)
Dim rs As New ADODB.Recordset
Dim Cmd As New ADODB.Command
Dim PP As New ADODB.Parameter
Dim a(0, 0)
Dim TT()
DoParamQuery = a

OpenDB
' Set Command reference to the stored procedure name.
Cmd.ActiveConnection = cn
Cmd.CommandText = QName '"Param_PL_by_Month"
Cmd.CommandType = adCmdStoredProc
Cmd.Parameters.Refresh

Set PP = Cmd.CreateParameter("RAM", adVarChar, adParamInput, 255, PRef)
Cmd.Parameters.Append PP

Set rs = Cmd.Execute

If rs.EOF Then Exit Function
Xdata = rs.GetRows
Xcols = UBound(Xdata)
Xrows = UBound(Xdata, 2)
ReDim TT(Xrows + 1, Xcols)
For rdx = 0 To Xrows
For cdx = 0 To Xcols
TT(rdx + 1, cdx) = Xdata(cdx, rdx)
Next cdx
Next rdx

With rs
For cdx = 0 To .Fields.Count - 1
TT(0, cdx) = .Fields(cdx).Name
Next cdx

End With

rs.Close

CloseDB
DoParamQuery = TT
End Function