Global g_sConnectionString As String
' Declares for INI Get & Put commands
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal grpnm As Any, ByVal parnm As Any, ByVal deflt As String, ByVal parvl As String, ByVal parlen As Long, ByVal INIPath As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal grpnm As String, ByVal parnm As Any, ByVal parvl As Any, ByVal INIPath As String) As Long
Public Function GetINI(ByVal sINIFile As String, ByVal sSection As String, ByVal sKey As String, ByVal sDefault As String) As String
' Declare local variables
Dim lCode As Long
Dim sBuff As String * 4096
If sINIFile = "" Or sSection = "" Or sKey = "" Then
GetINI = ""
Exit Function
End If
' Call API routine - length of result is returned in lRCLength
lCode = GetPrivateProfileString(sSection, sKey, sDefault, sBuff, Len(sBuff), sINIFile)
' Trim of the excess and return the rest in GetValue
GetINI = Left$(sBuff, lCode)
End Function
Function FileExists(ByVal sFileName As String) As Boolean
On Error GoTo Deverr:
If sFileName = "" Then
FileExists = False
Exit Function
End If
FileExists = (Dir(sFileName, 0) <> "")
FileExists = (Dir(sFileName, vbHidden) <> "")
Exit Function
Deverr:
FileExists = False
Exit Function
End Function
Public Function PutINI(ByVal sINIFile As String, ByVal sSection As String, ByVal sKey As String, ByVal sValue As String) As Boolean
Dim lCode As Long
PutINI = False
If sINIFile = "" Or sSection = "" Or sKey = "" Then
Exit Function
End If
' Call API routine - lRCResult will be non-zero if succesful
lCode = WritePrivateProfileString(sSection, sKey, sValue, sINIFile)
If lCode <> 0 Then
PutINI = True
End If
End Function
Function GetConnectionString() As Boolean
Dim sINI As String
sINI = "\\blah\blah\blah.INI"
g_sConnectionString = GetINI(sINI, "Reports", "ConnectionString", "")
If g_sConnectionString = "" Then
MsgBox "ERROR - Could not connect to reports data", vbExclamation, "Get Data"
GetConnectionString = False
Exit Function
End If
GetConnectionString = True
End Function
Sub cmdRefresh()
If GetConnectionString = False Then
Exit Sub
End If
Dim oWorkbook As Workbook
Dim oWorksheet As Worksheet
Dim oRange As Range
Dim oRS As ADODB.Recordset
Set oWorkbook = ActiveWorkbook
' Get SQL String
Set oWorksheet = oWorkbook.Worksheets("SQL")
Set oRange = oWorksheet.Range("A1")
Dim sSQL As String
sSQL = Trim(oRange.Value)
On Error Resume Next
Set oRS = modMain.GetSQLData(sSQL)
If Err <> 0 Then
MsgBox "Problem retrieving data : " & Err.Description, vbExclamation, "Get Data"
Exit Sub
End If
On Error GoTo 0
Set oWorksheet = oWorkbook.Worksheets("Data")
Set oRange = oWorksheet.Range("B1")
Dim vArr As Variant
vArr = oRS.GetRows()
oRange.Resize(UBound(vArr, 1), UBound(vArr, 2)).Value = vArr
oRS.Close
Set oWorksheet = oWorkbook.Worksheets("Summary")
Dim oPT As PivotTable
For Each oPT In oWorksheet.PivotTables
oPT.RefreshTable
Next
End Sub
Function GetSQLData(ByVal sSQL As String) As ADODB.Recordset
Dim oConn As New ADODB.Connection
Dim oRSOut As ADODB.Recordset
If sSQL = "" Then
Exit Function
End If
On Error Resume Next
With oConn
.CursorLocation = adUseClient 'suspect
.Open g_sConnectionString
.CommandTimeout = 0
Set oRSOut = .Execute(sSQL)
End With
If Err <> 0 Then
Exit Function
End If
On Error GoTo 0
Set GetSQLData = oRSOut
Set oRSOut = Nothing
Set oConn = Nothing
End Function