' In Visual Basic IDE > Tools > References... checkmark the following: ' Visual Basic for Applications, Microsoft Excel 16.0 Object Library, OLE Automation, Microsoft Office 16.0 Object Library, ' Microsoft Forms 2.0 Object Library, Microsoft Scripting Runtime ' Find all "Code Location" directions in each .txt file: ' Code Location: In Workbook Modules "Module1" '------------------------------------------------------------------------------- ' Checkmark the following References in Visual Basic IDE > Tools > References... ' Visual Basic for Applications, Microsoft Excel 16.0 Object Library, OLE Automation, Microsoft Office 16.0 Object Library, ' Microsoft Forms 2.0 Object Library, Microsoft Scripting Runtime Option Explicit Public thisWorksheet As Worksheet Public myWorkbook As Workbook Public onlyOne As Boolean Private myFileSystemObject As New FileSystemObject Enum xlCmdType xlCmdCube = 1 ' = 1 xlCmdSql ' = 2 xlCmdTable ' = 3 xlCmdDefault ' = 4 xlCmdList ' = 5 xlCmdTableCollection ' = 6 xlCmdExcel ' = 7 xlCmdDAX ' = 8 End Enum Public Sub updatePivot() Dim oPivot Dim thisPivot As PivotTable On Error Resume Next For Each oPivot In thisWorksheet.PivotTables Set thisPivot = oPivot thisPivot.PivotCache.Refresh thisWorksheet.PageSetup.PrintArea = thisPivot.DataBodyRange.Address thisPivot.PrintTitles = True FitRows thisPivot:=thisPivot Next oPivot On Error GoTo 0 End Sub ' Inserts strSourceTarget into strInitialString, between left delimiter: dataSourceDelim and right delimiter: rightDelim ' strReplaceString2 looks for two alternative right delimiters and if found picks the leftmost of the two. The second check is ignored if rightDelim2 is "*". ' If no change is made to strInitialString, then the function returns the value of strInitialString so changes can be "chained". Private Function strReplaceString2(ByVal dataSourceDelim As String, ByVal rightDelim As String, ByVal rightDelim2 As String, ByVal strInitialString As String, ByVal strSourceTarget As String) As String 'Copyright (c) 2020 Richard M. Bixler, All Rights Reserved. Do not delete this copyright notice. Dim makeDataSource As String, strStringToReplace As String, useDelim As String Dim currentLeftDelim As Integer, currentRightDelim As Integer, currentRightDelim2 As Integer, useDelimEnd As Integer strReplaceString2 = strInitialString ' Default. Changes made based on conditionals below. If no changes are made to strInitialString, return strInitialString. makeDataSource = "" currentLeftDelim = InStr(1, strInitialString, dataSourceDelim, vbTextCompare) ' Find start of string to replace within strConnectionString If currentLeftDelim > 0 Then ' If dataSourceDelim is in strInitialString, go on to find rightDelim and rightDelim2 ' Now find end of string to replace within strConnectionString. This finds start char of right delimiter strings currentRightDelim = InStr(currentLeftDelim + Len(dataSourceDelim), strInitialString, rightDelim, vbTextCompare) currentRightDelim2 = InStr(currentLeftDelim + Len(dataSourceDelim), strInitialString, rightDelim2, vbTextCompare) ' Assume we will use rightDelim... If currentRightDelim > 0 Then useDelim = rightDelim useDelimEnd = currentRightDelim + Len(useDelim) - 1 ' Correct currentRightDelim validity check to reflect end-of-string including rightDelim string. makeDataSource = dataSourceDelim & strSourceTarget & useDelim ' Create make-string containing new value End If ' ...But if rightDelim is not "Ignore", then if rightDelim was NOT found, or if it was found but rightDelim2 occurs before rightDelim, use rightDelim2 If rightDelim2 <> "*" Then If (currentRightDelim < 1 Or currentRightDelim2 < currentRightDelim) Then useDelim = rightDelim2 useDelimEnd = currentRightDelim2 + Len(useDelim) - 1 ' Correct currentRightDelim2 validity check to reflect end-of-string including rightDelim2 string. makeDataSource = dataSourceDelim & strSourceTarget & useDelim End If End If ' If all conditions: leftDelim is found, rightDelim is found and chosen, and if string to be replaced is within strInitialString, the make the replacement If makeDataSource <> "" Then ' If valid delimiter found, update strInitialString to return changes strStringToReplace = Mid(strInitialString, currentLeftDelim, useDelimEnd - currentLeftDelim + 1) ' Capture current-string to replaced within strConnectionString If InStr(1, strInitialString, strStringToReplace, vbTextCompare) > 0 Then ' Check if we found the string to replace strReplaceString2 = Replace(strInitialString, strStringToReplace, makeDataSource, 1, -1, vbTextCompare) ' Match current-string within strConnectionString and replace by make-string End If End If End If End Function Public Sub updateConnections(ByVal whichButton As String) 'Copyright (c) 2020 Richard M. Bixler, All Rights Reserved. Do not delete this copyright notice. 'Updates Connections and Queries, to definitions defined in table on DataSources tab. Dim connectionSheet As Worksheet Dim tblConnectionConfig As ListObject Dim thisListRow As ListRow Dim thisConnection As WorkbookConnection Dim strConnectionName As String, strAltPath As String, strPrimaryPath As String, strTableName As String, strLinkType As String, strSQL As String, wkstnIDStringExisting As String, wkstnIDStringNew As String, leftDelim As String, leftIDdelim As String Dim thisConnectionRowFound As Boolean Dim thisCell As Range, rngHeaderRow As Range Dim nameIndex As Integer, altPathIndex As Integer, priPathIndex As Integer, tableNameIndex As Integer, linkTypeIndex As Integer, sqlIndex As Integer, intErrDescription As Integer Dim thisListObject As ListObject Dim thisListObjectObject As Variant, thisSheetObject As Variant, objectRow As Variant Dim thisSheet As Worksheet Dim thisQuery As QueryTable Dim thisConnectionString As String, dataSourceStringExisting As String, strPathSymbol As String, strThisWorkbookPath As String, strTargetFileName As String Dim oldPath As String, dataSourceStringNew As String, dataSourceFileName As String Dim dbSourceFile As String, dbTableSheet As String, sDatabase As String, dbTable As String, sSQL As String Dim leftChar As Long, rightChar As Long, rightChar2 As Long Dim thisRow As Range Dim fsFileSystem As New FileSystemObject Dim thisPivotObject As Variant Dim thisPivot As PivotTable Dim thisPivotCache As PivotCache Dim thisWorkbook As Workbook Dim thisWBQuery As WorkbookQuery Dim newFormula As String Dim cHeaderCollection As New Collection Dim iCellIndex As Integer Dim strDescription As String, strProvider As String, strConnectionString As String, strConnectionType As String Dim strCommandType As String, strCommandText As String, strAlternatePath As String, strComputerName As String, strMode As String Dim strSQLInstance As String, strServerName As String, strDatabase As String, strSourceTarget As String, strWorkstation As String, strTest As String, strNewString As String Dim boolEnableRefresh As Boolean, boolRefreshAll As Boolean, boolRefreshOnOpen As Boolean, boolBackgroundQuery As Boolean Dim boolMaintainConnection As Boolean Dim intRefreshPeriod As Integer Dim lCmdType As xlCmdType Dim makeDataSource As String, makeWorkstationID As String, makeInitialCatalog As String, dataSourceDelim As String, WorkstationIDDelim As String, InitialCatalogDelim As String Dim currentDataSource As String, currentWorkstationID As String, currentInitialCatalog As String, strSkipBuildUpdate As String, strErrorMessage As String, strAction As String Dim strStringToReplace As String, strProviderCase As String, strProviderTemplate As String Dim currentLeftDelim As Integer, currentRightDelim As Integer, intErrNum As Integer, iConnectionIndex As Integer, iMatchTypeExact As Integer, iCurLeft As Integer, iCurRight As Integer Dim colxlCmdType As New Collection, colConnectionList As New Collection, colWBQueryList As New Collection, colPivotCache As New Collection Dim localErrObject As ErrObject leftDelim = ";Data Source=" leftIDdelim = ";Workstation ID=" If Module1.myWorkbook Is Nothing Then Set Module1.myWorkbook = ActiveWorkbook Set thisWorkbook = Module1.myWorkbook ' Set myWorkbook = thisWorkbook strThisWorkbookPath = thisWorkbook.Path Set connectionSheet = thisWorkbook.Worksheets("DataSources") Set tblConnectionConfig = connectionSheet.ListObjects("tblConnectionConfig") Set rngHeaderRow = tblConnectionConfig.HeaderRowRange iMatchTypeExact = 0 intErrDescription = 45 Set localErrObject = Err ' ******************* Expand this object in Locals to see Err properties when debugging. colxlCmdType.Add Item:=1, Key:="xlcmdcube" colxlCmdType.Add Item:=2, Key:="xlcmdsql" colxlCmdType.Add Item:=3, Key:="xlcmdtable" colxlCmdType.Add Item:=4, Key:="xlcmddefault" colxlCmdType.Add Item:=5, Key:="xlcmdlist" colxlCmdType.Add Item:=6, Key:="xlcmdtablecollection" colxlCmdType.Add Item:=7, Key:="xlcmdexcel" colxlCmdType.Add Item:=8, Key:="xlcmddax" ' Clear out collection of header names prior to populating For iCellIndex = cHeaderCollection.Count To 1 Step -1 cHeaderCollection.Remove iCellIndex Next iCellIndex ' Then populate the collection of header names For iCellIndex = 1 To tblConnectionConfig.HeaderRowRange.Count cHeaderCollection.Add Item:=iCellIndex, Key:=tblConnectionConfig.HeaderRowRange.Cells(iCellIndex) Next iCellIndex ' Clear out collection of defined connections For iConnectionIndex = colConnectionList.Count To 1 Step -1 colConnectionList.Remove iConnectionIndex Next iConnectionIndex ' ... and collection of defined WBQuerys For iConnectionIndex = colWBQueryList.Count To 1 Step -1 colWBQueryList.Remove iConnectionIndex Next iConnectionIndex ' Connections Where-used For iConnectionIndex = colPivotCache.Count To 1 Step -1 colPivotCache.Remove iConnectionIndex Next iConnectionIndex For Each thisPivotCache In thisWorkbook.PivotCaches colPivotCache.Add Item:=thisPivotCache.WorkbookConnection.Name, Key:=thisPivotCache.WorkbookConnection.Name Next thisPivotCache strErrorMessage = "" ' Clear error message string. Each connection will add an entry if an error occurs at any stage. For Each thisListRow In tblConnectionConfig.ListRows ' Get Config Parameter Values from tblConnectionConfig ' ' Demonstrating syntax using MATCH instead of cHeaderCollection construct ' If WorksheetFunction.Match("BackgroundQuery", rngHeaderRow, iMatchTypeExact) > 0 Then boolBackgroundQuery = CBool(thisListRow.Range.Cells(WorksheetFunction.Match("BackgroundQuery", rngHeaderRow, iMatchTypeExact))) Else nameIndex = False ' If WorksheetFunction.Match("Alternate Path", rngHeaderRow, iMatchTypeExact) > 0 Then strAlternatePath = thisListRow.Range.Cells(WorksheetFunction.Match("Alternate Path", rngHeaderRow, iMatchTypeExact)) Else strAlternatePath = "" ' MATCH is more complicated than cHeaderCollection so used that... If boolExists("BackgroundQuery", cHeaderCollection) Then boolBackgroundQuery = CBool(thisListRow.Range.Cells(cHeaderCollection.Item("BackgroundQuery"))) Else boolBackgroundQuery = False If boolExists("Alternate Path", cHeaderCollection) Then strAlternatePath = thisListRow.Range.Cells(cHeaderCollection.Item("Alternate Path")) Else strAlternatePath = "" If boolExists("CommandText", cHeaderCollection) Then strCommandText = thisListRow.Range.Cells(cHeaderCollection.Item("CommandText")) Else strCommandText = "" If boolExists("ComputerName", cHeaderCollection) Then strComputerName = thisListRow.Range.Cells(cHeaderCollection.Item("ComputerName")) Else strComputerName = "" If boolExists("CommandType", cHeaderCollection) Then strCommandType = thisListRow.Range.Cells(cHeaderCollection.Item("CommandType")) Else strCommandType = "" If boolExists("ConnectionName", cHeaderCollection) Then strConnectionName = thisListRow.Range.Cells(cHeaderCollection.Item("ConnectionName")) Else strConnectionName = "" If boolExists("ConnectionString", cHeaderCollection) Then strConnectionString = thisListRow.Range.Cells(cHeaderCollection.Item("ConnectionString")) Else strConnectionString = "" If boolExists("ConnectionType", cHeaderCollection) Then strConnectionType = thisListRow.Range.Cells(cHeaderCollection.Item("ConnectionType")) Else strConnectionType = "" If boolExists("Database", cHeaderCollection) Then strDatabase = thisListRow.Range.Cells(cHeaderCollection.Item("Database")) Else strDatabase = "" If boolExists("Description", cHeaderCollection) Then strDescription = thisListRow.Range.Cells(cHeaderCollection.Item("Description")) Else strDescription = "" If boolExists("LinkType", cHeaderCollection) Then strLinkType = thisListRow.Range.Cells(cHeaderCollection.Item("LinkType")) Else strLinkType = "" If boolExists("MaintainConnection", cHeaderCollection) Then boolMaintainConnection = CBool(thisListRow.Range.Cells(cHeaderCollection.Item("MaintainConnection"))) Else boolMaintainConnection = False If boolExists("Mode", cHeaderCollection) Then strMode = thisListRow.Range.Cells(cHeaderCollection.Item("Mode")) Else strMode = "" If boolExists("Primary Path", cHeaderCollection) Then strPrimaryPath = thisListRow.Range.Cells(cHeaderCollection.Item("Primary Path")) Else strPrimaryPath = "" If boolExists("Provider", cHeaderCollection) Then strProvider = thisListRow.Range.Cells(cHeaderCollection.Item("Provider")) Else strProvider = "" If boolExists("RefreshAll", cHeaderCollection) Then boolRefreshAll = CBool(thisListRow.Range.Cells(cHeaderCollection.Item("RefreshAll"))) Else boolRefreshAll = False If boolExists("EnableRefresh", cHeaderCollection) Then boolEnableRefresh = CBool(thisListRow.Range.Cells(cHeaderCollection.Item("EnableRefresh"))) Else boolEnableRefresh = True If boolExists("RefreshOnOpen", cHeaderCollection) Then boolRefreshOnOpen = CBool(thisListRow.Range.Cells(cHeaderCollection.Item("RefreshOnOpen"))) Else boolRefreshOnOpen = False If boolExists("RefreshPeriod", cHeaderCollection) Then intRefreshPeriod = CInt(thisListRow.Range.Cells(cHeaderCollection.Item("RefreshPeriod"))) Else intRefreshPeriod = 0 If boolExists("ServerName", cHeaderCollection) Then strServerName = thisListRow.Range.Cells(cHeaderCollection.Item("ServerName")) Else strServerName = "" If boolExists("SQLInstance", cHeaderCollection) Then strSQLInstance = thisListRow.Range.Cells(cHeaderCollection.Item("SQLInstance")) Else strSQLInstance = "" If boolExists("Table Name", cHeaderCollection) Then strTableName = thisListRow.Range.Cells(cHeaderCollection.Item("Table Name")) Else strTableName = "" If boolExists("Workstation", cHeaderCollection) Then strWorkstation = thisListRow.Range.Cells(cHeaderCollection.Item("Workstation")) Else strWorkstation = "" If boolExists("SkipBuildUpdate", cHeaderCollection) Then strSkipBuildUpdate = thisListRow.Range.Cells(cHeaderCollection.Item("SkipBuildUpdate")) Else strSkipBuildUpdate = "" Application.StatusBar = strConnectionName ' Fix up parameters common to Connections and QUERYs ' strProviderCase#strProviderTemplate is a fully-qualified strProvider name. ' strProviderCase by itself can specify a Template, or a non-Templated provider. ' Substitution in strConnectionString for Provider strProviderCase will occur ' if and only strProviderCase matches a Template name. ' strProviderCase#strProviderTemplate specifies template for substitution. ' Substitution in strConnectionString for Provider strProviderCase#strProviderTemplate will occur ' if and only if strProviderTemplate matches a Template name. ' Templates are ' OleDb_DataSource Matches M Procedure ' Excel_Workbook Matches M Procedure ' Sql_Database Matches M Procedure ' Access_Database Matches M Procedure ' Table_Join Matches M Procedure ' Microsoft.ACE.OLEDB.12.0 Matches Connection Provider ' Microsoft.ACE.OLEDB.16.0 Matches Connection Provider ' MSOLEDBSQL Matches Connection Provider ' SQLOLDEB Matches Connection Provider If InStr(1, LCase(strProvider), "#", vbTextCompare) > 0 Then strProviderTemplate = LCase(Right(strProvider, Len(strProvider) - (InStr(1, LCase(strProvider), "#", vbTextCompare) - 1))) If Len(strProvider) > Len(strProviderTemplate) Then strProviderCase = LCase(Left(strProvider, Len(strProvider) - (Len(strProviderTemplate) + 1))) Else strProviderCase = strProviderTemplate End If Else strProviderTemplate = strProvider strProviderCase = strProvider End If ' Choose and validate filename for ACE provider; and for aliased PowerQuery If (InStr(1, LCase(strProviderTemplate), "ace", vbTextCompare) > 0) _ Or (LCase(strProviderTemplate) = "#excel_workbook") _ Or (LCase(strProviderTemplate) = "#excel_workbookpromoted") _ Or (LCase(strProviderTemplate) = "#table_join") _ Or (LCase(strProviderTemplate) = "#access_database") Then ' ******For ACE, PowerQueryExcel, or PowerQueryMSAccess, data source is a filename strAction = "Source Target" sDatabase = strEvalPath(strPrimaryPath, thisWorkbook, "path") If sDatabase = "" Then sDatabase = strEvalPath(strAlternatePath, thisWorkbook, "path") ' Choose primary or alternate path If myFileSystemObject.FileExists(sDatabase) Then 'Validate the file strSourceTarget = sDatabase Else If strErrorMessage <> "" Then strErrorMessage = strErrorMessage & Chr(32) & Chr(10) & Chr(10) strErrorMessage = strErrorMessage & strConnectionName & ", " & strAction & ", File does not exist: " & sDatabase & ", Set ""Skip"" if not used." strSkipBuildUpdate = "Skip" ' Skip further action for this connection End If Else strSourceTarget = strServerName ' for MSOLEDBSQL or SQLOLEDB, source is database instance on server End If ' lCmdType: Determine the value of the xlCmdType from enumeration, passed in by name string from tblConnectionConfig If boolExists(LCase(strCommandType), colxlCmdType) Then lCmdType = colxlCmdType(LCase(strCommandType)) Else lCmdType = xlCmdSql 'colxlCmdType(LCase("xlCmdSql")) ' strCommandText: Fix up default SQL If strCommandText = "-" Then strCommandText = "SELECT * FROM " & strTableName & ";" ' DATA CONNECTIONS If LCase(strLinkType) = "pivotsource" Or LCase(strLinkType) = "mppimport" Then ' Record each connection defined in tblConnectionConfig, into colConnectionList. This will be used to determine existing Connections that are NOT defined in tblConnectionConfig. Those will be deleted. colConnectionList.Add Item:=strConnectionName, Key:=strConnectionName If LCase(strSkipBuildUpdate) <> "skip" Then ' Skip Build and Update on strSkipBuildUpdate ' Create or update PivotSource or mppImport Connections If (whichButton = "RebuildRefreshPivotSourceWebQuery" And LCase(strLinkType) = "pivotsource") _ Or (whichButton = "RebuildRefreshMPPImportMPPQuery" And LCase(strLinkType) = "mppimport") Then ' strConnectionString: Make replacements for Connection String Select Case LCase(strProviderTemplate) Case "#microsoft.ace.oledb.12.0", "#microsoft.ace.oledb.16.0", "#msoledbsql", "#sqloledb" strConnectionString = strReplaceString2("Data Source=", ";", "*", strConnectionString, strSourceTarget) ' Replace Data Source strConnectionString = strReplaceString2("Workstation ID=", ";", "*", strConnectionString, strWorkstation) ' Replace Workstation ID strConnectionString = strReplaceString2("Initial Catalog=", ";", "*", strConnectionString, strDatabase) ' Replace Initial Catalog strConnectionString = strReplaceString2("Mode=", ";", "*", strConnectionString, strMode) 'Replace ACE Read Write Mode End Select If Not boolExists(strConnectionName, thisWorkbook.Connections) Then ' If connection(strConnectionName) NOT PRE-EXISTING, create it with parameters required for creation strAction = "Create" Application.StatusBar = strConnectionName & " - " & strAction Err.Clear localErrObject.Clear On Error Resume Next Set thisConnection = thisWorkbook.Connections.Add2(strConnectionName, strDescription, strConnectionString, strCommandText, lCmdType) intErrNum = Err.Number If intErrNum <> 0 Then If strErrorMessage <> "" Then strErrorMessage = strErrorMessage & Chr(32) & Chr(10) & Chr(10) strErrorMessage = strErrorMessage & strConnectionName & ", " & strAction & ", Error " & CStr(intErrNum) & ", " & Left(Err.Description, intErrDescription) _ & ", " & Err.HelpContext & ", " & Err.HelpFile & ", Set ""Skip"" if not used." strSkipBuildUpdate = "Skip" ' Skip further action for this connection End If ' intErrNum Else ' Not Exists Check 'If connection(strConnectionName) IS PRE-EXISTING, update its params required for creation so that it's in state equivalent to a newly-created connection strAction = "Update" Err.Clear On Error Resume Next Set thisConnection = thisWorkbook.Connections(strConnectionName) If thisConnection.OLEDBConnection.Refreshing Then thisConnection.OLEDBConnection.CancelRefresh ' Turn off ongoing activity if any - it will refresh later thisConnection.Description = strDescription If (thisConnection.Type = xlConnectionTypeOLEDB And strConnectionType = "xlConnectionTypeOLEDB") Then Application.StatusBar = strConnectionName & " - " & strAction ' strConnectionString: Make replacements for Connection String ' For Update, Update the existing string If strSkipBuildUpdate = "Update" Then strConnectionString = thisConnection.OLEDBConnection.Connection ' if Update, start with pre-existing string in connection; else start from template Select Case LCase(strProviderTemplate) Case "#microsoft.ace.oledb.12.0", "#microsoft.ace.oledb.16.0", "#msoledbsql", "#sqloledb" strConnectionString = strReplaceString2("Data Source=", ";", "*", strConnectionString, strSourceTarget) ' Replace Data Source strConnectionString = strReplaceString2("Workstation ID=", ";", "*", strConnectionString, strWorkstation) ' Replace Workstation ID strConnectionString = strReplaceString2("Initial Catalog=", ";", "*", strConnectionString, strDatabase) ' Replace Initial Catalog strConnectionString = strReplaceString2("Mode=", ";", "*", strConnectionString, strMode) 'Replace ACE Read Write Mode End Select ' Update the other strings involved in creation of a new connection thisConnection.OLEDBConnection.Connection = strConnectionString thisConnection.OLEDBConnection.CommandText = strCommandText thisConnection.OLEDBConnection.CommandType = lCmdType End If ' Button Check intErrNum = Err.Number If intErrNum <> 0 Then If strErrorMessage <> "" Then strErrorMessage = strErrorMessage & Chr(32) & Chr(10) & Chr(10) strErrorMessage = strErrorMessage & strConnectionName & ", " & strAction & ", Error " & CStr(intErrNum) & ", " & Left(Err.Description, intErrDescription) _ & ", " & Err.HelpContext & ", " & Err.HelpFile & ", Set ""Skip"" if not used." strSkipBuildUpdate = "Skip" ' Skip further action for this connection End If ' intErrNum End If ' Exists or Not Exists ' When Connection defined in tblConnectionConfig exists, either pre-existing or just created, update its params beyond creation-required params If boolExists(thisConnection.Name, thisWorkbook.Connections) Then ' Check connection exists If (thisConnection.Type = xlConnectionTypeOLEDB And strConnectionType = "xlConnectionTypeOLEDB") Then strAction = "Params" Application.StatusBar = strConnectionName & " - " & strAction Err.Clear On Error Resume Next If thisConnection.OLEDBConnection.Refreshing Then thisConnection.OLEDBConnection.CancelRefresh ' Turn off ongoing activity if any - it will refresh later thisConnection.OLEDBConnection.BackgroundQuery = boolBackgroundQuery thisConnection.OLEDBConnection.MaintainConnection = boolMaintainConnection thisConnection.OLEDBConnection.RefreshOnFileOpen = boolRefreshOnOpen thisConnection.OLEDBConnection.RefreshPeriod = intRefreshPeriod intErrNum = Err.Number If intErrNum <> 0 Then If strErrorMessage <> "" Then strErrorMessage = strErrorMessage & Chr(32) & Chr(10) & Chr(10) strErrorMessage = strErrorMessage & strConnectionName & ", " & strAction & ", Error " & CStr(intErrNum) & ", " & Left(Err.Description, intErrDescription) _ & ", " & Err.HelpContext & ", " & Err.HelpFile & ", Set ""Skip"" if not used." strSkipBuildUpdate = "Skip" ' Skip further action for this connection End If ' intErrNum End If ' Button check End If ' Connection Exists End If ' Button check End If ' end strSkipBuildUpdate ' Refresh Connection after build / update. strSkipBuildUpdate does NOT affect Refresh. ' For button RebuildRefreshPivotSourceWebQuery or RefreshPivotSourceWebQuery, refresh PivotSource ' For button RebuildRefreshMPPImportMPPQuery, refresh mppImport If LCase(strSkipBuildUpdate) <> "skip" Then ' Skip Build and Update on strSkipBuildUpdate If boolExists(strConnectionName, thisWorkbook.Connections) Then Set thisConnection = thisWorkbook.Connections(strConnectionName) If boolExists(thisConnection.Name, colPivotCache) Then ' Check that Connection exists AND can drive a Pivot DoEvents ' Allow any pending Refresh or other events to complete, to avoid errors due to changing parameters. thisConnection.RefreshWithRefreshAll = boolRefreshAll ' If exists and associated to Pivot, set its Refresh-related parameters ' Enable Refresh; this may cause error, reason unknown If thisConnection.OLEDBConnection.EnableRefresh <> boolEnableRefresh Then thisConnection.OLEDBConnection.EnableRefresh = boolEnableRefresh strAction = "Refresh" Application.StatusBar = strConnectionName & " - " & strAction Err.Clear On Error Resume Next If Not thisConnection.OLEDBConnection.Refreshing Then ' If it's already refreshing then skip it, else refresh depending on buttons If (whichButton = "RebuildRefreshPivotSourceWebQuery" And LCase(strLinkType) = "pivotsource") _ Or (whichButton = "RebuildRefreshMPPImportMPPQuery" And LCase(strLinkType) = "mppimport") _ Or (whichButton = "RefreshPivotSourceWebQuery" And LCase(strLinkType) = "pivotsource") _ Or (whichButton = "RefreshMPPImportMPPQuery" And LCase(strLinkType) = "mppimport") _ Then thisConnection.OLEDBConnection.Refresh End If ' Refreshing DoEvents intErrNum = Err.Number If intErrNum <> 0 Then If strErrorMessage <> "" Then strErrorMessage = strErrorMessage & Chr(32) & Chr(10) & Chr(10) strErrorMessage = strErrorMessage & strConnectionName & ", " & strAction & ", Error " & CStr(intErrNum) & ", " & Left(Err.Description, intErrDescription) _ & ", " & Err.HelpContext & ", " & Err.HelpFile & ", Set ""Skip"" if not used." strSkipBuildUpdate = "Skip" ' Skip further action for this connection End If ' Error case End If ' In colPivotCache End If ' In thisWorkbook.Connections End If ' SKIP check ' WORKBOOK QUERIES of type "GET DATA > FROM OLEDB" using provider MSOLEDBSQL or SQLOLEDB ElseIf LCase(strLinkType) = "webquery" Or LCase(strLinkType) = "mppquery" Then ' Record each connection defined in tblConnectionConfig, into colConnectionList. This will be used to determine existing Connections that are NOT defined in tblConnectionConfig. Those will be deleted. colWBQueryList.Add Item:=strConnectionName, Key:=strConnectionName ' Put together a newFormula in case a new thisWBQuery is created, and include in it the previously-determined strSourceTarget. If strSourceTarget <> "" And (fsFileSystem.FileExists(filespec:=strSourceTarget) Or strEvalPath(strSourceTarget, thisWorkbook, "pathSymbol") = "") Then ' At this point, strSourceTarget contains correct NEW path. ' For WBQuery, strConnectionString contains a template for newFormula ' So so newFormula is the strConnectionString template, with strSourceTarget and strTableName replaced into the template. strAction = "Connection String" Select Case LCase(strProviderTemplate) Case "#oledb_datasource" strConnectionString = strReplaceString2("provider=", ";", """", strConnectionString, "MSOLEDBSQL") ' Replace strProvider strConnectionString = strReplaceString2("initial catalog=", ";", """", strConnectionString, strDatabase) ' Replace strDatabase strConnectionString = strReplaceString2("data source=", ";", """", strConnectionString, strServerName) ' Replace strServerName strConnectionString = strReplaceString2("Query=""", """", "*", strConnectionString, strCommandText) ' Replace strCommandText strConnectionString = updateQueryTableName(strConnectionString, "_Table =", strTableName) ' If there's a Table name within strConnectionString, replace it by the strTableName parameter. Case "#excel_workbook", "#excel_workbookpromoted" strConnectionString = strReplaceString2("File.Contents(""", """)", "*", strConnectionString, strSourceTarget) strConnectionString = strReplaceString2("Name=""", """", "*", strConnectionString, strTableName) Case "#sql_database" strConnectionString = strReplaceString2("Sql.Database(""", """,", "*", strConnectionString, strServerName) ' Replace strServerName strConnectionString = strReplaceString2("Query=""", """", "*", strConnectionString, strCommandText) ' Replace strCommandText iCurLeft = InStr(1, strConnectionString, ",", vbTextCompare) ' Replacing the Database name is harder because it has no unique delimiter iCurLeft = InStr(iCurLeft, strConnectionString, """", vbTextCompare) + 1 iCurRight = InStr(iCurLeft, strConnectionString, """", vbTextCompare) - 1 strStringToReplace = Mid(strConnectionString, iCurLeft, iCurRight - iCurLeft + 1) ' Capture current-string to replaced within strConnectionString If InStr(1, strConnectionString, strStringToReplace, vbTextCompare) > 0 Then ' Check if we found the string to replace strConnectionString = Replace(strConnectionString, strStringToReplace, strDatabase, 1, -1, vbTextCompare) ' Match current-string within strConnectionString and replace by make-string End If ' String Replacement Case "#access_database" strConnectionString = strReplaceString2("File.Contents(""", """)", "*", strConnectionString, strSourceTarget) strConnectionString = strReplaceString2("Item=""", """", "*", strConnectionString, strTableName) Case "#table_join" strConnectionString = strReplaceString2("File.Contents(""", """)", "*", strConnectionString, strSourceTarget) Case Else ' ' Allow other providercase to pass using strConnectionString passed in, without substitution. Substitution for these is done in tblConnection. ' If strErrorMessage <> "" Then strErrorMessage = strErrorMessage & Chr(32) & Chr(10) & Chr(10) ' strErrorMessage = strErrorMessage & strConnectionName & ", " & strAction & ", Unknown Provider: " & strProvider & ", Set ""Skip"" if not used." ' strSkipBuildUpdate = "Skip" ' Skip further action on this connection End Select Else 'Source file strSourceTarget does not exist If strErrorMessage <> "" Then strErrorMessage = strErrorMessage & Chr(32) & Chr(10) & Chr(10) strErrorMessage = strErrorMessage & strConnectionName & ", " & strAction & ", File does not exist: " & sDatabase & ", Set ""Skip"" if not used." strSkipBuildUpdate = "Skip" ' Don't execute any actions for this connection End If 'fsFileSystem.FileExists If LCase(strSkipBuildUpdate) <> "skip" Then ' Skip Build and Update on strSkipBuildUpdate If (whichButton = "RebuildRefreshPivotSourceWebQuery" And LCase(strLinkType) = "webquery") _ Or (whichButton = "RebuildRefreshMPPImportMPPQuery" And LCase(strLinkType) = "mppquery") Then ' Either access the named existing WBQuery, or create one ' If it does not pre-exist, create it If Not boolExists(strConnectionName, thisWorkbook.Queries) Then ' First check for attempt to Build a PowerQueryExcel and avoid that, otherwise go ahead and build. If LCase(strProvider) <> "powerqueryexcel" Then ' Here's the Build action strAction = "Create" Application.StatusBar = strConnectionName & " - " & strAction Err.Clear On Error Resume Next Set thisWBQuery = thisWorkbook.Queries.Add(strConnectionName, strConnectionString, strDescription) intErrNum = Err.Number 'Check for error on Build and handle it. intErrNum = Err.Number If intErrNum <> 0 Then If strErrorMessage <> "" Then strErrorMessage = strErrorMessage & Chr(32) & Chr(10) & Chr(10) strErrorMessage = strErrorMessage & strConnectionName & ", " & strAction & ", Error " & CStr(intErrNum) & ", " & Left(Err.Description, intErrDescription) _ & ", " & Err.HelpContext & ", " & Err.HelpFile & ", Set ""Skip"" if not used." strSkipBuildUpdate = "Skip" ' Skip further action for this connection End If ' intErrNum ' But if trying to build a PowerQueryExcel connection, give error message instead. Else If strErrorMessage <> "" Then strErrorMessage = strErrorMessage & Chr(32) & Chr(10) & Chr(10) strErrorMessage = strErrorMessage & strConnectionName & ", " & strAction & ", " & "Provider " & strProvider & " is Update Only. Build first using ""Get Data>From File>From Workbook""; or Set ""Skip"" if not used." strSkipBuildUpdate = "Skip" ' Skip further action for this connection End If ' If it pre-exists, update it Else ' Update pre-existing QUERY Connection String and Command Text strAction = "Update" Application.StatusBar = strConnectionName & " - " & strAction Err.Clear On Error Resume Next Set thisWBQuery = thisWorkbook.Queries(strConnectionName) If strSkipBuildUpdate = "Update" Then strConnectionString = thisWBQuery.Formula ' If Update, start with pre-existing string in QUERY, else re-start from template ElseIf LCase(strProvider) = "powerqueryexcel" Then strConnectionString = thisWBQuery.Formula ' For PowerQueryExcel and Build, force Update, start with pre-existing string in QUERY, else re-start from template If strErrorMessage <> "" Then strErrorMessage = strErrorMessage & Chr(32) & Chr(10) & Chr(10) strErrorMessage = strErrorMessage & strConnectionName & ", " & strAction & ", " & "Provider " & strProvider & " is Update Only. Action set to ""Update"". Build first using ""Get Data>From File>From Workbook""; or Set ""Skip"" if not used." End If Select Case LCase(strProviderTemplate) Case "#oledb_datasource" strConnectionString = strReplaceString2("provider=", ";", """", strConnectionString, "MSOLEDBSQL") ' Replace strProvider strConnectionString = strReplaceString2("initial catalog=", ";", """", strConnectionString, strDatabase) ' Replace strDatabase strConnectionString = strReplaceString2("data source=", ";", """", strConnectionString, strServerName) ' Replace strServerName strConnectionString = strReplaceString2("Query=""", """", "*", strConnectionString, strCommandText) ' Replace strCommandText strConnectionString = updateQueryTableName(strConnectionString, "_Table =", strTableName) ' If there's a Table name within strConnectionString, replace it by the strTableName parameter. Case "#excel_workbook", "#excel_workbookpromoted" strConnectionString = strReplaceString2("File.Contents(""", """)", "*", strConnectionString, strSourceTarget) strConnectionString = strReplaceString2("Name=""", """", "*", strConnectionString, strTableName) Case "#sql_database" strConnectionString = strReplaceString2("Sql.Database(""", """,", "*", strConnectionString, strServerName) ' Replace strServerName strConnectionString = strReplaceString2("Query=""", """", "*", strConnectionString, strCommandText) ' Replace strCommandText iCurLeft = InStr(1, strConnectionString, ",", vbTextCompare) ' Replacing the Database name is harder because it has no unique delimiter iCurLeft = InStr(iCurLeft, strConnectionString, """", vbTextCompare) + 1 iCurRight = InStr(iCurLeft, strConnectionString, """", vbTextCompare) - 1 strStringToReplace = Mid(strConnectionString, iCurLeft, iCurRight - iCurLeft + 1) ' Capture current-string to replaced within strConnectionString If InStr(1, strConnectionString, strStringToReplace, vbTextCompare) > 0 Then ' Check if we found the string to replace strConnectionString = Replace(strConnectionString, strStringToReplace, strDatabase, 1, -1, vbTextCompare) ' Match current-string within strConnectionString and replace by make-string End If Case "#access_database" strConnectionString = strReplaceString2("File.Contents(""", """)", "*", strConnectionString, strSourceTarget) strConnectionString = strReplaceString2("Item=""", """", "*", strConnectionString, strTableName) Case "#table_join" strConnectionString = strReplaceString2("File.Contents(""", """)", "*", strConnectionString, strSourceTarget) Case Else ' ' Allow other providercase to pass using strConnectionString passed in, without substitution. Substitution for these is done in tblConnection. ' If strErrorMessage <> "" Then strErrorMessage = strErrorMessage & Chr(32) & Chr(10) & Chr(10) ' strErrorMessage = strErrorMessage & strConnectionName & ", " & strAction & ", Unknown Provider: " & strProvider & ", Set ""Skip"" if not used." ' strSkipBuildUpdate = "Skip" ' Skip further action on this connection End Select thisWBQuery.Formula = strConnectionString thisWBQuery.Description = strDescription intErrNum = Err.Number If intErrNum <> 0 Then If strErrorMessage <> "" Then strErrorMessage = strErrorMessage & Chr(32) & Chr(10) & Chr(10) strErrorMessage = strErrorMessage & strConnectionName & ", " & strAction & ", Error " & CStr(intErrNum) & ", " & Left(Err.Description, intErrDescription) _ & ", " & Err.HelpContext & ", " & Err.HelpFile & ", Set ""Skip"" if not used." strSkipBuildUpdate = "Skip" ' Skip further action for this connection End If End If ' Update common parameters of QUERY Connection If boolExists("Query - " & thisWBQuery.Name, thisWorkbook.Connections) Then strAction = "Params" Application.StatusBar = strConnectionName & " - " & strAction Set thisConnection = thisWorkbook.Connections("Query - " & thisWBQuery.Name) If thisConnection.OLEDBConnection.Refreshing Then thisConnection.OLEDBConnection.CancelRefresh ' Cancel refresh if active thisConnection.RefreshWithRefreshAll = boolRefreshAll If (thisConnection.Type = xlConnectionTypeOLEDB And strConnectionType = "xlConnectionTypeOLEDB") Then Err.Clear On Error Resume Next thisConnection.OLEDBConnection.EnableRefresh = boolEnableRefresh thisConnection.OLEDBConnection.BackgroundQuery = boolBackgroundQuery thisConnection.OLEDBConnection.MaintainConnection = boolMaintainConnection thisConnection.OLEDBConnection.RefreshOnFileOpen = boolRefreshOnOpen thisConnection.OLEDBConnection.RefreshPeriod = intRefreshPeriod intErrNum = Err.Number If intErrNum <> 0 Then If strErrorMessage <> "" Then strErrorMessage = strErrorMessage & Chr(32) & Chr(10) & Chr(10) strErrorMessage = strErrorMessage & strConnectionName & ", " & strAction & ", Error " & CStr(intErrNum) & ", " & Left(Err.Description, intErrDescription) _ & ", " & Err.HelpContext & ", " & Err.HelpFile & ", Set ""Skip"" if not used." strSkipBuildUpdate = "Skip" ' Skip further action for this connection End If End If End If End If ' QUERY button check End If ' end strSkipBuildUpdate ' Refresh QUERY after build / update. strSkipBuildUpdate "skip" does NOT inhibit Refresh. ' For button RebuildRefreshPivotSourceWebQuery or RefreshPivotSourceWebQuery, refresh webQuery ' For button RebuildRefreshMPPImportMPPQuery, refresh mppQuery If boolExists(strConnectionName, thisWorkbook.Queries) Then ' Check if QUERY exists - created or pre-existing strAction = "Refresh" Application.StatusBar = strConnectionName & " - " & strAction If LCase(strSkipBuildUpdate) <> "skip" Then ' Skip Build and Update on strSkipBuildUpdate Set thisWBQuery = thisWorkbook.Queries(strConnectionName) If (whichButton = "RebuildRefreshPivotSourceWebQuery" And LCase(strLinkType) = "webquery") _ Or (whichButton = "RebuildRefreshMPPImportMPPQuery" And LCase(strLinkType) = "mppquery") _ Or (whichButton = "RefreshPivotSourceWebQuery" And LCase(strLinkType) = "webquery") _ Or (whichButton = "RefreshMPPImportMPPQuery" And LCase(strLinkType) = "mppquery") _ Then ' Get the Connection associated with this QUERY, and refresh it Err.Clear On Error Resume Next If boolExists("Query - " & thisWBQuery.Name, thisWorkbook.Connections) Then Set thisConnection = thisWorkbook.Connections("Query - " & thisWBQuery.Name) If Not thisConnection.OLEDBConnection.Refreshing Then ' If it's already refreshing let it go thisConnection.OLEDBConnection.BackgroundQuery = boolBackgroundQuery thisConnection.OLEDBConnection.Refresh End If DoEvents End If ' Refresh Operation intErrNum = Err.Number If intErrNum <> 0 Then If strErrorMessage <> "" Then strErrorMessage = strErrorMessage & Chr(32) & Chr(10) & Chr(10) strErrorMessage = strErrorMessage & strConnectionName & ", " & strAction & ", Error " & CStr(intErrNum) & ", " & Left(Err.Description, intErrDescription) _ & ", " & Err.HelpContext & ", " & Err.HelpFile & ", Set ""Skip"" if not used." strSkipBuildUpdate = "Skip" ' Skip further action for this connection End If End If ' REFRESH Button check End If ' SKIP check End If ' QUERY existence check End If ' PivotSource or MPPimport CONNECTION or QUERY ' Try to release MS Access if it got locked If InStr(1, LCase(strProviderTemplate), "ace", vbTextCompare) > 0 Then strAction = "Release MS Access" Application.StatusBar = strConnectionName & " - " & strAction strSourceTarget = Left(strSourceTarget, Len(strSourceTarget) - Len(".accdb")) & ".laccdb" If myFileSystemObject.FileExists(strSourceTarget) Then ' Won't be able to clear it if someone else locked it Err.Clear On Error Resume Next myFileSystemObject.DeleteFile (strSourceTarget) If Err.Number <> 0 Then If strErrorMessage <> "" Then strErrorMessage = strErrorMessage & Chr(32) & Chr(10) & Chr(10) strErrorMessage = strErrorMessage & strConnectionName & ", " & strAction & ", " & strSourceTarget & ", Error " & CStr(intErrNum) & ", " & Left(Err.Description, intErrDescription) _ & ", " & Err.HelpContext & ", " & Err.HelpFile & ", Attempt re-try." strSkipBuildUpdate = "Skip" ' Skip further action for this connection End If End If End If Next thisListRow ' Once defined connections are handled, delete existing Connections not defined in tblConnectionConfig For Each thisConnection In thisWorkbook.Connections If (whichButton = "RebuildRefreshPivotSourceWebQuery" And LCase(strLinkType) = "pivotsource") _ Or (whichButton = "RebuildRefreshMPPImportMPPQuery" And LCase(strLinkType) = "mppimport") Then ' Connections defined in tblConnectionConfig were saved into colConnectionList ' Delete connection if it's not in colConnectionList, as long as its name doesn't begin with "Query -" If Not boolExists(thisConnection.Name, colConnectionList) Then If Not (Left(thisConnection.Name, 8) = "Query - ") Then strAction = "Delete" Application.StatusBar = strConnectionName & " - " & strAction Err.Clear On Error Resume Next If thisConnection.OLEDBConnection.Refreshing Then thisConnection.OLEDBConnection.CancelRefresh ' Stop refresh before deleting it thisConnection.Delete intErrNum = Err.Number If intErrNum <> 0 Then If strErrorMessage <> "" Then strErrorMessage = strErrorMessage & Chr(32) & Chr(10) & Chr(10) strErrorMessage = strErrorMessage & strConnectionName & ", " & strAction & ", Error " & CStr(intErrNum) & ", " & Left(Err.Description, intErrDescription) _ & ", " & Err.HelpContext & ", " & Err.HelpFile & ", Set ""Skip"" if not used." strSkipBuildUpdate = "Skip" ' Skip further action for this connection End If End If End If End If Next thisConnection ' Once defined QUERYs are handled, delete existing QUERYs not defined in tblConnectionConfig For Each thisWBQuery In thisWorkbook.Queries If (whichButton = "RebuildRefreshPivotSourceWebQuery" And LCase(strLinkType) = "webquery") _ Or (whichButton = "RebuildRefreshMPPImportMPPQuery" And LCase(strLinkType) = "mppquery") Then ' Queries defined in tblConnectionConfig were saved into colWBQueryList If Not boolExists(thisWBQuery.Name, colWBQueryList) Then ' Delete the Connection strAction = "Delete" Application.StatusBar = strConnectionName & " - " & strAction Err.Clear On Error Resume Next thisWorkbook.Connections("Query - " & thisWBQuery.Name).OLEDBConnection.CancelRefresh ' Stop any ongoing refresh before deletin thisWorkbook.Connections("Query - " & thisWBQuery.Name).Delete ' Then delete the associated QUERY If boolExists("Query - " & thisWBQuery.Name, thisWorkbook.Connections) Then thisWBQuery.Delete End If intErrNum = Err.Number If intErrNum <> 0 Then If strErrorMessage <> "" Then strErrorMessage = strErrorMessage & Chr(32) & Chr(10) & Chr(10) strErrorMessage = strErrorMessage & strConnectionName & ", " & strAction & ", Error " & CStr(intErrNum) & ", " & Left(Err.Description, intErrDescription) _ & ", " & Err.HelpContext & ", " & Err.HelpFile & ", Set ""Skip"" if not used." strSkipBuildUpdate = "Skip" ' Skip further action for this connection End If End If End If Next thisWBQuery DoEvents ' Let everything stable out before releasing control. ' Report Errors if any If strErrorMessage <> "" Then MsgBox prompt:=strErrorMessage, Buttons:=vbOKOnly, Title:="Error Report" End If 'Update Queries and Connections, clean up and exit sub Application.StatusBar = "" alignButtons End Sub Public Function updateQueryTableName(ByVal strConnectionString As String, ByVal strFinder As String, ByVal strTableNameNew As String) As String 'Copyright (c) 2020 Richard M. Bixler, All Rights Reserved. Do not delete this copyright notice. Dim strTableNameOld As String, symbolTable As String Dim delimLeft As Integer, delimLeftLeft As Integer updateQueryTableName = strConnectionString strTableNameOld = "" 'Find the name of the Table previously embedded in strConnectionString. Find a unique symbol next to an occurrence of that Table name. delimLeft = InStr(1, strConnectionString, strFinder, vbTextCompare) ' From the delimiter, back up to delimiter preceding embedded Table name, and extract the name between those delimiters. If delimLeft > 0 Then delimLeftLeft = InStrRev(strConnectionString, ",", delimLeft, vbTextCompare) + 2 strTableNameOld = LTrim(Mid(strConnectionString, delimLeftLeft, delimLeft - delimLeftLeft)) End If ' If we found a name in the prescribed manner, replace the old name by the new name and return the value. ' If a name was not found, return the original input string. If strTableNameOld <> "" And strTableNameNew <> "" Then updateQueryTableName = Replace(strConnectionString, strTableNameOld, strTableNameNew, 1, -1, vbTextCompare) End Function Public Function updateQueryName(ByVal strConnectionString As String, ByVal strFinder As String, ByVal strDelimRight As String, ByVal strQueryNameNew As String) As String 'Copyright (c) 2020 Richard M. Bixler, All Rights Reserved. Do not delete this copyright notice. Dim strQueryNameOld As String, symbolTable As String Dim delimLeft As Integer, delimRight As Integer updateQueryName = strConnectionString strQueryNameOld = "" 'Find the name of the Table previously embedded in strConnectionString. Find a unique symbol next to an occurrence of that Table name. delimLeft = InStr(1, strConnectionString, strFinder, vbTextCompare) + Len(strFinder) ' From past the left delimiter, find the right delimiter, and extract the name between those delimiters. If delimLeft > 0 Then delimRight = InStr(delimLeft + Len(strFinder), strConnectionString, strDelimRight, vbTextCompare) - 1 strQueryNameOld = LTrim(Mid(strConnectionString, delimLeft, delimRight - delimLeft + 1)) End If ' If we found a name in the prescribed manner, replace the old name by the new name and return the value. ' If a name was not found, return the original input string. If strQueryNameOld <> "" And strQueryNameNew <> "" Then updateQueryName = Replace(strConnectionString, strQueryNameOld, strQueryNameNew, 1, -1, vbTextCompare) End Function Public Function strEvalPath(ByVal strPathName As String, ByVal thisWorkbook As Workbook, ByVal returnType As String) As String 'Copyright (c) 2012 Richard M. Bixler, All Rights Reserved. Do not delete this copyright notice. Dim strPathSymbol As String, strTargetFileName As String, strThisWorkbookPath As String strTargetFileName = "" strEvalPath = "" strThisWorkbookPath = thisWorkbook.Path If strPathName <> "" Then If Left(strPathName, 2) = ".\" Then strPathSymbol = ".\" strTargetFileName = Right(strPathName, Len(strPathName) - 2) ElseIf Left(strPathName, 2) = "\\" Then strPathSymbol = "\\" ElseIf Left(strPathName, 3) = "..\" Then strPathSymbol = "..\" strTargetFileName = Right(strPathName, Len(strPathName) - 3) Else strPathSymbol = "" strTargetFileName = strPathName End If Select Case strPathSymbol Case "" strEvalPath = strTargetFileName Case ".\" strEvalPath = strThisWorkbookPath & "\" & strTargetFileName Case Else strEvalPath = myFileSystemObject.GetAbsolutePathName(strPathName) End Select If (strPathSymbol <> "" And Not myFileSystemObject.FileExists(strEvalPath)) Then strEvalPath = "" Select Case returnType Case "path" 'return value already set to path Case "pathSymbol" strEvalPath = strPathSymbol Case Else strEvalPath = "" End Select End If 'strPathName is not null End Function Public Function localClient() As String localClient = CreateObject("WScript.Network").ComputerName End Function Public Function localLogin() As String localLogin = environ$("username") ' Windows Login name (use for directory path) End Function Public Function appUser() As String appUser = Application.UserName End Function Public Sub setColWid(ByVal wks As Worksheet) Dim displayWidth As Range, thisPivotRowRange As Range, thisCol As Range Dim thisBook As Workbook Dim thisWidth As Integer Dim thisColName As String Dim saveEvents As Boolean Dim thisPivot As PivotTable saveEvents = Application.EnableEvents Application.EnableEvents = False Set thisBook = Module1.myWorkbook Set displayWidth = thisBook.Worksheets("DataSources").Range("DisplayWidth") Set thisPivot = wks.PivotTables(1) Set thisPivotRowRange = thisPivot.RowRange.Rows(1) For Each thisCol In thisPivotRowRange.Columns On Error Resume Next thisColName = thisCol.Value If Left(thisColName, 1) = "_" Then thisColName = Right(thisColName, Len(thisColName) - 1) thisWidth = Application.WorksheetFunction.VLookup(thisColName, displayWidth, 2) If Not (Err Or thisWidth = 0) Then wks.Columns(thisCol.Column).ColumnWidth = thisWidth Next thisCol thisWidth = Application.WorksheetFunction.VLookup("datacolumns##", displayWidth, 2) If Not (Err Or thisWidth = 0) Then thisPivot.ColumnRange.Columns.ColumnWidth = thisWidth On Error GoTo 0 Application.EnableEvents = saveEvents End Sub Sub FitRows(ByVal thisPivot As PivotTable) ' Keyboard Shortcut: Ctrl+f ' Module1.onlyOne = True thisPivot.Cells.Select Module1.onlyOne = True Selection.Rows.AutoFit Module1.onlyOne = False 'Range("D1").Select End Sub Public Sub TableUpdate(ByVal Target As Range) 'Copyright (c) 2015 Richard M. Bixler, All Rights Reserved. Do not delete this copyright notice. 'Keeps a range object in sync with table definition. Range object is updated each time the table is changed/selected. Dim tblTarget As ListObject, thisListObject As ListObject Dim cellChanged As Range, rngTarget As Range Dim strTableName As String, strRangeName As String, strTblRangePrefix As String If Target Is Nothing Then Exit Sub Set cellChanged = Target strTblRangePrefix = "rng" For Each thisListObject In cellChanged.Worksheet.ListObjects If Not Intersect(cellChanged, thisListObject.Range) Is Nothing Then Set tblTarget = thisListObject strTableName = tblTarget.Name strRangeName = strTableName If Left(strRangeName, 3) = "tbl" Then strRangeName = Right(strRangeName, Len(strRangeName) - 3) strRangeName = strTblRangePrefix & strRangeName Set rngTarget = tblTarget.Range rngTarget.Name = strRangeName Exit For End If Next thisListObject End Sub Public Sub alignButtons() Dim thisWorkbook As Workbook Dim thisWorksheet As Worksheet Dim cellButtonIndex As Range Dim heightdb As Integer, widthdb As Integer, spacedb As Integer, spaceRows If Module1.myWorkbook Is Nothing Then Set Module1.myWorkbook = ActiveWorkbook Set thisWorkbook = Module1.myWorkbook heightdb = 24 widthdb = 140 spacedb = 1 spaceRows = 7 Set thisWorkbook = Module1.myWorkbook Set thisWorksheet = thisWorkbook.Worksheets("DataSources") Set cellButtonIndex = thisWorksheet.Cells(thisWorksheet.Range("Buttons_Here").Row, thisWorksheet.Range("Buttons_Here").Column) thisWorksheet.OLEObjects("CommandButton1").Top = cellButtonIndex.Top thisWorksheet.OLEObjects("CommandButton1").Left = cellButtonIndex.Left thisWorksheet.OLEObjects("CommandButton1").Width = widthdb thisWorksheet.OLEObjects("CommandButton1").Height = heightdb thisWorksheet.OLEObjects("CommandButton2").Top = thisWorksheet.OLEObjects("CommandButton1").Top + heightdb + spacedb thisWorksheet.OLEObjects("CommandButton2").Left = cellButtonIndex.Left thisWorksheet.OLEObjects("CommandButton2").Width = widthdb thisWorksheet.OLEObjects("CommandButton2").Height = heightdb thisWorksheet.OLEObjects("RefreshLinkedServer").Top = thisWorksheet.OLEObjects("CommandButton2").Top + heightdb + spacedb thisWorksheet.OLEObjects("RefreshLinkedServer").Left = cellButtonIndex.Left thisWorksheet.OLEObjects("RefreshLinkedServer").Width = widthdb thisWorksheet.OLEObjects("RefreshLinkedServer").Height = heightdb thisWorksheet.OLEObjects("RefreshMPP").Top = thisWorksheet.OLEObjects("RefreshLinkedServer").Top + heightdb + spacedb thisWorksheet.OLEObjects("RefreshMPP").Left = cellButtonIndex.Left thisWorksheet.OLEObjects("RefreshMPP").Width = widthdb thisWorksheet.OLEObjects("RefreshMPP").Height = heightdb thisWorksheet.OLEObjects("runQuerySequence").Top = thisWorksheet.OLEObjects("RefreshMPP").Top + heightdb + spacedb thisWorksheet.OLEObjects("runQuerySequence").Left = cellButtonIndex.Left thisWorksheet.OLEObjects("runQuerySequence").Width = widthdb thisWorksheet.OLEObjects("runQuerySequence").Height = heightdb End Sub Public Function nameExists(ByVal thisname As String, ByRef thisCollection As Variant) As Boolean Dim thisItem As Variant Dim n As Integer Dim thisItemName As String nameExists = False For Each thisItem In thisCollection thisItemName = CStr(thisItem) If thisItemName = thisname Then nameExists = True Else nameExists = False If nameExists Then Exit Function Next thisItem End Function Public Function exists(ByVal thisname As String, ByVal thisCollection As Variant) As Boolean Dim thisItem As Variant exists = False For Each thisItem In thisCollection If thisItem.Name = thisname Then exists = True Exit Function End If Next thisItem End Function Public Function boolExists(ByVal thisname As String, ByVal thisCollection As Variant) As Boolean On Error Resume Next thisname = thisCollection(thisname) boolExists = (Err.Number = 0) End Function Public Function VBTEXTJOIN(ByVal strCRLFChar As String, ByVal bIgnoreBlank As Boolean, ByVal rngColConcat As Range, ByVal calledFrom As String) As String 'Replicate Excel2016 TEXTJOIN function, in VB Dim thisString As String Dim objThisString As Object Dim bColumnLabel As Boolean Dim intColConcatIndex As Integer, intColConcatIndexLast As Integer Select Case LCase(calledFrom) Case "excel" bColumnLabel = False Case "vba" bColumnLabel = True Case Else bColumnLabel = False End Select 'Set bColumnLabel to ignore first element of rngColConcat if the call is from VBA. 'rngColConcat as tablename[columnname} from Excel does not include columnname as first element. 'rngColConcat as loTableListObject.ListColumns("MaterialKey").Range includes columnname as first element. ' Find last non-empty cell intColConcatIndexLast = rngColConcat.Count For intColConcatIndex = rngColConcat.Count To 1 Step -1 thisString = rngColConcat(intColConcatIndex) ' Last non-blank cell in column defines end of string creation If Not ((thisString = "" Or IsNull(thisString)) And bIgnoreBlank) Then intColConcatIndexLast = intColConcatIndex Exit For End If Next intColConcatIndex VBTEXTJOIN = "" For intColConcatIndex = 1 To intColConcatIndexLast If bColumnLabel Then bColumnLabel = False Else thisString = rngColConcat(intColConcatIndex) ' Ignore blank cells preceding first non-blank cell If VBTEXTJOIN = "" And Not ((thisString = "" Or IsNull(thisString)) And bIgnoreBlank) Then ' Add first non-blank cell to return value VBTEXTJOIN = thisString Else ' If not directive and not empty cell: add cell content, including blank or non-blank cells after ' first non-blank cell, added value preceded by a CRLF character VBTEXTJOIN = VBTEXTJOIN & strCRLFChar & thisString End If End If Next intColConcatIndex End Function Public Function runDirective() As String Dim tblSQL As ListObject Dim columnIndex As Integer, rowIndex As Integer, startString As Integer, endString As Integer Dim thisWorksheet As Worksheet Dim tblSQLHeaderRowRange As Range, tblSQLRowRange As Range, thisCell As Range Dim tblSQLListColumns As ListColumns Dim thisColumn As Range Dim thisColumnName As String, thisDirective As String, rowString As String, command As String, strSQL As String Dim strPath As String Dim tblSQLListRows As ListRows Dim myFileSystem As New scripting.FileSystemObject Dim myTextFile As TextStream If Module1.myWorkbook Is Nothing Then Set Module1.myWorkbook = ActiveWorkbook Set thisWorksheet = Module1.myWorkbook.Worksheets("DataSources") Set tblSQL = thisWorksheet.ListObjects("tblSQL") Set tblSQLHeaderRowRange = tblSQL.HeaderRowRange Set tblSQLRowRange = tblSQL.DataBodyRange For columnIndex = 1 To tblSQLHeaderRowRange.Count thisColumnName = tblSQLHeaderRowRange(columnIndex) ' thisColumn INCLUDES the column header cell, so call VBTEXTJOIN with calledFrom="VBA" Set thisColumn = tblSQL.ListColumns(columnIndex).Range For rowIndex = 1 To thisColumn.Rows.Count thisDirective = "" rowString = thisColumn.Rows(rowIndex) startString = InStr(1, rowString, "#VBTEXTJOIN:", vbTextCompare) If startString > 0 Then ' Row contains a directive endString = InStr(startString, rowString, ";", vbTextCompare) If endString > startString Then 'Extract the Directive string thisDirective = Mid(rowString, startString, endString - startString + 1) End If If thisDirective <> "" Then ' If Directive string is successfully extracted, parse it. ' First get the Command element from the Directive string startString = InStr(1, thisDirective, ": ", vbTextCompare) + Len(": ") endString = InStr(startString, thisDirective, ";", vbTextCompare) command = Mid(thisDirective, startString, endString - startString) If Len(command) > 0 Then ' Begin execution of the Command string Select Case LCase(command) ' ********************* DIRECTIVE SELECTION AND PROCESSING *********************** Case "export" 'On EXPORT set up text file, content=strSQL, path=from WS, filename=columnname, filetype="sql", save/overwrite strSQL = Module1.VBTEXTJOIN(Chr(32) & Chr(10), True, thisColumn, "VBA") If Right(thisWorksheet.Range("ExportTo").Value2, 1) = "\" Then strPath = "" Else strPath = "\" strPath = thisWorksheet.Range("ExportTo").Value2 & strPath If Not myFileSystem.FolderExists(strPath) Then myFileSystem.CreateFolder (strPath) strPath = strPath & thisColumnName & ".sql" ' Export the file ' https://docs.microsoft.com/en-us/office/vba/language/reference/user-interface-help/createtextfile-method Set myTextFile = myFileSystem.CreateTextFile(strPath, True) myTextFile.WriteLine (strSQL) myTextFile.Close Case Else End Select End If End If End If Next rowIndex Next columnIndex Application.StatusBar = "" alignButtons End Function