├── _config.yml ├── BOA Control Panel.xlsb ├── Refresher Sample.vbs ├── LICENSE ├── README.md └── VBA └── ControlPanel.cls /_config.yml: -------------------------------------------------------------------------------- 1 | theme: jekyll-theme-cayman -------------------------------------------------------------------------------- /BOA Control Panel.xlsb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/IvanBond/SAP-BOA-Automation/HEAD/BOA Control Panel.xlsb -------------------------------------------------------------------------------- /Refresher Sample.vbs: -------------------------------------------------------------------------------- 1 | ' sample of a VBscript that can be scheduled e.g. in Windows Tasks Scheduler 2 | 3 | 'Samples of call VBS from .bat or command prompt 4 | ' Refresher.vbs /TargetFilePath:"C:\Temp\Test.xlsm" 5 | ' Refresher.vbs /TargetFilePath:"C:\Temp\BOA Automation\Sample with 2 DS.xlsb" 6 | 7 | Set NamedArguments = WScript.Arguments.Named 8 | 9 | if not NamedArguments.Exists("TargetFilePath") then 10 | TargetFilePath = "C:\Temp\BOA Automation\Sample with 2 DS.xlsb" 11 | else 12 | TargetFilePath = NamedArguments("TargetFilePath") 13 | end if 14 | 15 | set xlapp = CreateObject("Excel.Application") 16 | xlapp.visible = true 17 | 18 | xlapp.workbooks.open TargetFilePath ', true, true 19 | 20 | ' run macro "Refresh" located in worksheet ControlPanel (ID of worksheet, NOT a name) 21 | if xlapp.Run("ControlPanel.Refresh") = 0 then 22 | WScript.Echo "Refresh Failed" 23 | end if 24 | 25 | xlapp.Quit 26 | ' not 100% stable method 27 | ' used only for demo purpose 28 | ' Better solution can be found here 29 | ' https://github.com/IvanBond/Power-Refresh 30 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2018 Ivan Bondarenko 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## SAP BO Analysis for Office (BOAO) Automation 2 | 3 | This tool allows you to automate refresh of workbooks with BO Analysis data sources. 4 | Tool helps to automate change of Variables (Prompts) and dimension Filters (Background Filters), and then refresh process itself. 5 | On top of this, you can configure additional actions like "Save As", "Save As & Email", "Refresh All", Run another specific macro etc. 6 | 7 | Solution consists of only one worksheet (VBA code is inside it) 8 | 9 | - [BOA Control Panel.xlsb](https://github.com/IvanBond/SAP-BOA-Automation/blob/master/BOA%20Control%20Panel.xlsb) 10 | 11 | Worksheet can be easily moved to your workbook using standard "Move worksheet" Excel action. Then just collect variables, set values and run Refresh. 12 | 13 | # BOA Control Panel 14 | 15 | Your future operational center. Control Panel is a worksheet, which includes 16 | - tables defining scenarios of refresh and variables with their values 17 | - VBA code 18 | 19 | # How to use this tool 20 | 21 | Assume you already have a workbook with BOA data sources and want to simplify refresh process. Let's call it 'Target Workbook'. 22 | 23 | 0. Open 'Target Workbook' and 'BOA Control Panel' side by side in one Excel application. 24 | 25 | 1. Move worksheet 'Control Panel' to 'Target Workbook' 26 | 27 | 2. Press 'Collect Variables'. Macro will make inventory of data sources and their prompts / variables / filters. 28 | 29 | 3. Specify necessary settings, such as "Scope", "Refresh?", "Order", values for Variables and Filters. 30 | Use formulas to make values of your variables dynamic, then you no longer need to change them manually. 31 | 32 | You are ready to refresh! 33 | 34 | # Optional steps 35 | 36 | - If you don't want to enter your password each time - follow the instruction in comment for 'Path to file with passwords' cell. 37 | 38 | - You can specify macros that should be executed before BOA refresh and after (e.g. for your saving/mailing scenario). 39 | 40 | # What is 'Scope'? 41 | 42 | Scope defines set of settings for data sources and sets of variables. 43 | 44 | Assume you want to refresh same workbook for two different Sales Organizations. 45 | 46 | Easy. Just define two Scopes with corresponding values for variables. 47 | 48 | Using Scopes you may define very advanced scenarios of refresh. 49 | 50 | E.g. imagine report when you need to execute 10 queries for current and previous year. Without Scopes it would be 20 queries, 10 for each year. But with Scope you may leave only 10 queries. 51 | Define two Scopes - Prior Year, Current Year. Enable 'Refresh All Scopes' option. Using formulas for variables, force them to calculate corresponding to active Scope values. Add simple macro that will copy data after 'Prior Year" scope refresh is done to another worksheet. Use it in 'Macros After' for the last data source of PY scope. Then after refresh of all scopes you will have static data of PY on one worksheet and data sources with CY on another. 52 | 53 | If you run refresh from outside of workbook, e.g. like it is shown in [Sample Refresher VB script](https://github.com/IvanBond/SAP-BOA-Automation/blob/master/Refresher%20Sample.vbs) - you can even run refresh in parallel. 54 | -------------------------------------------------------------------------------- /VBA/ControlPanel.cls: -------------------------------------------------------------------------------- 1 | VERSION 1.0 CLASS 2 | BEGIN 3 | MultiUse = -1 'True 4 | END 5 | Attribute VB_Name = "ControlPanel" 6 | Attribute VB_GlobalNameSpace = False 7 | Attribute VB_Creatable = False 8 | Attribute VB_PredeclaredId = True 9 | Attribute VB_Exposed = True 10 | Option Explicit 11 | Option Compare Text 12 | 13 | Rem Introduction 14 | ' Author: Ivan Bondarenko 15 | ' Initial release: 2017-01 16 | ' https://bondarenkoivan.wordpress.com 17 | ' http://excel.city 18 | ' https://linkedin.com/in/bondarenkoivan/en 19 | 20 | ' Big Thanks to Andres Merino for ideas and testing! 21 | 22 | ' update 2017-05-24 23 | ' now macro handles cases with SAPSetVariables only 24 | ' no need to refresh twice in such cases 25 | 26 | ' update 2017-08-01 27 | ' release of version with additional actions 28 | ' added actions: 'Email', 'Save As', 'Refresh All', 'Email on Success', 'Run Macro' 29 | ' planned: Publish to PowerBI, Update PP+ThinkCell, Update PowerPoint Tables 30 | 31 | ' update 2017-08-13 32 | ' fixed serious issue with subsequent refresh 33 | ' callback now used only for first refresh of DS 34 | ' every next refresh macro uses SAPSetVariable is DS is active 35 | ' if not active - firstly refesh it, then set filters 36 | ' reason: Disable / Enable BOA is not stable action, it crashes Excel too often. 37 | ' What else? Many small fixes, renamed all objects 38 | ' now prefix for tables and named ranges is common: CP_ (from Control Panel) 39 | ' 40 | 41 | ' update 2017-08-19 42 | ' improved logic of FillHeaders sub 43 | 44 | ' update 2017-09-18 45 | ' Run Actions after each Scope - new parameter 46 | ' many minor changes 47 | 48 | ' update 2017-11-26 49 | ' new parameters for some actions 50 | ' named ranges for relative dates 51 | 52 | ' update 2018-03-12 53 | ' Email on Success renamed to Email 54 | ' minor fixes 55 | ' added comments 56 | 57 | ' declaration of function that is used in Function CreatePath 58 | ' possibly will be used for logging 59 | 60 | Rem Declaration 61 | #If VBA7 Then 62 | Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib _ 63 | "IMAGEHLP.DLL" (ByVal DirPath As String) As Long 64 | Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) 65 | #Else 66 | Private Declare Function MakeSureDirectoryPathExists Lib _ 67 | "IMAGEHLP.DLL" (ByVal DirPath As String) As Long 68 | Private Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) 69 | #End If 70 | 71 | Const ForAppending = 8 ' for OpenTextFile 72 | Const ForReading = 1 73 | 74 | Const sTableScopesName = "CP_SCOPES" 75 | Const sTableDataSourcesName = "CP_DATA_SOURCES" 76 | Const sTableVariablesName = "CP_VARIABLES" 77 | Const STableActions = "CP_ACTIONS" 78 | 79 | Public Logs_Enabled As Boolean 80 | Public LogFile As String 81 | 82 | Public objFSO As Object 83 | Public objLog As Object 84 | Dim arrDS ' array for data sources 85 | Dim currentDS As String ' current data source ID 86 | Dim currentDS_index As Long ' index in array arrDS 87 | Dim bManualRefresh As Boolean 88 | Dim bBOAEnabled As Boolean ' var to store initial state of BOA 89 | ' Enable / Disable Boa causes Excel to crash when Excel starts with BOA activated 90 | ' however, works fine when BOA is not enabled by default 91 | ' In addition, subsequent refresh doesn't trigger CallBack 92 | Dim bBeforeFirstPromptsDisplayRegistered As Boolean 93 | Dim bBeforeFirstPromptsDisplaySubExecuted As Boolean 94 | Dim dicRefreshedDataSources ' dictionary with refreshed datasources 95 | ' for refreshed data sources callback BeforeFirstPromptsDisplay won't work 96 | 97 | Dim currentActionRowId As Long 98 | Dim bCallActionFromDStable As Boolean 99 | 100 | Dim bMultiLogonMode As Boolean 101 | ' special mode when refresh is done data source be data source 102 | ' and after each data source macro run SAPLogoff 103 | ' to be sure that next data source will be refreshed with defined language 104 | ' and defined user 105 | 106 | Enum enumDataSource ' used to reference to elements of arrDS array 107 | DS_ID = 0 108 | DS_Refresh = 1 109 | DS_Language = 2 110 | DS_System = 3 111 | DS_User = 4 112 | DS_MacrosAfter = 5 113 | DS_Client = 6 114 | DS_CalculateAfter = 7 115 | DS_Row = 8 116 | DS_Sheet = 9 117 | ' Repeat Refresh can be changed by macro / formula, so do not keep it in this array 118 | DS_Crosstab = 10 119 | ' Clear Crosstab - is used by action "Clear Crosstabs", or after all actions 120 | DS_FillHeaders = 11 121 | DS_CallActions = 12 122 | End Enum 123 | 124 | Enum enumMailImportance 125 | Low = 0 126 | Normal = 1 127 | High = 2 128 | End Enum 129 | 130 | Dim dummy As Integer 131 | Rem End of declaration 132 | 133 | Function Manual_Refresh() As Boolean 134 | bManualRefresh = True 135 | Manual_Refresh = Refresh 136 | End Function 137 | 138 | Private Sub Worksheet_Activate() 139 | If Me.Names("CP_PASSWORDS_PATH").RefersToRange.Value = vbNullString Then 140 | Me.Names("CP_PASSWORDS_PATH").RefersToRange.Value = CreateObject("WScript.Shell").SpecialFolders("mydocuments") & "\Passwords.txt" 141 | End If 142 | If Me.Names("CP_GENERAL_USER").RefersToRange.Value = vbNullString Then 143 | Me.Names("CP_GENERAL_USER").RefersToRange.Value = LCase(Environ("username")) 144 | End If 145 | End Sub 146 | 147 | Private Sub Worksheet_SelectionChange(ByVal Target As Range) 148 | If Me.Names("CP_PASSWORDS_PATH").RefersToRange.Value = vbNullString Then 149 | Me.Names("CP_PASSWORDS_PATH").RefersToRange.Value = CreateObject("WScript.Shell").SpecialFolders("mydocuments") & "\Passwords.txt" 150 | End If 151 | If Me.Names("CP_GENERAL_USER").RefersToRange.Value = vbNullString Then 152 | Me.Names("CP_GENERAL_USER").RefersToRange.Value = LCase(Environ("username")) 153 | End If 154 | End Sub 155 | 156 | Private Sub DefineGlobalVariables() 157 | Set objFSO = CreateObject("Scripting.FileSystemObject") 158 | If Left(ThisWorkbook.Path, 4) <> "http" Then 159 | ' Logs_Enabled = True ' TODO - add cell with parameter 160 | LogFile = ThisWorkbook.Path & "\" & ThisWorkbook.Name & ".log" 161 | Else 162 | LogFile = Environ("temp") & "\" & ThisWorkbook.Name & ".log" 163 | End If 164 | End Sub 165 | 166 | Function Refresh() As Boolean 167 | Dim StartPoint As Double 168 | Dim cell_scope As Range 169 | Dim i As Long 170 | Dim m As Integer 171 | Dim arrMacrosBefore 172 | Dim arrMacrosAfter 173 | Dim arrMacrosAfterDSRefresh 174 | Dim arrActions 175 | Dim Attempt As Long 176 | Dim bYetAnotherAttempt As Boolean 177 | Dim bSAPSetVariablesOnly As Boolean ' when scope's filters don't contain SAPSetFilter command 178 | Dim lScopeRow As Long 179 | Dim iRet As Integer 180 | Dim InitialCalculationState As Long 181 | Dim bScopeFailed As Boolean 182 | 183 | On Error GoTo ErrHandler 184 | 185 | If Me.ListObjects("CP_SCOPES").DataBodyRange Is Nothing Then 186 | If bManualRefresh Then 187 | MsgBox "No scopes defined!", vbCritical 188 | End If 189 | Exit Function 190 | End If 191 | 192 | StartPoint = Now() 193 | InitialCalculationState = Application.Calculation 194 | Application.Calculation = xlCalculationManual 195 | ThisWorkbook.Windows(1).Activate ' otherwise Logon fails, if another wb is active 196 | 197 | Me.Names("CP_LAST_REPORT_DATE").RefersToRange.Value = _ 198 | Me.Names("CP_REPORT_DATE").RefersToRange.Value 199 | 200 | If IsEmpty(dicRefreshedDataSources) Then 201 | Set dicRefreshedDataSources = CreateObject("Scripting.Dictionary") 202 | dicRefreshedDataSources.comparemode = 1 ' TextCompare 203 | End If 204 | 205 | Application.StatusBar = "Enabling BOA..." 206 | Call EnableBOA ' does nothing if addin is already enabled 207 | 208 | Application.StatusBar = "Defining global variables..." 209 | Call DefineGlobalVariables 210 | 211 | Application.StatusBar = "Executing macros before Refresh..." 212 | arrMacrosBefore = Split(Me.Names("CP_MACROS_BEFORE").RefersToRange.Value, ",") 213 | 214 | For m = 0 To UBound(arrMacrosBefore) 215 | On Error Resume Next 216 | Application.StatusBar = "Executing macro " & Trim(arrMacrosBefore(m)) & "..." 217 | Application.Run Trim(arrMacrosBefore(m)) 218 | If Err.Number <> 0 Then 219 | Debug.Print Now, "Couldn't run macro " & Trim(arrMacrosBefore(m)) 220 | GoTo ErrHandler 221 | End If 222 | On Error GoTo 0 223 | 224 | ' ? do we need to calc after each macro? - macro owner decides 225 | Next m 226 | Application.StatusBar = vbNullString 227 | 228 | On Error GoTo ErrHandler 229 | ' initial calculate 230 | With Application 231 | .StatusBar = "Initial calculation..." 232 | .Calculate 233 | .StatusBar = vbNullString 234 | End With 235 | 236 | For lScopeRow = 1 To Me.ListObjects("CP_SCOPES").DataBodyRange.Rows.Count 237 | 238 | Me.ListObjects("CP_SCOPES").DataBodyRange.Calculate 239 | 240 | ' if 'Refresh All Scopes' mode is enabled - change main Scope cell 241 | If Me.Names("CP_REFRESH_ALL_SCOPES").RefersToRange.Value = "Y" Then 242 | If Me.ListObjects("CP_SCOPES").ListColumns("Enabled?").DataBodyRange.Cells(lScopeRow, 1).Value <> "Y" Then 243 | GoTo Next_Scope 244 | Else 245 | Application.EnableEvents = False 246 | Me.Names("CP_SCOPE").RefersToRange.Value = _ 247 | "'" & CStr(Me.ListObjects("CP_SCOPES").ListColumns("Scope").DataBodyRange.Cells(lScopeRow, 1).Value) 248 | Application.EnableEvents = True 249 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": calculating..." 250 | Application.Calculate ' just in case 251 | Application.StatusBar = vbNullString 252 | End If 253 | Else 254 | ' leave Scope cell as is 255 | End If 256 | 257 | ' refresh screen 258 | If bManualRefresh Then 259 | Application.ScreenUpdating = True 260 | WaitSeconds 1 261 | Application.ScreenUpdating = False 262 | End If 263 | 264 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Collecting data sources..." 265 | Call GetArrDS ' populate array with data sources 266 | Application.StatusBar = vbNullString 267 | 268 | On Error Resume Next 269 | Debug.Print Now, "# Data sources: "; UBound(arrDS) 270 | If Err.Number <> 0 Then 271 | Err.Clear 272 | GoTo Skipped_Data_Sources 273 | End If 274 | On Error GoTo ErrHandler 275 | 276 | ' old version - check if any Data Sources defined 277 | ' If WorksheetFunction.CountIf(Me.ListObjects(sTableDataSourcesName).ListColumns("Scope").DataBodyRange, _ 278 | ' CStr(Me.Names("CP_SCOPE").RefersToRange.Value)) = 0 Then 279 | ' ' no data sources defined for scope 280 | ' If bManualRefresh Then 281 | ' MsgBox "No Data Sources specified for scope '" & Me.Names("CP_SCOPE").RefersToRange.Value & "'." & vbCrLf _ 282 | ' & "Disable Scope or add Data Sources.", vbExclamation 283 | ' Else 284 | ' Debug.Print Now, "No Data Sources specified for scope " & Me.Names("CP_SCOPE").RefersToRange.Value 285 | ' End If 286 | ' bScopeFailed = True 287 | ' GoTo Next_Scope 288 | ' End If 289 | ' No check for 'data sources defined' to support scenario, when we need only Actions 290 | ' this is not for refresh of data sources, but rather for misuse of this tool 291 | ' e.g. define list of Scopes and turn on "Refresh All Scopes" 292 | ' after each Scope macro can execute actions, like refresh + Save As 293 | ' it allows to generate files from one worksheet 294 | 295 | 296 | ' when common connection parameters are used - enough to logon once 297 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Logging On..." 298 | If Not LogOn_DataSources Then 299 | Debug.Print Now, "Couldn't LogOn" 300 | If bManualRefresh Then 301 | Stop 302 | End If 303 | GoTo ErrHandler 304 | End If 305 | Application.StatusBar = vbNullString 306 | 307 | ' refresh all enabled data sources in the specified scope using specified order 308 | For i = 1 To UBound(arrDS, 1) 309 | ' array elements are ordered 310 | ' macro refreshes only those that enabled 311 | If arrDS(i, enumDataSource.DS_Refresh) = "Y" Then 312 | Attempt = 0 ' attempt to refresh in case of delay (if no new data) 313 | bYetAnotherAttempt = False 314 | bSAPSetVariablesOnly = IsSAPSetVariablesOnly(CStr(arrDS(i, enumDataSource.DS_ID))) 315 | currentDS = CStr(arrDS(i, enumDataSource.DS_ID)) 316 | currentDS_index = i ' index in array, not a row of sheet! 317 | 318 | ' Jump to new refresh attempt if RepeatRefresh is enabled 319 | Start_Refresh: 320 | On Error GoTo ErrHandler 321 | 322 | ' if another attempt - we have to logon again 323 | ' as for safety macro does Logoff (avoid kick from server) 324 | If bYetAnotherAttempt Then 325 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Logging On..." 326 | If Not LogOn_DataSources Then 327 | Debug.Print Now, "Couldn't LogOn" 328 | If bManualRefresh Then 329 | Stop 330 | End If 331 | GoTo ErrHandler 332 | End If 333 | Application.StatusBar = vbNullString 334 | End If 335 | 336 | ' if within one Scope we should refresh several data sources with different languages 337 | ' e.g. everything is available in local language except one data source, which should be refreshed in EN 338 | If bMultiLogonMode Then 339 | If i = 1 Then ' if first data source 340 | ' logon with specified Language / User / Client 341 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Logging On " & arrDS(i, enumDataSource.DS_ID) 342 | If Run("SAPLogon", arrDS(i, enumDataSource.DS_ID), arrDS(i, enumDataSource.DS_Client), arrDS(i, enumDataSource.DS_User), _ 343 | GetPassword(CStr(arrDS(i, enumDataSource.DS_System)), CStr(arrDS(i, enumDataSource.DS_User))), _ 344 | arrDS(i, enumDataSource.DS_Language)) = 0 Then 345 | 346 | Debug.Print Now, "Couldn't LogOn to " & CStr(arrDS(i, enumDataSource.DS_System)) 347 | If bManualRefresh Then 348 | Stop 349 | End If 350 | GoTo ErrHandler 351 | End If 352 | Else 353 | ' if one of previous connection parameters differ from current 354 | ' in the end of prev cycle macro logged off - check end of loop area for MultiLogon case 355 | If arrDS(i, enumDataSource.DS_Language) <> arrDS(i - 1, enumDataSource.DS_Language) Or _ 356 | arrDS(i, enumDataSource.DS_System) <> arrDS(i - 1, enumDataSource.DS_System) Or _ 357 | arrDS(i, enumDataSource.DS_Client) <> arrDS(i - 1, enumDataSource.DS_Client) Or _ 358 | arrDS(i, enumDataSource.DS_User) <> arrDS(i - 1, enumDataSource.DS_User) Then 359 | 360 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Logging On " & arrDS(i, enumDataSource.DS_ID) 361 | If Run("SAPLogon", arrDS(i, enumDataSource.DS_ID), arrDS(i, enumDataSource.DS_Client), arrDS(i, enumDataSource.DS_User), _ 362 | GetPassword(CStr(arrDS(i, enumDataSource.DS_System)), CStr(arrDS(i, enumDataSource.DS_User))), _ 363 | arrDS(i, enumDataSource.DS_Language)) = 0 Then 364 | 365 | Debug.Print Now, "Couldn't LogOn to " & CStr(arrDS(i, enumDataSource.DS_System)) 366 | If bManualRefresh Then 367 | Stop 368 | End If 369 | GoTo ErrHandler 370 | End If 371 | End If 372 | 373 | End If ' if first data source in array 374 | Else 375 | ' not bMultiLogonMode 376 | ' logon was done during LogOn_DataSources 377 | End If ' MultiLogon check 378 | 379 | ' Logon is done at this step 380 | ' after Logon - Initial Refresh (for SAPSetFilter) 381 | If Not bSAPSetVariablesOnly Then 382 | ' SAPSetVariableOnly is Scope-depending 383 | If Not Application.Run("SAPGetProperty", "IsDataSourceActive", CStr(arrDS(i, enumDataSource.DS_ID))) Then 384 | ' if SAPSetFilter is used then we need "Initial Refresh" before ApplyScopeFilters 385 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Refreshing " & arrDS(i, enumDataSource.DS_ID) & "...(" & i & "/" & UBound(arrDS) & ")" 386 | If Run("SAPExecuteCommand", "Refresh", arrDS(i, enumDataSource.DS_ID)) = 0 Then 387 | Debug.Print Now, "Couldn't Refresh " & CStr(arrDS(i, enumDataSource.DS_ID)) 388 | GoTo ErrHandler 389 | End If 390 | Application.StatusBar = vbNullString 391 | bBeforeFirstPromptsDisplaySubExecuted = False ' if callback was called - do not track it here 392 | 393 | ' add to dictionary 394 | If Not dicRefreshedDataSources.exists(CStr(arrDS(i, enumDataSource.DS_ID))) Then 395 | dicRefreshedDataSources.Add CStr(arrDS(i, enumDataSource.DS_ID)), CStr(arrDS(i, enumDataSource.DS_ID)) 396 | End If 397 | End If 398 | End If ' not bSAPSetVariablesOnly 399 | 400 | ' just in case, if user set pause 401 | ' without it VBA cannot use com-addin's API 402 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Refreshing " & arrDS(i, enumDataSource.DS_ID) & "...(" & i & "/" & UBound(arrDS) & ")" 403 | Call Run("SAPExecuteCommand", "PauseVariableSubmit", "Off") ' unpause submit of variables 404 | Call Run("SAPSetRefreshBehaviour", "On") ' triggers RefreshData 405 | Application.StatusBar = vbNullString 406 | 407 | ' set filters / variables 408 | ' AnotherAttempt - is a second or third attempt after successful first refresh (where filters were set) 409 | ' first attempt is Scope-depending. It is not the same as first refresh of data source within session 410 | If Not bYetAnotherAttempt Then 411 | ' note: 412 | ' if first attempt (not the same as first refresh of data source) - we have to apply filters / variables 413 | ' note: if second / third ... attempt - no need to set variables again 414 | 415 | ' if active - just apply scope filters 416 | If Application.Run("SAPGetProperty", "IsDataSourceActive", CStr(arrDS(i, enumDataSource.DS_ID))) Then 417 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & " - Applying filters to " & arrDS(i, enumDataSource.DS_ID) & "...(" & i & "/" & UBound(arrDS) & ")" 418 | ' during ApplyScopeFilters macro will 419 | ' set PauseVariableSubmit to On, and SAPSetRefreshBehaviour to Off 420 | If Not ApplyScopeFilters(CStr(Me.Names("CP_SCOPE").RefersToRange.Value), CStr(arrDS(i, enumDataSource.DS_ID))) Then 421 | Debug.Print Now, "Couldn't Apply filters for " & CStr(arrDS(i, enumDataSource.DS_ID)) 422 | If bManualRefresh Then 423 | Stop 424 | End If 425 | End If 426 | 427 | ' unpause 428 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Refreshing " & arrDS(i, enumDataSource.DS_ID) & "...(" & i & "/" & UBound(arrDS) & ")" 429 | Call Run("SAPExecuteCommand", "PauseVariableSubmit", "Off") ' unpause submit of variables 430 | Call Run("SAPSetRefreshBehaviour", "On") ' triggers RefreshData 431 | Application.StatusBar = vbNullString 432 | Else 433 | ' DS is not active - probably after logoff / logon or the very first refresh 434 | ' the very first refresh of data source (callback) OR consequent refresh 435 | If dicRefreshedDataSources.exists(CStr(arrDS(i, enumDataSource.DS_ID))) Then 436 | ' callback will not work for consequent refresh 437 | ' as DS is not Active - we have to refresh it 438 | ' in old version: we used Disable BOA + Enable BOA to reset callback, 439 | ' but it crashes Excel in most of the cases 440 | ' new method can lead to double refresh, but no other stable choice 441 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Refreshing " & arrDS(i, enumDataSource.DS_ID) & "...(" & i & "/" & UBound(arrDS) & ")" 442 | If Run("SAPExecuteCommand", "Refresh", arrDS(i, enumDataSource.DS_ID)) = 0 Then 443 | Debug.Print Now, "Couldn't Refresh " & CStr(arrDS(i, enumDataSource.DS_ID)) 444 | GoTo ErrHandler 445 | End If 446 | ' no need to add to the dictionary 447 | bBeforeFirstPromptsDisplaySubExecuted = False 448 | 449 | ' after refresh we can set filters 450 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Applying filters to " & arrDS(i, enumDataSource.DS_ID) & "...(" & i & "/" & UBound(arrDS) & ")" 451 | ' during ApplyScopeFilters macro will 452 | ' set PauseVariableSubmit to On, and SAPSetRefreshBehaviour to Off 453 | If Not ApplyScopeFilters(CStr(Me.Names("CP_SCOPE").RefersToRange.Value), CStr(arrDS(i, enumDataSource.DS_ID))) Then 454 | Debug.Print Now, "Couldn't Apply filters for " & CStr(arrDS(i, enumDataSource.DS_ID)) 455 | If bManualRefresh Then 456 | Stop 457 | End If 458 | End If 459 | 460 | ' unpause 461 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Refreshing " & arrDS(i, enumDataSource.DS_ID) & "...(" & i & "/" & UBound(arrDS) & ")" 462 | Call Run("SAPExecuteCommand", "PauseVariableSubmit", "Off") ' unpause submit of variables 463 | Call Run("SAPSetRefreshBehaviour", "On") ' triggers RefreshData 464 | Application.StatusBar = vbNullString 465 | Else 466 | ' doesn't exists in dictionary 467 | 468 | If bSAPSetVariablesOnly Then 469 | ' the very first refresh - use callback, it should work 470 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Registering callback BeforeFirstPromptsDisplay..." 471 | Call Callback_BeforeFirstPromptsDisplay_Reg 472 | 473 | ' just refresh and callback will set filters 474 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Refreshing " & arrDS(i, enumDataSource.DS_ID) & "...(" & i & "/" & UBound(arrDS) & ")" 475 | iRet = Run("SAPExecuteCommand", "Refresh", arrDS(i, enumDataSource.DS_ID)) 476 | Debug.Print Now, "Refresh", CStr(arrDS(i, enumDataSource.DS_ID)), iRet 477 | 478 | ' check whether callback was called 479 | If bBeforeFirstPromptsDisplayRegistered And (Not bBeforeFirstPromptsDisplaySubExecuted) Then 480 | ' variables were not applied 481 | Debug.Print Now, "Callback didn't work" 482 | ' still have to apply filters - only using double refresh 483 | ' this never happend to me, but in case of issue of BOA... 484 | If bManualRefresh Then 485 | Stop 486 | End If 487 | End If 488 | 489 | ' unregistering is not necessary, but just in case. It takes no time 490 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Unregistering callback BeforeFirstPromptsDisplay..." 491 | Call Callback_BeforeFirstPromptsDisplay_UnReg 492 | Application.StatusBar = vbNullString 493 | Else 494 | ' have SAPSetFilter 495 | ' if it is first attempt - call ApplyScopeFilters 496 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Applying filters to " & arrDS(i, enumDataSource.DS_ID) & "...(" & i & "/" & UBound(arrDS) & ")" 497 | 498 | ' during ApplyScopeFilters macro will 499 | ' set PauseVariableSubmit to On, and SAPSetRefreshBehaviour to Off 500 | If Not ApplyScopeFilters(CStr(Me.Names("CP_SCOPE").RefersToRange.Value), CStr(arrDS(i, enumDataSource.DS_ID))) Then 501 | Debug.Print Now, "Couldn't Apply filters for " & CStr(arrDS(i, enumDataSource.DS_ID)) 502 | GoTo ErrHandler 503 | End If 504 | Application.StatusBar = vbNullString 505 | 506 | ' unpause 507 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Refreshing " & arrDS(i, enumDataSource.DS_ID) & "...(" & i & "/" & UBound(arrDS) & ")" 508 | Call Run("SAPExecuteCommand", "PauseVariableSubmit", "Off") ' unpause submit of variables 509 | Call Run("SAPSetRefreshBehaviour", "On") ' triggers RefreshData 510 | Application.StatusBar = vbNullString 511 | End If ' If bSAPSetVariablesOnly Then 512 | End If ' if dicRefreshedDataSources.Exists( cstr(arrDS(i, enumDataSource.DS_ID)) ) then 513 | End If ' if Application.Run("SAPGetProperty", "IsDataSourceActive", CStr(arrDS(i, enumDataSource.DS_ID))) then 514 | Else 515 | ' 2nd, 3rd... attempt 516 | ' just refresh, all filters were set for first refresh 517 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Refreshing " & arrDS(i, enumDataSource.DS_ID) & "...(" & i & "/" & UBound(arrDS) & ")" 518 | Call Run("SAPExecuteCommand", "Refresh", arrDS(i, enumDataSource.DS_ID)) 519 | Application.StatusBar = vbNullString 520 | End If ' If Not bYetAnotherAttempt Then 521 | 522 | bBeforeFirstPromptsDisplaySubExecuted = False 523 | 524 | ' since program is here - DS was refreshed 525 | If Not dicRefreshedDataSources.exists(CStr(arrDS(i, enumDataSource.DS_ID))) Then 526 | ' register fact of refresh - add to dictionary 527 | dicRefreshedDataSources.Add CStr(arrDS(i, enumDataSource.DS_ID)), CStr(arrDS(i, enumDataSource.DS_ID)) 528 | End If 529 | 530 | If bMultiLogonMode Then 531 | ' if next DS has different connection parameters - logoff 532 | If i < UBound(arrDS) Then 533 | If arrDS(i, enumDataSource.DS_Language) <> arrDS(i + 1, enumDataSource.DS_Language) Or _ 534 | arrDS(i, enumDataSource.DS_System) <> arrDS(i + 1, enumDataSource.DS_System) Or _ 535 | arrDS(i, enumDataSource.DS_Client) <> arrDS(i + 1, enumDataSource.DS_Client) Or _ 536 | arrDS(i, enumDataSource.DS_User) <> arrDS(i + 1, enumDataSource.DS_User) Then 537 | 538 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Logging Off..." 539 | Application.EnableEvents = False ' for some reason LogOff triggers SelectionChange event 540 | Call LogOffBOA 541 | Application.EnableEvents = True 542 | Application.StatusBar = vbNullString 543 | End If 544 | End If 545 | End If 546 | 547 | ' **************************** Extra actions for data source **************************** 548 | 549 | ' Fill Headers 550 | If arrDS(i, enumDataSource.DS_FillHeaders) = "Y" Then 551 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Filling headers for " & CStr(arrDS(i, enumDataSource.DS_ID)) 552 | Call FillHeaders(CStr(arrDS(i, enumDataSource.DS_Crosstab))) 553 | Application.StatusBar = vbNullString 554 | End If 555 | 556 | ' calculate if user specified this parameter 557 | If arrDS(i, enumDataSource.DS_CalculateAfter) = "Y" Then 558 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Calculating after " & CStr(arrDS(i, enumDataSource.DS_ID)) 559 | 'Application.CalculationInterruptKey = xlNoKey 560 | Application.Calculate ' trigger calculation of formulas. Possibly, next report has filter based on the refreshed report 561 | 'Application.CalculationInterruptKey = xlAnyKey 562 | Application.StatusBar = vbNullString 563 | End If 564 | 565 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Executing Macros After " & CStr(arrDS(i, enumDataSource.DS_ID)) 566 | If arrDS(i, enumDataSource.DS_MacrosAfter) <> vbNullString Then 567 | arrMacrosAfterDSRefresh = Split(arrDS(i, enumDataSource.DS_MacrosAfter), ",") 568 | 569 | For m = 0 To UBound(arrMacrosAfterDSRefresh) 570 | On Error Resume Next 571 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Executing macro " & Trim(arrMacrosAfterDSRefresh(m)) & "..." 572 | Application.Run Trim(arrMacrosAfterDSRefresh(m)) 573 | If Err.Number <> 0 Then 574 | Debug.Print Now, "Couldn't run macro " & Trim(arrMacrosAfterDSRefresh(m)) 575 | GoTo ErrHandler 576 | End If 577 | On Error GoTo 0 578 | Next m ' next macro 579 | End If ' If arrDS(i, enumDataSource.DS_MacrosAfter) <> vbNullString Then 580 | Application.StatusBar = vbNullString 581 | 582 | ' Handle Delay scenario 583 | Me.Names("CP_DELAY").RefersToRange.Calculate 584 | ' user could call a sub, which change CONTROL_PANEL_DELAY cell value 585 | ' check it - Check if no new data 586 | If Me.Names("CP_DELAY").RefersToRange.Value = "Y" Then 587 | ' check if have attempts 588 | ' starts from 0 for each data source 589 | Attempt = Attempt + 1 590 | If Attempt > Me.Names("CP_ATTEMPTS").RefersToRange.Value Then 591 | Debug.Print Now, "Attempts limit exceed. " & arrDS(i, enumDataSource.DS_ID) & " has no new data." 592 | GoTo ErrHandler 593 | Else 594 | ' if trigger - wait 595 | ' log off to prevent kick from server 596 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Logging Off..." 597 | Application.EnableEvents = False ' for some reason LogOff triggers SelectionChange event 598 | Call LogOffBOA 599 | Application.EnableEvents = True 600 | 601 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Delay till " & Format((Now() + TimeValue("00:" & Right("0" & _ 602 | CStr(Me.Names("CP_DELAY_FOR").RefersToRange.Value), 2) & ":00")), "yyyy-MM-dd hh:mm:ss") 603 | 604 | Debug.Print Now, "Delay till " & Format((Now() + TimeValue("00:" & Right("0" & _ 605 | CStr(Me.Names("CP_DELAY_FOR").RefersToRange.Value), 2) & ":00")), "yyyy-MM-dd hh:mm:ss") 606 | 607 | WaitSeconds 60 * Me.Names("CP_DELAY_FOR").RefersToRange.Value 608 | 609 | Application.StatusBar = vbNullString 610 | 611 | bYetAnotherAttempt = True 612 | ' refresh same data source again - and make same check again 613 | GoTo Start_Refresh 614 | End If ' If Attempt > Me.Names("CP_ATTEMPTS").RefersToRange.Value Then 615 | End If ' If Me.Names("CP_DELAY").RefersToRange.Value = "Y" Then 616 | 617 | ' Call Action 618 | ' call specified actions 619 | If CStr(arrDS(i, enumDataSource.DS_CallActions)) <> vbNullString Then 620 | bCallActionFromDStable = True 621 | arrActions = Split(CStr(arrDS(i, enumDataSource.DS_CallActions)), ",") 622 | For m = LBound(arrActions) To UBound(arrActions) 623 | Call Actions_Handler(Trim(arrActions(m))) 624 | Next m 625 | bCallActionFromDStable = False 626 | End If 627 | 628 | ' if Repeat refresh 629 | With Me.ListObjects(sTableDataSourcesName) 630 | ' calculate to get state of Repeat Refresh 631 | Me.Cells(arrDS(i, enumDataSource.DS_Row), .ListColumns("Repeat Refresh").Range.Column).Calculate 632 | If Me.Cells(arrDS(i, enumDataSource.DS_Row), .ListColumns("Repeat Refresh").Range.Column).Value = "Y" Then 633 | 634 | GoTo Start_Refresh 635 | End If 636 | End With 637 | 638 | End If ' If arrDS(i, enumDataSource.DS_Refresh) = "Y" Then 639 | 640 | Next_Data_Source: 641 | Next i ' next Data source 642 | 643 | Skipped_Data_Sources: 644 | ' if 'Refresh All Scopes' mode is disabled - then quit from loop 645 | If Me.Names("CP_REFRESH_ALL_SCOPES").RefersToRange.Value <> "Y" Then 646 | Exit For ' Next lScopeRow 647 | End If 648 | 649 | If Not bScopeFailed Then 650 | If Me.Names("CP_RUN_ACTIONS_EACH_SCOPE").RefersToRange.Value = "Y" Then 651 | Application.StatusBar = "Actions after " & Me.Names("CP_SCOPE").RefersToRange.Value 652 | Call Actions_Handler 653 | End If 654 | End If 655 | 656 | Next_Scope: 657 | Application.StatusBar = Me.Names("CP_SCOPE").RefersToRange.Value & ": Completed" 658 | Next lScopeRow 659 | 660 | arrMacrosAfter = Split(Me.Names("CP_MACROS_AFTER").RefersToRange.Value, ",") 661 | For m = 0 To UBound(arrMacrosAfter) 662 | Application.StatusBar = "Executing macros after Refresh..." 663 | On Error Resume Next 664 | Run Trim(arrMacrosAfter(m)) 665 | If Err.Number <> 0 Then 666 | Debug.Print Now, "Couldn't run macro " & arrMacrosAfterDSRefresh(m) 667 | GoTo ErrHandler 668 | End If 669 | On Error GoTo 0 670 | Next m 671 | 672 | ' resulting calculation 673 | Application.StatusBar = "Final calculation..." 674 | Application.Calculate 675 | Application.StatusBar = vbNullString 676 | 677 | Me.Names("CP_LAST_REFRESH_DATETIME").RefersToRange.Value = Now() 678 | 679 | Debug.Print Now, "Refresh time: " & Format(Now() - StartPoint, "hh:mm:ss") 680 | 681 | ' Call Write_Log("END # Overall execution time # " & _ 682 | Round((Now() - StartPoint) * 3600 * 24 / 60, 0) & "m " & _ 683 | FormatNumber(Round((Now() - StartPoint) * 3600 * 24, 0) Mod 60, 0) & "s") 684 | 685 | ' if Refresh for All scopes enabled and Actions after each scope 686 | ' Actions Handler was called after last enabled scope 687 | ' no need to call it again 688 | If Me.Names("CP_REFRESH_ALL_SCOPES").RefersToRange.Value = "Y" And _ 689 | Me.Names("CP_RUN_ACTIONS_EACH_SCOPE").RefersToRange.Value = "Y" Then 690 | ' skip 691 | Else 692 | Call Actions_Handler 693 | End If 694 | 695 | Refresh = True 696 | 697 | Exit_Function: 698 | On Error Resume Next 699 | 700 | Erase arrDS 701 | 702 | If Not bManualRefresh Then 703 | Application.StatusBar = "Logging off..." 704 | Call LogOffBOA ' just in case 705 | 706 | Application.StatusBar = "Disabling BOA..." 707 | ' Disabling is needed for automation 708 | ' otherwise Excel application cannot be closed 709 | ' BO Analysis addin requires something... 710 | Call DisableBOA 711 | Application.StatusBar = vbNullString 712 | Else 713 | 'Application.StatusBar = "Logging off..." 714 | 'Call Run("SAPLogOff", True) ' re-connect 715 | 'Application.StatusBar = vbNullString 716 | End If 717 | 718 | With Application 719 | .Cursor = xlDefault 720 | .EnableEvents = True 721 | .ScreenUpdating = True ' just in case 722 | .StatusBar = "Final calculation..." ' just in case 723 | .Calculation = InitialCalculationState 724 | .StatusBar = vbNullString 725 | End With 726 | 727 | Exit Function 728 | 729 | ErrHandler: 730 | ' send email? 731 | If Err.Number <> 0 Then 732 | Debug.Print Now, "Refresh", Err.Number & ": " & Err.Description 733 | Err.Clear 734 | Application.Cursor = xlDefault 735 | Application.ScreenUpdating = True 736 | If bManualRefresh Then Stop 737 | End If 738 | GoTo Exit_Function 739 | Resume 740 | End Function 741 | 742 | Private Function IsBOAEnabled() As Boolean 743 | Dim addIn As COMAddIn 744 | On Error Resume Next 745 | For Each addIn In Application.COMAddIns 746 | If addIn.progID = "SapExcelAddIn" Then 747 | If addIn.Connect = True Then 748 | IsBOAEnabled = True 749 | Exit Function 750 | End If 751 | End If 752 | Next 753 | End Function 754 | 755 | Private Sub EnableBOA() 756 | Dim addIn As COMAddIn 757 | On Error Resume Next 758 | For Each addIn In Application.COMAddIns 759 | If addIn.progID = "SapExcelAddIn" Then 760 | If addIn.Connect = False Then 761 | addIn.Connect = True 762 | Exit Sub 763 | End If 764 | End If 765 | Next 766 | End Sub 767 | 768 | Private Sub DisableBOA() 769 | Dim addIn As COMAddIn 770 | On Error Resume Next 771 | For Each addIn In Application.COMAddIns 772 | If addIn.progID = "SapExcelAddIn" Then 773 | addIn.Connect = False 774 | Exit Sub 775 | End If 776 | Next 777 | End Sub 778 | 779 | Private Function LogOn_DataSources() As Boolean 780 | Dim arrSystems 781 | Dim arrDataSources 782 | Dim arrLanguages 783 | Dim i As Long 784 | Dim r As Long 785 | Dim sLanguage As String 786 | Dim sUser As String 787 | Dim sSystem As String 788 | Dim sClient As String 789 | Dim dicSystems As Object 790 | Dim Key 791 | Dim n As Long 792 | 793 | On Error GoTo ErrHandler 794 | 795 | Set dicSystems = CreateObject("Scripting.Dictionary") 796 | dicSystems.comparemode = 1 ' TextCompare 797 | 798 | With Me.ListObjects(sTableDataSourcesName) 799 | If .DataBodyRange Is Nothing Then 800 | LogOn_DataSources = True 801 | Exit Function 802 | Else 803 | ' check if any data sources in scope 804 | ' number of data sources in Scope 805 | n = WorksheetFunction.CountIf(Me.ListObjects(sTableDataSourcesName).ListColumns("Scope").DataBodyRange, _ 806 | Me.Names("CP_SCOPE").RefersToRange.Value) 807 | 808 | If n = 0 Then 809 | Debug.Print Now, "No data sources defined for scope " & Me.Names("CP_SCOPE").RefersToRange.Value 810 | If bManualRefresh Then 811 | Stop 812 | End If 813 | End If 814 | 815 | ' check if several languages in Scope 816 | For r = 1 To .DataBodyRange.Rows.Count 817 | If CStr(.ListColumns("Scope").DataBodyRange.Cells(r, 1).Value) = _ 818 | CStr(Me.Names("CP_SCOPE").RefersToRange.Value) Then 819 | ' Connection parameters - System, Client, Language 820 | ' in 99.9% cases workbook use sames values for all three 821 | ' however, sometimes we can meet workbooks with data from different systems 822 | ' or queries that uses different languages 823 | ' if so - I call it Multi-Logon mode 824 | ' as it requires to logoff from prev session and logon with new parameters 825 | 826 | If sLanguage = vbNullString And .ListColumns("Refresh?").DataBodyRange.Cells(r, 1).Value = "Y" Then 827 | ' on first step - remember value in variable 828 | sLanguage = IIf(.ListColumns("Language").DataBodyRange.Cells(r, 1).Value = vbNullString, _ 829 | Me.Names("CP_GENERAL_LANGUAGE").RefersToRange.Value, _ 830 | .ListColumns("Language").DataBodyRange.Cells(r, 1).Value) 831 | Else 832 | ' second and further steps - compare each row with value in variable 833 | If sLanguage <> IIf(.ListColumns("Language").DataBodyRange.Cells(r, 1).Value = vbNullString, _ 834 | Me.Names("CP_GENERAL_LANGUAGE").RefersToRange.Value, _ 835 | .ListColumns("Language").DataBodyRange.Cells(r, 1).Value) And _ 836 | .ListColumns("Refresh?").DataBodyRange.Cells(r, 1).Value = "Y" Then 837 | bMultiLogonMode = True 838 | LogOn_DataSources = True 839 | Exit Function 840 | End If 841 | End If ' empty language 842 | 843 | If sUser = vbNullString And .ListColumns("Refresh?").DataBodyRange.Cells(r, 1).Value = "Y" Then 844 | ' on first step - remember value in variable 845 | sUser = IIf(.ListColumns("User").DataBodyRange.Cells(r, 1).Value = vbNullString, _ 846 | Me.Names("CP_GENERAL_USER").RefersToRange.Value, _ 847 | .ListColumns("User").DataBodyRange.Cells(r, 1).Value) 848 | Else 849 | ' second and further steps - compare each row with value in variable 850 | If sUser <> IIf(.ListColumns("User").DataBodyRange.Cells(r, 1).Value = vbNullString, _ 851 | Me.Names("CP_GENERAL_USER").RefersToRange.Value, _ 852 | .ListColumns("User").DataBodyRange.Cells(r, 1).Value) And _ 853 | .ListColumns("Refresh?").DataBodyRange.Cells(r, 1).Value = "Y" Then 854 | bMultiLogonMode = True 855 | LogOn_DataSources = True 856 | Exit Function 857 | End If 858 | End If 859 | 860 | ' check if different clients used in Scope 861 | If sClient = vbNullString And .ListColumns("Refresh?").DataBodyRange.Cells(r, 1).Value = "Y" Then 862 | ' on first step - remember value in variable 863 | sClient = IIf(.ListColumns("Client").DataBodyRange.Cells(r, 1).Value = vbNullString, _ 864 | Me.Names("CP_GENERAL_CLIENT").RefersToRange.Value, _ 865 | .ListColumns("Client").DataBodyRange.Cells(r, 1).Value) 866 | Else 867 | ' second and further steps - compare each row with value in variable 868 | If sClient <> IIf(.ListColumns("Client").DataBodyRange.Cells(r, 1).Value = vbNullString, _ 869 | Me.Names("CP_GENERAL_CLIENT").RefersToRange.Value, _ 870 | .ListColumns("Client").DataBodyRange.Cells(r, 1).Value) And _ 871 | .ListColumns("Refresh?").DataBodyRange.Cells(r, 1).Value = "Y" Then 872 | bMultiLogonMode = True 873 | LogOn_DataSources = True 874 | Exit Function 875 | End If 876 | End If 877 | 878 | ' Dictionary of Systems 879 | sSystem = IIf(.ListColumns("System").DataBodyRange.Cells(r, 1).Value = vbNullString, _ 880 | Me.Names("CP_GENERAL_SYSTEM").RefersToRange.Value, _ 881 | .ListColumns("System").DataBodyRange.Cells(r, 1).Value) 882 | If Not dicSystems.exists(sSystem & "+" & sClient) Then 883 | dicSystems.Add sSystem & "+" & sClient, .ListColumns("Data Source").DataBodyRange.Cells(r, 1).Value 884 | End If 885 | 886 | End If ' row in Scope, System and Language is not null 887 | Next r ' row of table 'data sources' 888 | 889 | ' if here - same language in all rows 890 | bMultiLogonMode = False ' just in case 891 | ' only one language is used - that defined in General settings 892 | ' call usual logon - for any data source 893 | 894 | ' we checked that Scope contains same User and same Language 895 | ' it means that we can logon to all systems at once 896 | For Each Key In dicSystems.keys 897 | 'Debug.Print Now, CStr(dicSystems.Item(Key)), Application.Run("SAPGetProperty", "IsDataSourceActive", CStr(dicSystems.Item(Key))) 898 | 899 | ' 'arrDS(1, enumDataSource.DS_ID), 900 | If Run("SapLogon", _ 901 | CStr(dicSystems.Item(Key)), _ 902 | Split(Key, "+")(1), _ 903 | sUser, _ 904 | GetPassword(CStr(Split(Key, "+")(0)), _ 905 | sUser), _ 906 | sLanguage) = 0 Then 907 | 908 | Debug.Print Now, "Couldn't log on to the system '" & CStr(dicSystems.Item(Key)) & "'" 909 | If bManualRefresh Then 910 | Stop 911 | End If 912 | Exit Function ' leave Log_On_Systems as False 913 | Else 914 | LogOn_DataSources = True 915 | Exit Function 916 | End If 917 | Next Key ' of dicSystems - dictionary with list of systems in Scope 918 | 919 | End If ' if table 'data source' is not empty 920 | End With 921 | 922 | Exit_Sub: 923 | Exit Function 924 | ErrHandler: 925 | Debug.Print Now, "LogOn Data Sources", Err.Number, Err.Description 926 | Application.ScreenUpdating = True 927 | Application.Cursor = xlDefault 928 | If bManualRefresh Then Stop 929 | 930 | GoTo Exit_Sub 931 | Resume 932 | End Function 933 | 934 | Private Function GetPassword(system As String, username As String) As String 935 | ' Expected txt file with structure 936 | ' SYSTEM;USERNAME;PASSWORD 937 | ' Sample: 938 | ' P01;ivan;12345 939 | ' P01; ivan; 23456 940 | ' spaces will be trimmed, case doesn't matter (only in password) 941 | 942 | Dim objFile As Object 943 | Dim strLine As String 944 | 945 | On Error GoTo ErrHandler 946 | If objFSO Is Nothing Then Set objFSO = CreateObject("Scripting.FileSystemObject") 947 | 948 | On Error Resume Next 949 | Set objFile = objFSO.OpenTextFile(Me.Names("CP_PASSWORDS_PATH").RefersToRange.Value, ForReading) 950 | If Err.Number <> 0 Then 951 | Err.Clear 952 | Application.EnableEvents = False 953 | Me.Cells(13, 5).Value = "File with passwords not found!" 954 | Me.Cells(13, 5).Font.Color = 3 955 | GoTo Exit_Function 956 | End If 957 | Application.EnableEvents = False 958 | Me.Cells(13, 5).Value = vbNullString 959 | Me.Cells(13, 5).ClearFormats 960 | 961 | On Error GoTo ErrHandler 962 | Do Until objFile.AtEndOfStream 963 | strLine = objFile.ReadLine 964 | If InStr(1, strLine, system, vbTextCompare) > 0 And _ 965 | InStr(1, strLine, username, vbTextCompare) > 0 Then 966 | GetPassword = Trim(Mid(strLine, InStr(InStr(strLine, ";") + 1, strLine, ";") + 1)) 967 | Exit Do ' password found 968 | End If 969 | Loop 970 | 971 | objFile.Close 972 | 973 | Exit_Function: 974 | Set objFSO = Nothing 975 | Set objFile = Nothing 976 | Exit Function 977 | 978 | ErrHandler: 979 | Debug.Print Now, "GetPassword", Err.Number & ": " & Err.Description 980 | Err.Clear 981 | 982 | Application.ScreenUpdating = True 983 | Application.Cursor = xlDefault 984 | Application.EnableEvents = True 985 | ' do not stop when file not found 986 | 'If bManualRefresh Then Stop 987 | 988 | GoTo Exit_Function 989 | Resume 990 | End Function 991 | 992 | Private Function Get_Array_From_Range(rng_ref) 993 | Dim rng_tmp As Range 994 | Dim arr_tmp 995 | If Left(rng_ref, 2) <> "'[" Then ' if not external link 996 | ThisWorkbook.Windows(1).Activate ' Range fails if another workbook is activated 997 | End If 998 | Set rng_tmp = Application.Range(rng_ref) 999 | If rng_tmp.Cells.Count = 1 Then 1000 | ReDim arr_tmp(1 To 1, 1 To 1) 1001 | arr_tmp(1, 1) = rng_tmp.Value 1002 | Else 1003 | arr_tmp = Application.Range(rng_ref) 1004 | End If 1005 | Get_Array_From_Range = arr_tmp 1006 | End Function 1007 | 1008 | Private Sub Write_Log(Msg As String) 1009 | 1010 | If Logs_Enabled Then 1011 | On Error Resume Next 1012 | If objFSO Is Nothing Then _ 1013 | Set objFSO = CreateObject("Scripting.FileSystemObject") 1014 | If objLog Is Nothing Then _ 1015 | Set objLog = CreateObject("Scripting.FileSystemObject") 1016 | 1017 | ' CreatePath LogsFolder ' in case we need to create special path 1018 | If Not objFSO.FileExists(LogFile) Then objFSO.CreateTextFile LogFile 1019 | Set objLog = objFSO.OpenTextFile(LogFile, ForAppending) 1020 | objLog.WriteLine (Now() & "# " & Msg) 1021 | objLog.Close 1022 | End If 1023 | End Sub 1024 | 1025 | Private Function ApplyScopeFilters(scope As String, data_source As String) As Boolean 1026 | Dim arr_var_scope 1027 | Dim arr_var_ds 1028 | Dim arr_var_command 1029 | Dim arr_var_field 1030 | Dim arr_var_value 1031 | Dim arr_var_ref_type 1032 | Dim i As Long 1033 | Dim variable_row As Long 1034 | Dim arrVariableValue 1035 | Dim sVariableValue As String 1036 | 1037 | On Error GoTo ErrHandler 1038 | 1039 | If Me.ListObjects(sTableVariablesName).DataBodyRange Is Nothing Then 1040 | ApplyScopeFilters = True 1041 | Exit Function 1042 | End If 1043 | 1044 | ' define arrays with Variables table columns - faster then read each cell 1045 | With Me.ListObjects(sTableVariablesName) 1046 | ' if sure that more than 1 variable 1047 | ' explanation: http://www.cpearson.com/excel/ArraysAndRanges.aspx 1048 | ' arr_var_ds = .ListColumns("Data Source ID").DataBodyRange.Value 1049 | ' if sure that Excel runs only one workbook - local address 1050 | ' arr_var_ds = Get_Array_From_Range("'" & Split(.ListColumns("Data Source ID").DataBodyRange.Address(External:=True), "]")(1)) 1051 | 1052 | arr_var_scope = Get_Array_From_Range(.ListColumns("Scope").DataBodyRange.Address(external:=True)) 1053 | arr_var_ds = Get_Array_From_Range(.ListColumns("Data Source").DataBodyRange.Address(external:=True)) 1054 | arr_var_command = Get_Array_From_Range(.ListColumns("Command").DataBodyRange.Address(external:=True)) 1055 | arr_var_field = Get_Array_From_Range(.ListColumns("Field").DataBodyRange.Address(external:=True)) 1056 | arr_var_value = Get_Array_From_Range(.ListColumns("Value").DataBodyRange.Address(external:=True)) 1057 | arr_var_ref_type = Get_Array_From_Range(.ListColumns("Reference Type").DataBodyRange.Address(external:=True)) 1058 | End With 1059 | 1060 | ' loop over rows of Variables table 1061 | ' check Scope in each row 1062 | 1063 | Call Run("SAPSetRefreshBehaviour", "Off") 1064 | 1065 | ' two loops, because SetFilters should go before SetVariables (due to PauseVariableSubmit behavior) 1066 | ' Set Filters 1067 | For variable_row = 1 To UBound(arr_var_scope) 1068 | If arr_var_scope(variable_row, 1) = scope And arr_var_ds(variable_row, 1) = data_source Then 1069 | If arr_var_command(variable_row, 1) = "SAPSetFilter" Then 1070 | If arr_var_ref_type(variable_row, 1) = "Range" Then 1071 | 1072 | ' easier then INPUT_STRING_AS_ARRAY? 1073 | ' in this way we can control length of resulting variable, as there is limitaion equal to ~max possible chars in standard Excel cell 1074 | ' ~32000 (including spaces and delimiters) 1075 | On Error Resume Next 1076 | Debug.Print Application.Range(CStr(arr_var_value(variable_row, 1))).Rows.Count 1077 | If Err.Number <> 0 Then 1078 | Debug.Print Now, "Range '" & CStr(arr_var_value(variable_row, 1)) & "' wasn't found" 1079 | If bManualRefresh Then 1080 | Stop 1081 | Else 1082 | GoTo ErrHandler 1083 | End If 1084 | End If 1085 | On Error GoTo ErrHandler 1086 | 1087 | arrVariableValue = Get_Array_From_Range(Application.Range(CStr(arr_var_value(variable_row, 1))).Address(external:=True)) 1088 | For i = 1 To UBound(arrVariableValue) 1089 | sVariableValue = sVariableValue & "; " & arrVariableValue(i, 1) 1090 | Next i 1091 | sVariableValue = Mid(sVariableValue, 3) 1092 | 1093 | ' sVariableValue = "1; 2; 3; .... 90000; ... " 1094 | ' sVariableValue = "!1; !2; !3; .... !90000; ... " 1095 | Else 1096 | sVariableValue = CStr(arr_var_value(variable_row, 1)) 1097 | End If 1098 | 1099 | If Run(arr_var_command(variable_row, 1), _ 1100 | arr_var_ds(variable_row, 1), _ 1101 | arr_var_field(variable_row, 1), _ 1102 | sVariableValue) = 0 Then 1103 | 1104 | Debug.Print Now, "Couldn't apply filter for variable " & CStr(arr_var_field(variable_row, 1)) & " : " & sVariableValue 1105 | Exit Function 1106 | Else 1107 | Application.EnableEvents = False 1108 | ' if successful - keep values 1109 | Me.ListObjects(sTableVariablesName).ListColumns("Last Refresh").DataBodyRange.Cells(variable_row, 1).Value = Now() 1110 | Me.ListObjects(sTableVariablesName).ListColumns("Last Used Value").DataBodyRange.Cells(variable_row, 1).Value = "'" & sVariableValue 1111 | Application.EnableEvents = True 1112 | End If ' successful command 1113 | sVariableValue = vbNullString 1114 | End If ' var command 1115 | End If ' var scope and data source 1116 | Next variable_row 1117 | 1118 | ' Set Variables 1119 | Call Run("SAPExecuteCommand", "PauseVariableSubmit", "On") ' stop re-calculation after Variable change 1120 | 1121 | For variable_row = 1 To UBound(arr_var_ds) 1122 | If arr_var_scope(variable_row, 1) = scope And arr_var_ds(variable_row, 1) = data_source Then 1123 | If arr_var_command(variable_row, 1) = "SAPSetVariable" Then 1124 | If arr_var_ref_type(variable_row, 1) = "Range" Then 1125 | 1126 | On Error Resume Next 1127 | Debug.Print Application.Range(CStr(arr_var_value(variable_row, 1))).Rows.Count 1128 | If Err.Number <> 0 Then 1129 | Debug.Print Now, "Range '" & CStr(arr_var_value(variable_row, 1)) & "' wasn't found" 1130 | If bManualRefresh Then 1131 | Stop 1132 | Else 1133 | GoTo ErrHandler 1134 | End If 1135 | End If 1136 | On Error GoTo ErrHandler 1137 | 1138 | ' easier then INPUT_STRING_AS_ARRAY? 1139 | arrVariableValue = Get_Array_From_Range(Application.Range(CStr(arr_var_value(variable_row, 1))).Address(external:=True)) 1140 | For i = 1 To UBound(arrVariableValue) 1141 | sVariableValue = sVariableValue & "; " & arrVariableValue(i, 1) 1142 | Next i 1143 | sVariableValue = Mid(sVariableValue, 3) 1144 | 1145 | ' sVariableValue = "1; 2; 3; .... 90000; ... " 1146 | ' sVariableValue = "!1; !2; !3; .... !90000; ... " 1147 | Else 1148 | sVariableValue = CStr(arr_var_value(variable_row, 1)) 1149 | End If 1150 | 1151 | If Run(arr_var_command(variable_row, 1), _ 1152 | arr_var_field(variable_row, 1), _ 1153 | sVariableValue, _ 1154 | "INPUT_STRING", _ 1155 | arr_var_ds(variable_row, 1)) = 0 Then 1156 | 1157 | Debug.Print Now, "Couldn't apply filter for variable " & CStr(arr_var_field(variable_row, 1)) & " : " & sVariableValue 1158 | GoTo Exit_Sub 1159 | Else 1160 | Application.EnableEvents = False 1161 | ' if successful - keep values 1162 | Me.ListObjects(sTableVariablesName).ListColumns("Last Refresh").DataBodyRange.Cells(variable_row, 1).Value = Now() 1163 | Me.ListObjects(sTableVariablesName).ListColumns("Last Used Value").DataBodyRange.Cells(variable_row, 1).Value = "'" & sVariableValue 1164 | Application.EnableEvents = True 1165 | End If 1166 | sVariableValue = vbNullString 1167 | End If ' var command 1168 | End If ' var scope and data source 1169 | Next variable_row 1170 | 1171 | ApplyScopeFilters = True 1172 | Exit_Sub: 1173 | Application.ScreenUpdating = True 1174 | Application.Cursor = xlDefault 1175 | Application.EnableEvents = True 1176 | Exit Function 1177 | 1178 | ErrHandler: 1179 | Debug.Print Now, "Apply Filters", Err.Number, Err.Description 1180 | Err.Clear 1181 | 1182 | Application.ScreenUpdating = True 1183 | Application.Cursor = xlDefault 1184 | Application.EnableEvents = True 1185 | If bManualRefresh Then Stop 1186 | 1187 | GoTo Exit_Sub 1188 | Resume ' for debug 1189 | End Function 1190 | 1191 | Private Sub GetArrDS() 1192 | ' sub collects all active data sources 1193 | Dim n As Long 1194 | Dim i As Long 1195 | Dim k As Long 1196 | 1197 | On Error GoTo ErrHandler 1198 | 1199 | If Me.ListObjects(sTableDataSourcesName).DataBodyRange Is Nothing Then Exit Sub 1200 | If Me.Names("CP_SCOPE").RefersToRange.Value = vbNullString Then Exit Sub 1201 | 1202 | ' just sort by Order, if no Order - default order of execution 1203 | Call SortDataSources 1204 | 1205 | ' number of data sources in Scope 1206 | n = WorksheetFunction.CountIf(Me.ListObjects(sTableDataSourcesName).ListColumns("Scope").DataBodyRange, _ 1207 | Me.Names("CP_SCOPE").RefersToRange.Value) 1208 | 1209 | ' n must be equal to MAX value in column Order for corresponding Scope 1210 | k = 1 1211 | ReDim arrDS(n, 12) ' size must be equal to number of parameters, check enumDataSource 1212 | With Me.ListObjects(sTableDataSourcesName) 1213 | For i = 1 To .DataBodyRange.Rows.Count 1214 | ' fill array according to order of execution 1215 | 1216 | ' expected correct value in column Order 1217 | If CStr(.ListColumns("Scope").DataBodyRange.Cells(i, 1).Value) = _ 1218 | CStr(Me.Names("CP_SCOPE").RefersToRange.Value) Then 1219 | 1220 | arrDS(k, enumDataSource.DS_ID) = _ 1221 | .ListColumns("Data Source").DataBodyRange.Cells(i, 1).Value 1222 | 1223 | arrDS(k, enumDataSource.DS_Refresh) = _ 1224 | .ListColumns("Refresh?").DataBodyRange.Cells(i, 1).Value 1225 | 1226 | arrDS(k, enumDataSource.DS_MacrosAfter) = _ 1227 | .ListColumns("Macros After").DataBodyRange.Cells(i, 1).Value 1228 | 1229 | arrDS(k, enumDataSource.DS_CalculateAfter) = _ 1230 | .ListColumns("Calculate After").DataBodyRange.Cells(i, 1).Value 1231 | 1232 | arrDS(k, enumDataSource.DS_Row) = _ 1233 | .ListColumns("Scope").DataBodyRange.Cells(i, 1).Row 1234 | 1235 | arrDS(k, enumDataSource.DS_Sheet) = _ 1236 | .ListColumns("Sheet").DataBodyRange.Cells(i, 1).Value 1237 | 1238 | arrDS(k, enumDataSource.DS_Crosstab) = _ 1239 | .ListColumns("Crosstab").DataBodyRange.Cells(i, 1).Value 1240 | 1241 | arrDS(k, enumDataSource.DS_CallActions) = _ 1242 | .ListColumns("Call Actions").DataBodyRange.Cells(i, 1).Value 1243 | 1244 | arrDS(k, enumDataSource.DS_FillHeaders) = _ 1245 | .ListColumns("Fill Headers").DataBodyRange.Cells(i, 1).Value 1246 | 1247 | ' if empty settings - use General options 1248 | arrDS(k, enumDataSource.DS_System) = _ 1249 | IIf(.ListColumns("System").DataBodyRange.Cells(i, 1).Value = vbNullString, _ 1250 | Me.Names("CP_GENERAL_SYSTEM").RefersToRange.Value, _ 1251 | .ListColumns("System").DataBodyRange.Cells(i, 1).Value) 1252 | 1253 | arrDS(k, enumDataSource.DS_Language) = _ 1254 | IIf(.ListColumns("Language").DataBodyRange.Cells(i, 1) = vbNullString, _ 1255 | Me.Names("CP_GENERAL_LANGUAGE").RefersToRange.Value, _ 1256 | .ListColumns("Language").DataBodyRange.Cells(i, 1).Value) 1257 | 1258 | arrDS(k, enumDataSource.DS_User) = _ 1259 | IIf(.ListColumns("User").DataBodyRange.Cells(i, 1) = vbNullString, _ 1260 | Me.Names("CP_GENERAL_USER").RefersToRange.Value, _ 1261 | .ListColumns("User").DataBodyRange.Cells(i, 1).Value) 1262 | 1263 | arrDS(k, enumDataSource.DS_Client) = _ 1264 | IIf(.ListColumns("Client").DataBodyRange.Cells(i, 1) = vbNullString, _ 1265 | Me.Names("CP_GENERAL_CLIENT").RefersToRange.Value, _ 1266 | .ListColumns("Client").DataBodyRange.Cells(i, 1).Value) 1267 | 1268 | k = k + 1 1269 | End If 1270 | Next i 1271 | End With ' DATA SOURCES table 1272 | 1273 | Exit_Sub: 1274 | Exit Sub 1275 | 1276 | ErrHandler: 1277 | Debug.Print Now, "GetArrDS", Err.Number & ": " & Err.Description 1278 | Err.Clear 1279 | Application.ScreenUpdating = True 1280 | Application.Cursor = xlDefault 1281 | Application.EnableEvents = True 1282 | If bManualRefresh Then Stop 1283 | GoTo Exit_Sub 1284 | Resume 'debug 1285 | End Sub 1286 | 1287 | Sub LogOffBOA() 1288 | On Error Resume Next 1289 | Call Run("SAPLogOff", False) ' disconnect 1290 | End Sub 1291 | 1292 | Private Function CreatePath(NewPath As String) As Boolean 1293 | ' Function possibly will be used for logging 1294 | ' create path to Logs 1295 | Dim sPath As String 1296 | 'Add a trailing slash if none 1297 | sPath = NewPath & IIf(Right$(NewPath, 1) = "\", "", "\") 1298 | 1299 | 'Call API 1300 | If MakeSureDirectoryPathExists(sPath) <> 0 Then 1301 | 'No errors, return True 1302 | CreatePath = True 1303 | End If 1304 | 1305 | End Function 1306 | 1307 | ' *********************************************************************************** 1308 | ' * COLLECTION OF VARIABLES * 1309 | ' * * 1310 | ' *********************************************************************************** 1311 | 1312 | ' Author: Ivan Bondarenko 1313 | ' Release date: 2017-01 1314 | ' https://bondarenkoivan.wordpress.com 1315 | ' https://linkedin.com/in/bondarenkoivan/en 1316 | 1317 | ' + inspiration from https://blogs.sap.com/2017/02/03/analysis-for-office-variables-and-filters-via-vba/ 1318 | 1319 | Private Sub Collect_Variables() 1320 | ' sub will add data sources and variables into existing tables 1321 | 1322 | Dim arrVar 1323 | Dim arrFilters 1324 | Dim arrDimensions 1325 | Dim r 1326 | Dim r_ds 1327 | Dim i As Long 1328 | Dim Var, Fil, Dimen 1329 | Dim sPassword As String 1330 | Dim sSystem As String 1331 | Dim order As Long 1332 | Dim WhatToCollectResponse As String 1333 | Dim bFirstCollection As Boolean 1334 | 1335 | AskWhatToCollect: 1336 | WhatToCollectResponse = InputBox("Please, specify what you want to collect:" & vbCrLf _ 1337 | & "1 - Variables" & vbCrLf _ 1338 | & "2 - Field (dimension) & Measure Filters" & vbCrLf _ 1339 | & "3 - both", "What to collect?", "1") 1340 | 1341 | If WhatToCollectResponse = vbNullString Then 1342 | Exit Sub 1343 | ElseIf WhatToCollectResponse <> "1" And WhatToCollectResponse <> "2" And WhatToCollectResponse <> "3" Then 1344 | GoTo AskWhatToCollect 1345 | End If 1346 | 1347 | Application.Cursor = xlWait 1348 | Application.ScreenUpdating = False 1349 | 1350 | 'On Error Resume Next 1351 | 'ThisWorkbook.Sheets("Result").ListObjects(sTableVariablesName).DataBodyRange.Rows.Delete 1352 | 'ThisWorkbook.Sheets("Result").ListObjects(sTableDataSourcesName).DataBodyRange.Rows.Delete 1353 | 'On Error GoTo ErrHandler 1354 | 1355 | ' If Application.Workbooks.Count = 1 Then Exit Sub 1356 | ' Call LogOffBOA 1357 | 'Call DefineNamedRangeScope 1358 | 1359 | Application.StatusBar = "Enabling BOA..." 1360 | Call EnableBOA 1361 | Application.StatusBar = vbNullString 1362 | ThisWorkbook.Activate 1363 | 1364 | Call ListObjectDeleteEmptyRows(Me.ListObjects(sTableDataSourcesName)) 1365 | Call ListObjectDeleteEmptyRows(Me.ListObjects(sTableVariablesName)) 1366 | 1367 | If Me.ListObjects(sTableDataSourcesName).DataBodyRange Is Nothing Then 1368 | bFirstCollection = True 1369 | End If 1370 | 1371 | Call GetListOfDS ' get list of Data Sources 1372 | 1373 | order = 1 1374 | If IsArray(arrDS) Then 1375 | ' for each DS in workbook - collect variables 1376 | 'For i = 1 To UBound(arrDS, 1) 1377 | For i = LBound(arrDS, 1) To UBound(arrDS, 1) 1378 | If arrDS(i, enumDataSource.DS_ID) = vbNullString Then GoTo Next_DS 1379 | 1380 | If Not Application.Run("SAPGetProperty", "IsDataSourceActive", arrDS(i, enumDataSource.DS_ID)) Then 1381 | 1382 | Application.StatusBar = "Logging On..." 1383 | Call Application.Run("SapLogon", _ 1384 | CStr(arrDS(i, enumDataSource.DS_ID)), _ 1385 | Me.Names("CP_GENERAL_CLIENT").RefersToRange.Value, _ 1386 | Me.Names("CP_GENERAL_USER").RefersToRange.Value, _ 1387 | GetPassword(Me.Names("CP_GENERAL_SYSTEM").RefersToRange.Value, _ 1388 | Me.Names("CP_GENERAL_USER").RefersToRange.Value), _ 1389 | Me.Names("CP_GENERAL_LANGUAGE").RefersToRange.Value) 1390 | 1391 | Application.StatusBar = "Refreshing..." 1392 | Run "SAPExecuteCommand", "Refresh" 1393 | 1394 | End If 1395 | 1396 | If Application.Run("SAPGetProperty", "IsDataSourceActive", arrDS(i, enumDataSource.DS_ID)) Then 1397 | Application.StatusBar = "Collecting variables and filters..." 1398 | Application.EnableEvents = False 1399 | Set r_ds = Me.ListObjects(sTableDataSourcesName).ListRows.Add(AlwaysInsert:=False) 1400 | 1401 | If bFirstCollection Then 1402 | r_ds.Range.Cells(1, r_ds.Parent.ListColumns("Scope").Index) = "Main" 1403 | End If 1404 | 1405 | r_ds.Range.Cells(1, r_ds.Parent.ListColumns("Sheet").Index) = arrDS(i, enumDataSource.DS_Sheet) ' Sheet Name 1406 | r_ds.Range.Cells(1, r_ds.Parent.ListColumns("Data Source").Index) = arrDS(i, enumDataSource.DS_ID) 1407 | r_ds.Range.Cells(1, r_ds.Parent.ListColumns("Crosstab").Index) = arrDS(i, enumDataSource.DS_Crosstab) 1408 | 1409 | ' hyperlink to corresponding Crosstab 1410 | Me.Hyperlinks.Add Anchor:=r_ds.Range.Cells(1, r_ds.Parent.ListColumns("Crosstab").Index), _ 1411 | Address:="", SubAddress:=arrDS(i, enumDataSource.DS_Crosstab), _ 1412 | TextToDisplay:=arrDS(i, enumDataSource.DS_Crosstab) 1413 | 1414 | r_ds.Range.Cells(1, r_ds.Parent.ListColumns("Data Source Name").Index) = _ 1415 | Application.Run("SapGetSourceInfo", arrDS(i, enumDataSource.DS_ID), "DataSourceName") 1416 | 1417 | r_ds.Range.Cells(1, r_ds.Parent.ListColumns("Query").Index) = _ 1418 | Application.Run("SapGetSourceInfo", arrDS(i, enumDataSource.DS_ID), "QueryTechName") 1419 | 1420 | r_ds.Range.Cells(1, r_ds.Parent.ListColumns("System").Index) = _ 1421 | Application.Run("SapGetSourceInfo", arrDS(i, enumDataSource.DS_ID), "System") 1422 | 1423 | r_ds.Range.Cells(1, r_ds.Parent.ListColumns("Refresh?").Index) = "Y" 1424 | r_ds.Range.Cells(1, r_ds.Parent.ListColumns("Order").Index) = order 1425 | order = order + 1 1426 | Application.EnableEvents = True 1427 | 1428 | If WhatToCollectResponse = "1" Or WhatToCollectResponse = "3" Then 1429 | ' Get Variables 1430 | arrVar = Application.Run("SAPListOfVariables", arrDS(i, enumDataSource.DS_ID), "INPUT_STRING", "PROMPTS") 1431 | 1432 | If IsArray(arrVar) Then 1433 | On Error Resume Next 1434 | Debug.Print arrVar(1, 1) 1435 | If Err.Number <> 0 Then 1436 | Err.Clear 1437 | On Error GoTo 0 1438 | ' 1-dimensional - only 1 variable 1439 | Application.EnableEvents = False 1440 | Set r = Me.ListObjects(sTableVariablesName).ListRows.Add(AlwaysInsert:=False) 1441 | 1442 | If bFirstCollection Then 1443 | r.Range.Cells(1, r.Parent.ListColumns("Scope").Index) = "Main" 1444 | End If 1445 | 1446 | r.Range.Cells(1, r.Parent.ListColumns("Data Source").Index) = arrDS(i, enumDataSource.DS_ID) 1447 | r.Range.Cells(1, r.Parent.ListColumns("Command").Index) = "SAPSetVariable" 1448 | r.Range.Cells(1, r.Parent.ListColumns("Data Source Sheet").Index) = arrDS(i, enumDataSource.DS_Sheet) 1449 | 1450 | r.Range.Cells(1, r.Parent.ListColumns("Field").Index) = _ 1451 | Application.Run("SAPGetVariable", arrDS(i, enumDataSource.DS_ID), arrVar(1), "TECHNICALNAME") 1452 | 1453 | r.Range.Cells(1, r.Parent.ListColumns("Field Name").Index) = arrVar(1) 1454 | r.Range.Cells(1, r.Parent.ListColumns("Value").Index) = "'" & arrVar(2) 1455 | Application.EnableEvents = True 1456 | Else 1457 | ' two-dimentional 1458 | For Var = LBound(arrVar) To UBound(arrVar) 1459 | Application.EnableEvents = False 1460 | Set r = Me.ListObjects(sTableVariablesName).ListRows.Add(AlwaysInsert:=False) 1461 | 1462 | If bFirstCollection Then 1463 | r.Range.Cells(1, r.Parent.ListColumns("Scope").Index) = "Main" 1464 | End If 1465 | 1466 | r.Range.Cells(1, r.Parent.ListColumns("Data Source").Index) = arrDS(i, enumDataSource.DS_ID) 1467 | r.Range.Cells(1, r.Parent.ListColumns("Command").Index) = "SAPSetVariable" 1468 | r.Range.Cells(1, r.Parent.ListColumns("Data Source Sheet").Index) = arrDS(i, enumDataSource.DS_Sheet) 1469 | 1470 | r.Range.Cells(1, r.Parent.ListColumns("Field").Index) = _ 1471 | Application.Run("SAPGetVariable", arrDS(i, enumDataSource.DS_ID), arrVar(Var, 1), "TECHNICALNAME") 1472 | 1473 | r.Range.Cells(1, r.Parent.ListColumns("Field Name").Index) = arrVar(Var, 1) 1474 | r.Range.Cells(1, r.Parent.ListColumns("Value").Index) = "'" & arrVar(Var, 2) 1475 | Application.EnableEvents = True 1476 | Next Var 1477 | End If 1478 | 1479 | Else ' If IsArray(arrVar) Then 1480 | ' if no variables in Data Source 1481 | Application.EnableEvents = False 1482 | Set r = Me.ListObjects(sTableVariablesName).ListRows.Add(AlwaysInsert:=False) 1483 | 1484 | If bFirstCollection Then 1485 | r.Range.Cells(1, r.Parent.ListColumns("Scope").Index) = "Main" 1486 | End If 1487 | 1488 | r.Range.Cells(1, r.Parent.ListColumns("Data Source").Index) = arrDS(i, enumDataSource.DS_ID) 1489 | r.Range.Cells(1, r.Parent.ListColumns("Command").Index) = "SAPSetVariable" 1490 | r.Range.Cells(1, r.Parent.ListColumns("Data Source Sheet").Index) = arrDS(i, enumDataSource.DS_Sheet) 1491 | 1492 | r.Range.Cells(1, r.Parent.ListColumns("Field").Index) = "" 1493 | r.Range.Cells(1, r.Parent.ListColumns("Field Name").Index) = "Not applicable" 1494 | r.Range.Cells(1, r.Parent.ListColumns("Value").Index) = "" 1495 | Application.EnableEvents = True 1496 | End If 1497 | End If ' WhatToCollectResponse = 1 or 3 1498 | 1499 | If WhatToCollectResponse = "2" Or WhatToCollectResponse = "3" Then 1500 | ' Get Filters 1501 | ' arrFilters = Application.Run("SAPListOfEffectiveFilters", arrDS(i, enumDataSource.DS_ID), "INPUT_STRING") 1502 | ' Effective filters also includes variables 1503 | 1504 | ' dynamic filters includes dimensions and measures 1505 | arrFilters = Application.Run("SAPListOfDynamicFilters", arrDS(i, enumDataSource.DS_ID), "INPUT_STRING") 1506 | arrDimensions = Application.Run("SAPListOfDimensions", arrDS(i, enumDataSource.DS_ID)) 1507 | 1508 | If IsArray(arrFilters) Then 1509 | On Error Resume Next 1510 | Debug.Print arrFilters(1, 1) 1511 | If Err.Number <> 0 Then 1512 | Err.Clear 1513 | On Error GoTo 0 1514 | ' 1-dimensional - only 1 variable 1515 | Application.EnableEvents = False 1516 | Set r = Me.ListObjects(sTableVariablesName).ListRows.Add(AlwaysInsert:=False) 1517 | 1518 | If bFirstCollection Then 1519 | r.Range.Cells(1, r.Parent.ListColumns("Scope").Index) = "Main" 1520 | End If 1521 | 1522 | r.Range.Cells(1, r.Parent.ListColumns("Data Source").Index) = arrDS(i, enumDataSource.DS_ID) 1523 | r.Range.Cells(1, r.Parent.ListColumns("Command").Index) = "SAPSetFilter" 1524 | r.Range.Cells(1, r.Parent.ListColumns("Data Source Sheet").Index) = arrDS(i, enumDataSource.DS_Sheet) 1525 | 1526 | For Dimen = LBound(arrDimensions) To UBound(arrDimensions) 1527 | If arrDimensions(Dimen, 2) = arrFilters(1) Then 1528 | r.Range.Cells(1, r.Parent.ListColumns("Field").Index) = arrDimensions(Dimen, 1) ' technical name 1529 | Exit For 1530 | End If 1531 | Next Dimen 1532 | 1533 | r.Range.Cells(1, r.Parent.ListColumns("Field Name").Index) = arrFilters(1) 1534 | r.Range.Cells(1, r.Parent.ListColumns("Value").Index) = "'" & arrFilters(2) 1535 | Application.EnableEvents = True 1536 | Else 1537 | ' 2-deminsional 1538 | For Fil = LBound(arrFilters) To UBound(arrFilters) 1539 | If arrFilters(Fil, 1) <> "Measures" Then 1540 | Application.EnableEvents = False 1541 | Set r = Me.ListObjects(sTableVariablesName).ListRows.Add(AlwaysInsert:=False) 1542 | 1543 | If bFirstCollection Then 1544 | r.Range.Cells(1, r.Parent.ListColumns("Scope").Index) = "Main" 1545 | End If 1546 | 1547 | r.Range.Cells(1, r.Parent.ListColumns("Data Source").Index) = arrDS(i, enumDataSource.DS_ID) 1548 | r.Range.Cells(1, r.Parent.ListColumns("Command").Index) = "SAPSetFilter" 1549 | r.Range.Cells(1, r.Parent.ListColumns("Data Source Sheet").Index) = arrDS(i, enumDataSource.DS_Sheet) 1550 | 1551 | For Dimen = LBound(arrDimensions) To UBound(arrDimensions) 1552 | If arrDimensions(Dimen, 2) = arrFilters(Fil, 1) Then 1553 | r.Range.Cells(1, r.Parent.ListColumns("Field").Index) = arrDimensions(Dimen, 1) ' technical name 1554 | Exit For 1555 | End If 1556 | Next Dimen 1557 | 1558 | r.Range.Cells(1, r.Parent.ListColumns("Field Name").Index) = arrFilters(Fil, 1) 1559 | r.Range.Cells(1, r.Parent.ListColumns("Value").Index) = "'" & arrFilters(Fil, 2) 1560 | Application.EnableEvents = False 1561 | End If ' if measures 1562 | Next Fil 1563 | 1564 | End If 1565 | Else 1566 | 1567 | End If ' If IsArray(arrFilters) 1568 | End If 1569 | Else ' If Application.Run("SAPGetProperty", "IsDataSourceActive", arrDS(i, enumDataSource.DS_ID)) Then 1570 | ' write that DS is not active 1571 | 1572 | End If ' isDataSourceActive 1573 | Next_DS: 1574 | Next i ' next DS in arrDS 1575 | Else 1576 | 1577 | 1578 | End If ' If IsArray(arrDS) Then 1579 | 1580 | Application.EnableEvents = False 1581 | Me.Range(sTableDataSourcesName & "[#All]").RemoveDuplicates Header:=xlYes, _ 1582 | Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19) 1583 | 1584 | Me.Range(sTableVariablesName & "[#All]").RemoveDuplicates Header:=xlYes, _ 1585 | Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12) 1586 | 1587 | Call ListObjectDeleteEmptyRows(Me.ListObjects(sTableDataSourcesName)) 1588 | Call ListObjectDeleteEmptyRows(Me.ListObjects(sTableVariablesName)) 1589 | 1590 | Exit_Sub: 1591 | On Error Resume Next 1592 | Erase arrDS 1593 | Application.Cursor = xlDefault 1594 | 1595 | Application.StatusBar = vbNullString 1596 | Application.EnableEvents = True 1597 | Application.ScreenUpdating = True 1598 | Exit Sub 1599 | 1600 | ErrHandler: 1601 | Debug.Print Now, "Collect_Variables", Err.Number & ": " & Err.Description 1602 | Err.Clear 1603 | Application.ScreenUpdating = True 1604 | Application.Cursor = xlDefault 1605 | Application.EnableEvents = True 1606 | 1607 | If bManualRefresh Then Stop 1608 | GoTo Exit_Sub 1609 | Resume ' for debug 1610 | End Sub 1611 | 1612 | ' *********************************************************************************** 1613 | ' * COLLECTION OF VARIABLES END * 1614 | ' * * 1615 | ' *********************************************************************************** 1616 | 1617 | Private Sub GetListOfDS() 1618 | ' Sub for "collect variables" part 1619 | Dim tmpCrossTabs 1620 | Dim i As Long 1621 | 1622 | ' works for active workbook 1623 | tmpCrossTabs = Application.Run("SAPListOf", "CROSSTABS") 1624 | 1625 | On Error Resume Next 1626 | If Not IsArray(tmpCrossTabs) Then 1627 | MsgBox "Cannot find any BOA Data Source in this workbook." & vbCrLf _ 1628 | & "Such issue was noticed when BO Analysis addin cannot initialize itself." & vbCrLf _ 1629 | & "If you are sure that have Data Sources in this workbook - " & vbCrLf _ 1630 | & "save this file, close Excel completely, check that no Excel process in Task Manager," & vbCrLf _ 1631 | & "open your file and try again." 1632 | Exit Sub 1633 | End If 1634 | Debug.Print tmpCrossTabs(1, 1) ' check if it is 2-dim array (when only 1 DS - response is 1-dim array) 1635 | 1636 | If Err.Number <> 0 Then 1637 | Err.Clear 1638 | On Error GoTo 0 1639 | ' only 1 dimension 1640 | ReDim arrDS(0, 12) 1641 | arrDS(0, enumDataSource.DS_ID) = tmpCrossTabs(3) ' data source ID 1642 | 1643 | On Error Resume Next 1644 | arrDS(0, enumDataSource.DS_Sheet) = ActiveWorkbook.Names("SAP" & tmpCrossTabs(1)).RefersToRange.Parent.Name ' worksheet name 1645 | ' not 100% precise method, can fail if user renamed NamedRange for crosstab 1646 | arrDS(0, enumDataSource.DS_Crosstab) = "SAP" & tmpCrossTabs(1) 1647 | Err.Clear 1648 | On Error GoTo 0 1649 | 1650 | Else 1651 | Err.Clear 1652 | On Error GoTo 0 1653 | ' arrDS = tmpCrossTabs 1654 | ReDim arrDS(UBound(tmpCrossTabs, 1), 12) 1655 | 1656 | For i = 1 To UBound(tmpCrossTabs, 1) 1657 | arrDS(i, enumDataSource.DS_ID) = tmpCrossTabs(i, 3) ' data source ID 1658 | 1659 | On Error Resume Next 1660 | arrDS(i, enumDataSource.DS_Sheet) = ThisWorkbook.Names("SAP" & tmpCrossTabs(i, 1)).RefersToRange.Parent.Name ' worksheet name 1661 | ' not 100% precise method, can fail if user renamed NamedRange for crosstab 1662 | arrDS(i, enumDataSource.DS_Crosstab) = "SAP" & tmpCrossTabs(i, 1) 1663 | Err.Clear 1664 | On Error GoTo 0 1665 | Next i 1666 | 1667 | End If 1668 | 1669 | End Sub 1670 | 1671 | Private Sub ListObjectDeleteEmptyRows(lo As ListObject) 1672 | Dim i As Long 1673 | Dim col As ListColumn 1674 | Dim bNonEmptyFound As Boolean 1675 | If lo.DataBodyRange Is Nothing Then Exit Sub 1676 | i = 1 1677 | ' TODO: replace by loop that ignores columns with hasformula 1678 | 'Do While i <= lo.ListRows.Count 1679 | ' If WorksheetFunction.CountA(lo.ListRows(i).Range) = 0 Then 1680 | ' lo.ListRows(i).Delete 1681 | ' i = i - 1 1682 | ' End If 1683 | ' i = i + 1 1684 | 'Loop 1685 | 1686 | Application.EnableEvents = False 1687 | Application.ScreenUpdating = False 1688 | Do While i <= lo.ListRows.Count 1689 | For Each col In lo.ListColumns 1690 | If col.DataBodyRange.HasFormula Then 1691 | ' skip 1692 | Else 1693 | If lo.DataBodyRange.Cells(i, col.Index).Value <> vbNullString Then 1694 | bNonEmptyFound = True 1695 | Exit For 1696 | End If 1697 | End If 1698 | Next col 1699 | 1700 | If Not bNonEmptyFound Then 1701 | lo.ListRows(i).Delete 1702 | i = i - 1 1703 | End If 1704 | 1705 | i = i + 1 1706 | bNonEmptyFound = False 1707 | Loop 1708 | 1709 | End Sub 1710 | 1711 | Private Sub Callback_BeforeFirstPromptsDisplay(Optional dummy As Variant) 1712 | ' callback is triggered on Data Source Refresh 1713 | ' at than point we know Scope and 'currentDS' stores DS ID 1714 | Dim arr_var_scope 1715 | Dim arr_var_ds 1716 | Dim arr_var_command 1717 | Dim arr_var_field 1718 | Dim arr_var_value 1719 | Dim arr_var_ref_type 1720 | Dim i As Long 1721 | Dim variable_row As Long 1722 | Dim arrVariableValue 1723 | Dim sVariableValue As String 1724 | Dim scope As String 1725 | 1726 | Debug.Print Now, "Callback_BeforeFirstPromptsDisplay" 1727 | scope = CStr(Me.Names("CP_SCOPE").RefersToRange.Value) 1728 | 1729 | ' define arrays with Variables table columns - faster then read each cell 1730 | With Me.ListObjects(sTableVariablesName) 1731 | arr_var_scope = Get_Array_From_Range(.ListColumns("Scope").DataBodyRange.Address(external:=True)) 1732 | arr_var_ds = Get_Array_From_Range(.ListColumns("Data Source").DataBodyRange.Address(external:=True)) 1733 | arr_var_command = Get_Array_From_Range(.ListColumns("Command").DataBodyRange.Address(external:=True)) 1734 | arr_var_field = Get_Array_From_Range(.ListColumns("Field").DataBodyRange.Address(external:=True)) 1735 | arr_var_value = Get_Array_From_Range(.ListColumns("Value").DataBodyRange.Address(external:=True)) 1736 | arr_var_ref_type = Get_Array_From_Range(.ListColumns("Reference Type").DataBodyRange.Address(external:=True)) 1737 | End With 1738 | 1739 | ' Set Variables 1740 | For variable_row = 1 To UBound(arr_var_ds) 1741 | If arr_var_scope(variable_row, 1) = scope And arr_var_ds(variable_row, 1) = currentDS Then 1742 | If arr_var_command(variable_row, 1) = "SAPSetVariable" Then 1743 | If arr_var_ref_type(variable_row, 1) = "Range" Then 1744 | 1745 | ' easier then INPUT_STRING_AS_ARRAY? 1746 | arrVariableValue = Get_Array_From_Range(Application.Range(CStr(arr_var_value(variable_row, 1))).Address(external:=True)) 1747 | For i = 1 To UBound(arrVariableValue) 1748 | sVariableValue = sVariableValue & "; " & arrVariableValue(i, 1) 1749 | Next i 1750 | sVariableValue = Mid(sVariableValue, 3) 1751 | 1752 | ' sVariableValue = "1; 2; 3; .... 90000; ... " 1753 | ' sVariableValue = "!1; !2; !3; .... !90000; ... " 1754 | Else 1755 | sVariableValue = CStr(arr_var_value(variable_row, 1)) 1756 | End If 1757 | 1758 | Me.ListObjects(sTableVariablesName).ListColumns("Last Refresh").DataBodyRange.Cells(variable_row, 1).Value = Now() 1759 | Me.ListObjects(sTableVariablesName).ListColumns("Last Used Value").DataBodyRange.Cells(variable_row, 1).Value = "'" & sVariableValue 1760 | 1761 | If Run(arr_var_command(variable_row, 1), _ 1762 | arr_var_field(variable_row, 1), _ 1763 | sVariableValue, _ 1764 | "INPUT_STRING", _ 1765 | arr_var_ds(variable_row, 1)) = 0 Then 1766 | 1767 | Debug.Print Now, "Couldn't apply filter for variable " & str(arr_var_field(variable_row, 1)) & " : " & sVariableValue 1768 | GoTo Exit_Sub 1769 | End If 1770 | sVariableValue = vbNullString 1771 | End If ' var command 1772 | End If ' var scope and data source 1773 | Next variable_row 1774 | 1775 | bBeforeFirstPromptsDisplaySubExecuted = True 1776 | Exit_Sub: 1777 | Exit Sub 1778 | 1779 | ErrHandler: 1780 | Debug.Print Now, "Callback_BeforeFirstPromptsDisplay", Err.Number & ": " & Err.Description 1781 | Err.Clear 1782 | 1783 | If bManualRefresh Then Stop 1784 | GoTo Exit_Sub 1785 | Resume 1786 | End Sub 1787 | 1788 | Private Sub Callback_BeforeFirstPromptsDisplay_Reg() 1789 | Dim iRet As Integer 1790 | iRet = Application.Run("SAPExecuteCommand", "RegisterCallback", "BeforeFirstPromptsDisplay", "ControlPanel.Callback_BeforeFirstPromptsDisplay") 1791 | Debug.Print Now, "Callback_BeforeFirstPromptsDisplay_Reg", iRet 1792 | bBeforeFirstPromptsDisplayRegistered = (iRet = 1) 1793 | End Sub 1794 | 1795 | Private Sub Callback_BeforeFirstPromptsDisplay_UnReg() 1796 | Dim iRet As Integer 1797 | iRet = Application.Run("SAPExecuteCommand", "UnRegisterCallback", "BeforeFirstPromptsDisplay", "ControlPanel.Callback_BeforeFirstPromptsDisplay") 1798 | Debug.Print Now, "Callback_BeforeFirstPromptsDisplay_UnReg", iRet 1799 | End Sub 1800 | 1801 | Private Function IsSAPSetVariablesOnly(ds As String) As Boolean 1802 | IsSAPSetVariablesOnly = True ' by default 1803 | With Me.ListObjects(sTableVariablesName) 1804 | If Not .DataBodyRange Is Nothing Then 1805 | IsSAPSetVariablesOnly = (WorksheetFunction.CountIfs(.ListColumns("Scope").DataBodyRange, Me.Names("CP_SCOPE").RefersToRange.Value, _ 1806 | .ListColumns("Data Source").DataBodyRange, ds, _ 1807 | .ListColumns("Command").DataBodyRange, "SAPSetFilter") = 0) 1808 | End If 1809 | End With 1810 | End Function 1811 | 1812 | Private Function IsRepeatRefreshOn(ds As String) As Boolean 1813 | With Me.ListObjects(sTableDataSourcesName) 1814 | If Not .DataBodyRange Is Nothing Then 1815 | IsRepeatRefreshOn = (WorksheetFunction.CountIfs(.ListColumns("Scope").DataBodyRange, Me.Names("CP_SCOPE").RefersToRange.Value, _ 1816 | .ListColumns("Data Source").DataBodyRange, ds, _ 1817 | .ListColumns("Repeat Refresh"), "Y") = 1) 1818 | End If 1819 | End With 1820 | End Function 1821 | 1822 | ' http://www.fmsinc.com/microsoftaccess/modules/examples/avoiddoevents.asp 1823 | Private Sub WaitSeconds(intSeconds As Integer) 1824 | Dim datTime As Date 1825 | Dim sStatusBarInitial As String 1826 | Dim k As Integer 1827 | Dim bScreenUpdatingInitial As Boolean 1828 | Dim CursorInitial As Double 1829 | 1830 | With Application 1831 | bScreenUpdatingInitial = .ScreenUpdating 1832 | CursorInitial = .Cursor 1833 | sStatusBarInitial = IIf(.StatusBar <> False, .StatusBar, vbNullString) 1834 | 1835 | .ScreenUpdating = False 1836 | .Cursor = xlWait 1837 | End With 1838 | 1839 | datTime = DateAdd("s", intSeconds, Now) 1840 | Do 1841 | ' 255 chars is limit of status bar 1842 | If Len(Application.StatusBar) + Len(CStr(CStr(intSeconds - k)) & "...") > 255 Then 1843 | Application.StatusBar = Left(Left(sStatusBarInitial, 255 - Len(CStr(intSeconds - k) & "...") - 1) _ 1844 | & " " & CStr(intSeconds - k) & "...", 255) 1845 | Else 1846 | Application.StatusBar = sStatusBarInitial & " " & CStr(intSeconds - k) & "..." 1847 | End If 1848 | ' Yield to other programs (better than using DoEvents which eats up all the CPU cycles) 1849 | Sleep 1000 1850 | If Me.Names("CP_USE_DOEVENTS").RefersToRange.Value = "Y" Then 1851 | DoEvents 1852 | End If 1853 | k = k + 1 1854 | Loop Until Now >= datTime 1855 | 1856 | With Application 1857 | .StatusBar = sStatusBarInitial 1858 | .ScreenUpdating = bScreenUpdatingInitial 1859 | .Cursor = CursorInitial 1860 | End With 1861 | End Sub 1862 | 1863 | ' **************************** ACTIONS HANDLER **************************** 1864 | ' ************************************************************************* 1865 | Private Sub Actions_Trigger() 1866 | ' test 1867 | 'Actions_Handler_Manual 1868 | Call Actions_Handler("3") 1869 | End Sub 1870 | 1871 | Function Actions_Handler_Manual(Optional ActionID As String) As Boolean 1872 | bManualRefresh = True 1873 | Call Actions_Handler 1874 | End Function 1875 | 1876 | Function Actions_Handler(Optional ActionID As String) As Boolean 1877 | ' go row by row of actions table, read parameters and call corresponding procedures 1878 | Dim row_id As Long 1879 | Dim sPath As String 1880 | Dim rSearchResult As Range 1881 | Dim i As Long 1882 | 1883 | On Error GoTo ErrHandler 1884 | Debug.Print Now, "Actions Handler " & ActionID 1885 | 1886 | With Me.ListObjects(STableActions) 1887 | 1888 | If .DataBodyRange Is Nothing Then Exit Function 1889 | 1890 | Me.UsedRange.Calculate ' re-calc all formulas on ControlPanel 1891 | 1892 | If ActionID <> vbNullString Then 1893 | ' range.find doesn't work when table is hidden 1894 | 'Set rSearchResult = .ListColumns("Action ID").DataBodyRange.Find(ActionID, , xlValues, xlWhole) 1895 | For i = 1 To .DataBodyRange.Rows.Count 1896 | If CStr(.ListColumns("Action ID").DataBodyRange.Cells(i, 1).Value) = ActionID Then 1897 | Set rSearchResult = .DataBodyRange.Rows(i) 1898 | Exit For 1899 | End If 1900 | Next i 1901 | 1902 | If Not rSearchResult Is Nothing Then 1903 | currentActionRowId = rSearchResult.Row - .HeaderRowRange.Row 1904 | Call Action_Handler(currentActionRowId) 1905 | Exit Function 1906 | End If 1907 | End If 1908 | 1909 | For row_id = 1 To .DataBodyRange.Rows.Count 1910 | currentActionRowId = row_id 1911 | ' skip disabled actions 1912 | If .ListColumns("Enabled").DataBodyRange.Cells(row_id, 1).Value = "Y" Then 1913 | Call Action_Handler(currentActionRowId) 1914 | End If 1915 | Next row_id 1916 | End With ' Me.ListObjects(STableActions) 1917 | 1918 | Actions_Handler = True 1919 | 1920 | Exit_Sub: 1921 | 1922 | Exit Function 1923 | 1924 | ErrHandler: 1925 | Debug.Print Now, Err.Number, Err.Description 1926 | Err.Clear 1927 | If bManualRefresh Then Stop 1928 | 1929 | GoTo Exit_Sub 1930 | Resume ' for debug 1931 | End Function 1932 | 1933 | Function Action_Handler(row_id As Long) As Boolean 1934 | On Error GoTo ErrHandler 1935 | Debug.Print Now, "Action Handler " & row_id 1936 | 1937 | With Me.ListObjects(STableActions) 1938 | If .ListColumns("Action").DataBodyRange.Cells(row_id, 1).Value = "Save As & Email" Then 1939 | ' prepare file for email 1940 | Application.StatusBar = CStr(Me.Names("CP_SCOPE").RefersToRange.Value) & ": Save As & Email" 1941 | Call Process_Email(row_id) 1942 | 1943 | ElseIf .ListColumns("Action").DataBodyRange.Cells(row_id, 1).Value = "Refresh All" Then 1944 | ' special function as update is complex operation 1945 | Application.StatusBar = CStr(Me.Names("CP_SCOPE").RefersToRange.Value) & ": Refresh All" 1946 | Call RefreshWorkbook 1947 | 1948 | ElseIf .ListColumns("Action").DataBodyRange.Cells(row_id, 1).Value = "Save As" Then 1949 | Application.StatusBar = CStr(Me.Names("CP_SCOPE").RefersToRange.Value) & ": Save As" 1950 | Call FileSave_Handler(row_id) 1951 | 1952 | ElseIf .ListColumns("Action").DataBodyRange.Cells(row_id, 1).Value = "Email" Then 1953 | Application.StatusBar = CStr(Me.Names("CP_SCOPE").RefersToRange.Value) & ": Email" 1954 | If .ListColumns("Email Method").DataBodyRange.Cells(row_id, 1).Value = "SMTP" Then 1955 | Call Send_EMail_CDO(Trim(.ListColumns("Email From").DataBodyRange.Cells(row_id, 1).Value), _ 1956 | Trim(.ListColumns("Email To").DataBodyRange.Cells(row_id, 1).Value), _ 1957 | Trim(.ListColumns("Email Subject").DataBodyRange.Cells(row_id, 1).Value), _ 1958 | Trim(.ListColumns("Email Body").DataBodyRange.Cells(row_id, 1).Value), _ 1959 | vbNullString, _ 1960 | Trim(.ListColumns("Email Importancy").DataBodyRange.Cells(row_id, 1).Value), _ 1961 | Trim(.ListColumns("Email CC").DataBodyRange.Cells(row_id, 1).Value), _ 1962 | Trim(.ListColumns("Email BCC").DataBodyRange.Cells(row_id, 1).Value)) 1963 | 1964 | ElseIf .ListColumns("Email Method").DataBodyRange.Cells(row_id, 1).Value = "Outlook" Then 1965 | Application.StatusBar = CStr(Me.Names("CP_SCOPE").RefersToRange.Value) & ": Email" 1966 | 1967 | Call Send_Email_Outlook(Trim(.ListColumns("Email To").DataBodyRange.Cells(row_id, 1).Value), _ 1968 | Trim(.ListColumns("Email Subject").DataBodyRange.Cells(row_id, 1).Value), _ 1969 | Trim(.ListColumns("Email Body").DataBodyRange.Cells(row_id, 1).Value), _ 1970 | vbNullString, _ 1971 | Trim(.ListColumns("Email Importancy").DataBodyRange.Cells(row_id, 1).Value), _ 1972 | Trim(.ListColumns("Email CC").DataBodyRange.Cells(row_id, 1).Value), _ 1973 | Trim(.ListColumns("Email BCC").DataBodyRange.Cells(row_id, 1).Value), _ 1974 | Trim(.ListColumns("Email From").DataBodyRange.Cells(row_id, 1).Value)) 1975 | End If 1976 | 1977 | ElseIf .ListColumns("Action").DataBodyRange.Cells(row_id, 1).Value = "Run Macro" Then 1978 | Application.StatusBar = CStr(Me.Names("CP_SCOPE").RefersToRange.Value) & ": Run Macro" 1979 | On Error Resume Next 1980 | Application.Run .ListColumns("Macro Name").DataBodyRange.Cells(row_id, 1).Value 1981 | Debug.Print Now, "Action_Handler - Run Macro", Err.Number, Err.Description 1982 | Err.Clear 1983 | On Error GoTo ErrHandler 1984 | 1985 | ElseIf .ListColumns("Action").DataBodyRange.Cells(row_id, 1).Value = "Clear Crosstabs" Then 1986 | Application.StatusBar = CStr(Me.Names("CP_SCOPE").RefersToRange.Value) & ": Clear Crosstabs" 1987 | Call ClearCrosstabs 1988 | 1989 | ElseIf .ListColumns("Action").DataBodyRange.Cells(row_id, 1).Value = "Save" Then 1990 | Application.StatusBar = CStr(Me.Names("CP_SCOPE").RefersToRange.Value) & ": Save" 1991 | ' always keep backup of your file !!! 1992 | ThisWorkbook.Save 1993 | 1994 | ElseIf 1 = 2 Then 1995 | 1996 | End If 1997 | End With 1998 | 1999 | Exit_Sub: 2000 | Application.StatusBar = vbNullString 2001 | Exit Function 2002 | 2003 | ErrHandler: 2004 | Debug.Print Now, Err.Number, Err.Description 2005 | Err.Clear 2006 | If bManualRefresh Then Stop 2007 | 2008 | GoTo Exit_Sub 2009 | Resume ' for debug 2010 | End Function 2011 | 2012 | Sub Process_Email(row_id As Long) 2013 | Dim sPath As String 2014 | 2015 | On Error GoTo ErrHandler 2016 | Debug.Print Now, "Process_Email" 2017 | 2018 | ' firstly we have to save file, then attach it to email 2019 | sPath = FileSave_Handler(row_id) ' saves file and return path 2020 | 2021 | If sPath <> vbNullString Then 2022 | With Me.ListObjects(STableActions) 2023 | If .ListColumns("Email Method").DataBodyRange.Cells(row_id, 1).Value = "SMTP" Then 2024 | Call Send_EMail_CDO(Trim(.ListColumns("Email From").DataBodyRange.Cells(row_id, 1).Value), _ 2025 | Trim(.ListColumns("Email To").DataBodyRange.Cells(row_id, 1).Value), _ 2026 | Trim(.ListColumns("Email Subject").DataBodyRange.Cells(row_id, 1).Value), _ 2027 | Trim(.ListColumns("Email Body").DataBodyRange.Cells(row_id, 1).Value), _ 2028 | sPath, _ 2029 | Trim(.ListColumns("Email Importancy").DataBodyRange.Cells(row_id, 1).Value), _ 2030 | Trim(.ListColumns("Email CC").DataBodyRange.Cells(row_id, 1).Value), _ 2031 | Trim(.ListColumns("Email BCC").DataBodyRange.Cells(row_id, 1).Value)) 2032 | 2033 | ElseIf .ListColumns("Email Method").DataBodyRange.Cells(row_id, 1).Value = "Outlook" Then 2034 | Call Send_Email_Outlook(Trim(.ListColumns("Email To").DataBodyRange.Cells(row_id, 1).Value), _ 2035 | Trim(.ListColumns("Email Subject").DataBodyRange.Cells(row_id, 1).Value), _ 2036 | Trim(.ListColumns("Email Body").DataBodyRange.Cells(row_id, 1).Value), _ 2037 | sPath, _ 2038 | Trim(.ListColumns("Email Importancy").DataBodyRange.Cells(row_id, 1).Value), _ 2039 | Trim(.ListColumns("Email CC").DataBodyRange.Cells(row_id, 1).Value), _ 2040 | Trim(.ListColumns("Email BCC").DataBodyRange.Cells(row_id, 1).Value), _ 2041 | .ListColumns("Email From").DataBodyRange.Cells(row_id, 1).Value) 2042 | End If 2043 | End With 2044 | Else 2045 | ' write log - failed to save file 2046 | End If 2047 | 2048 | Exit_Sub: 2049 | 2050 | Exit Sub 2051 | 2052 | ErrHandler: 2053 | ' write log - failed to send email 2054 | Debug.Print Now, Err.Number, Err.Description 2055 | Err.Clear 2056 | If bManualRefresh Then Stop 2057 | 2058 | GoTo Exit_Sub 2059 | Resume ' for debug 2060 | End Sub 2061 | 2062 | Function FileSave_Handler(row_id As Long) As String 2063 | ' returns file path when successful of -1 if not 2064 | Dim sExtension As String 2065 | Dim sFolder As String 2066 | Dim sFileName As String 2067 | Dim sPath As String 2068 | 2069 | ' Possible cases 2070 | ' 1. File Format is not provided - use current workbook's format 2071 | ' 2 if no sheets - send entire workbook 2072 | ' 3. if no Folder - use %temp% 2073 | ' 4 if no file name provided - use name of current workbook 2074 | ' 5 if 'add current datetime' - add 2075 | ' else - use provided file name 2076 | ' if 'add current datetime' - add 2077 | ' else - list of sheets - create workbook with provided sheets 2078 | ' else - depends on provided File Format 2079 | 2080 | On Error GoTo ErrHandler 2081 | Debug.Print Now, "FileSave_Handler" 2082 | FileSave_Handler = FileSave_XOR_Folder(row_id) 2083 | Exit Function 2084 | 2085 | Exit_Sub: 2086 | 2087 | Exit Function 2088 | 2089 | ErrHandler: 2090 | ' write log 2091 | Debug.Print Now, Err.Number, Err.Description 2092 | Err.Clear 2093 | If bManualRefresh Then Stop 2094 | 2095 | FileSave_Handler = vbNullString 2096 | 2097 | GoTo Exit_Sub 2098 | Resume ' for debug 2099 | End Function 2100 | 2101 | Function FileSave_XOR_Folder(row_id As Long) As String 2102 | Dim sFolder As String 2103 | On Error GoTo ErrHandler 2104 | 2105 | With Me.ListObjects(STableActions) 2106 | If Trim(.ListColumns("Folder / Workspace").DataBodyRange.Cells(row_id, 1).Value) = vbNullString Then 2107 | ' no Folder - use %temp% directory 2108 | sFolder = Environ("temp") & "\" 2109 | Else 2110 | sFolder = .ListColumns("Folder / Workspace").DataBodyRange.Cells(row_id, 1).Value 2111 | If Left(sFolder, 1) = "%" And Right(sFolder, 1) = "%" Then 2112 | If sFolder = "%temp%" Then 2113 | sFolder = Environ("temp") & "\" 2114 | Else 2115 | sFolder = CreateObject("WScript.Shell").SpecialFolders(Replace(sFolder, "%", vbNullString)) & "\" 2116 | End If 2117 | End If 2118 | If Left(sFolder, 4) = "http" Then 2119 | If Right(sFolder, 1) <> "/" Then: sFolder = sFolder & "/" 2120 | Else 2121 | ' not http folder 2122 | If Right(sFolder, 1) <> "\" Then: sFolder = sFolder & "\" 2123 | End If 2124 | End If ' check Folder / Workspace 2125 | End With 2126 | 2127 | 'If Left(sFolder, 4) = "http" Then 2128 | ' sFolder = WorksheetFunction.EncodeURL(sFolder) 2129 | 'End If 2130 | 2131 | FileSave_XOR_Folder = FileSave_XOR_FileName(row_id, sFolder) 2132 | 2133 | Exit_Sub: 2134 | 2135 | Exit Function 2136 | 2137 | ErrHandler: 2138 | ' write log 2139 | Debug.Print Now, Err.Number, Err.Description 2140 | Err.Clear 2141 | If bManualRefresh Then Stop 2142 | 2143 | FileSave_XOR_Folder = vbNullString 2144 | 2145 | GoTo Exit_Sub 2146 | Resume ' for debug 2147 | End Function 2148 | 2149 | Function FileSave_XOR_FileName(row_id As Long, sFolder As String) As String 2150 | Dim sFileName As String 2151 | 2152 | On Error GoTo ErrHandler 2153 | 2154 | With Me.ListObjects(STableActions) 2155 | If Trim(.ListColumns("File Name").DataBodyRange.Cells(row_id, 1).Value) = vbNullString Then 2156 | ' if no file name provided - use name of current workbook 2157 | sFileName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) 2158 | Else 2159 | ' use provided name 2160 | sFileName = ReplaceIllegalChar(.ListColumns("File Name").DataBodyRange.Cells(row_id, 1).Value) 2161 | End If ' File Name 2162 | End With 2163 | 2164 | FileSave_XOR_FileName = FileSave_XOR_DateTime(row_id, sFolder, sFileName) 2165 | Exit_Sub: 2166 | 2167 | Exit Function 2168 | 2169 | ErrHandler: 2170 | ' write log 2171 | Debug.Print Now, Err.Number, Err.Description 2172 | Err.Clear 2173 | If bManualRefresh Then Stop 2174 | 2175 | FileSave_XOR_FileName = vbNullString 2176 | 2177 | GoTo Exit_Sub 2178 | Resume ' for debug 2179 | End Function 2180 | 2181 | Function FileSave_XOR_DateTime(row_id As Long, sFolder As String, sFileName As String) As String 2182 | Dim sFileNameNew As String 2183 | 2184 | On Error GoTo ErrHandler 2185 | 2186 | With Me.ListObjects(STableActions) 2187 | If Trim(.ListColumns("Add Current DateTime").DataBodyRange.Cells(row_id, 1).Value) <> vbNullString Then 2188 | ' if 'add current datetime' - add 2189 | sFileNameNew = sFileName & " " & Format(Now(), .ListColumns("Add Current DateTime").DataBodyRange.Cells(row_id, 1).Value) 2190 | Else 2191 | sFileNameNew = sFileName 2192 | End If ' Add Current DateTime 2193 | End With 2194 | 2195 | FileSave_XOR_DateTime = FileSave_XOR_Extension(row_id, sFolder, sFileNameNew) 2196 | 2197 | Exit_Sub: 2198 | 2199 | Exit Function 2200 | 2201 | ErrHandler: 2202 | ' write log 2203 | Debug.Print Now, Err.Number, Err.Description 2204 | Err.Clear 2205 | If bManualRefresh Then Stop 2206 | 2207 | FileSave_XOR_DateTime = vbNullString 2208 | 2209 | GoTo Exit_Sub 2210 | Resume ' for debug 2211 | End Function 2212 | 2213 | Function FileSave_XOR_Extension(row_id As Long, sFolder As String, sFileName As String) As String 2214 | Dim sPath As String 2215 | Dim sTmp_path As String 2216 | Dim sTmp_path_xlsx As String 2217 | Dim tmp_wb As Workbook 2218 | Dim sExtension As String 2219 | Dim sh As Worksheet 2220 | Dim i As Integer 2221 | Dim arr 2222 | Dim sResulting_FileFormat As String 2223 | Dim sCSVfiles As String 2224 | Dim sh_id As Integer 2225 | Dim bFound As Boolean 2226 | Dim sFileNameNew As String 2227 | Dim bReadOnlyRecommended As Boolean 2228 | 2229 | On Error GoTo ErrHandler 2230 | Debug.Print Now, "FileSave_XOR_Extension" 2231 | 2232 | ' define parameters 2233 | With Me.ListObjects(STableActions) 2234 | If Trim(.ListColumns("File Format").DataBodyRange.Cells(row_id, 1).Value) = vbNullString Then 2235 | ' take extension of current workbook 2236 | sExtension = Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) - (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) 2237 | Else 2238 | sExtension = "." & .ListColumns("File Format").DataBodyRange.Cells(row_id, 1).Value 2239 | End If 2240 | 2241 | bReadOnlyRecommended = (.ListColumns("ReadOnly Recommended").DataBodyRange.Cells(row_id, 1).Value = "Y") 2242 | End With 2243 | 2244 | 'If Left(sFolder, 4) = "http" Then 2245 | ' sFileName = WorksheetFunction.EncodeURL(sFileName) 2246 | 'End If 2247 | 2248 | ' target path 2249 | sPath = sFolder & sFileName & LCase(sExtension) 2250 | 2251 | ' we cannot modify current workbook for 'SaveAs' and 'Send' actions 2252 | ' must save as new one - ALWAYS 2253 | ' this is the idea of additional actions 2254 | ' only action 'Save' will save current workbook inplace 2255 | ' for 'Saved As' workbook can be requested additional changes 2256 | ' such as 'Delete Sheets', 'Save Sheets', 'Sheets for Formulas to Values' 2257 | ' in addition, depending on 'File Format' we must use proper savinig method, especially PDF and CSV 2258 | 2259 | ' simplest way 2260 | ' if no modification requested, and same extension as current wb 2261 | 'SaveCopyAs doesn't support save to HTTP 2262 | If Left(sFolder, 4) <> "http" Then 2263 | If sExtension = Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) - (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) Then 2264 | With Me.ListObjects(STableActions) 2265 | If Trim(.ListColumns("Save Sheets").DataBodyRange.Cells(row_id, 1).Value) = vbNullString And _ 2266 | Trim(.ListColumns("Delete Sheets").DataBodyRange.Cells(row_id, 1).Value) = vbNullString And _ 2267 | Trim(.ListColumns("Delete WB Queries").DataBodyRange.Cells(row_id, 1).Value) = vbNullString And _ 2268 | Trim(.ListColumns("Sheets for Formulas to Values").DataBodyRange.Cells(row_id, 1).Value) = vbNullString And _ 2269 | Trim(.ListColumns("Save Without Macro").DataBodyRange.Cells(row_id, 1).Value) = vbNullString And _ 2270 | (Not bReadOnlyRecommended) Then 2271 | ' if no modifications then just save 2272 | 'SaveCopyAs doesn't support save to HTTP 2273 | ThisWorkbook.SaveCopyAs sPath 2274 | FileSave_XOR_Extension = sPath 2275 | Exit Function 2276 | End If 2277 | End With 2278 | End If 2279 | End If 2280 | 2281 | ' if method is "Copy/Paste" - applied only to xl* formats 2282 | With Me.ListObjects(STableActions) 2283 | If .ListColumns("Saving Method").DataBodyRange.Cells(row_id, 1).Value = "Copy/Paste" Then 2284 | If Trim(.ListColumns("Save Sheets").DataBodyRange.Cells(row_id, 1).Value) <> vbNullString Then 2285 | ' copy/paste specified sheets to a new workbook 2286 | arr = Split(Trim(.ListColumns("Save Sheets").DataBodyRange.Cells(row_id, 1).Value), ",") 2287 | 2288 | Application.DisplayAlerts = False 2289 | Application.ScreenUpdating = False 2290 | ' transfer worksheets by Copy / Paste 2291 | Set tmp_wb = Application.Workbooks.Add 2292 | For Each sh In ThisWorkbook.Sheets 2293 | For i = LBound(arr) To UBound(arr) 2294 | If Trim(arr(i)) = sh.Name Then 2295 | sh.Activate 2296 | Call CopySheetValues(tmp_wb, sh.Name) 2297 | Exit For ' loop through array 2298 | End If 2299 | Next i 2300 | Next sh 2301 | 2302 | ' delete default worksheets from resulting workbook 2303 | sh_id = 1 2304 | Do While sh_id <= tmp_wb.Sheets.Count 2305 | For i = LBound(arr) To UBound(arr) 2306 | If Trim(arr(i)) = tmp_wb.Sheets(sh_id).Name Then 2307 | bFound = True 2308 | Exit For 2309 | End If 2310 | Next i 2311 | 2312 | If Not bFound Then 2313 | tmp_wb.Sheets(sh_id).Visible = xlSheetVisible 2314 | tmp_wb.Sheets(sh_id).Delete 2315 | sh_id = sh_id - 1 2316 | End If 2317 | sh_id = sh_id + 1 2318 | bFound = False 2319 | Loop 2320 | 2321 | ' jump to last action 2322 | GoTo Saving_Workbook 2323 | Else 2324 | ' nothing is specified - save all sheets ? 2325 | ' not supported so far 2326 | End If 2327 | 2328 | End If ' If .ListColumns("Saving Method").DataBodyRange.Cells(row_id, 1).Value = "Copy/Paste" Then 2329 | End With 2330 | 2331 | Application.DisplayAlerts = False 2332 | Application.ScreenUpdating = False 2333 | ' kind of GUID :), enough for such DIY solution 2334 | sTmp_path = Environ("temp") & "\" & sFileName & " " & Format(Now(), "yyyy-MM-dd hh-mm-ss") & _ 2335 | Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) - (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)) 2336 | ThisWorkbook.SaveCopyAs sTmp_path 2337 | Application.EnableEvents = False ' prevent macro in Workbook_Open 2338 | Application.Calculation = xlCalculationManual 2339 | ' open workbook 2340 | Set tmp_wb = Workbooks.Open(sTmp_path, UpdateLinks:=False) 2341 | 2342 | ' if save without macro - just save as xlsx 2343 | If Me.ListObjects(STableActions).ListColumns("Save Without Macro").DataBodyRange.Cells(row_id, 1).Value = "Y" Then 2344 | sTmp_path_xlsx = Environ("temp") & "\" & sFileName & " " & Format(Now(), "yyyy-MM-dd hh-mm-ss") & ".xlsx" 2345 | tmp_wb.SaveAs sTmp_path_xlsx 2346 | End If 2347 | 2348 | With Me.ListObjects(STableActions) 2349 | If sExtension = ".CSV" Then 2350 | If Trim(.ListColumns("Save Sheets").DataBodyRange.Cells(row_id, 1).Value) <> vbNullString Then 2351 | arr = Split(Trim(.ListColumns("Save Sheets").DataBodyRange.Cells(row_id, 1).Value), ",") 2352 | 2353 | sCSVfiles = vbNullString 2354 | For Each sh In tmp_wb.Sheets 2355 | For i = LBound(arr) To UBound(arr) 2356 | If Trim(arr(i)) = sh.Name Then 2357 | sh.Activate 2358 | 2359 | ' if only one sheet 2360 | If LBound(arr) = UBound(arr) Then 2361 | If Trim(.ListColumns("File Name").DataBodyRange.Cells(row_id, 1).Value) = vbNullString Then 2362 | sFileNameNew = sFileName & " " & ReplaceIllegalChar(sh.Name) 2363 | Else 2364 | sFileNameNew = sFileName 2365 | End If 2366 | Else 2367 | ' many sheets 2368 | ' then have to add Sheet Name to file name provided 2369 | sFileNameNew = sFileName & " " & ReplaceIllegalChar(sh.Name) 2370 | If Left(sFolder, 4) = "http" Then 2371 | 'sFileNameNew = WorksheetFunction.EncodeURL(sFileNameNew) 2372 | sFileNameNew = sFileNameNew 2373 | End If 2374 | End If 2375 | 2376 | Application.DisplayAlerts = False 2377 | Application.ScreenUpdating = False 2378 | 2379 | ' xlCSVUTF8 exists only in newest versions of Excel 2016 2380 | ' clear formats 2381 | sh.Cells.ClearFormats 2382 | tmp_wb.SaveAs sFolder & sFileNameNew & ".csv", FileFormat:=xlCSVUTF8, CreateBackup:=False 2383 | sCSVfiles = sCSVfiles & """" & sFolder & sFileNameNew & ".csv" & """" & "+" 2384 | Exit For 2385 | End If 2386 | Next i 2387 | Next sh 2388 | End If 2389 | 2390 | 2391 | If .ListColumns("Combine CSV files").DataBodyRange.Cells(row_id, 1).Value = "Y" Then 2392 | ' files can be combined by using shell command 2393 | ' copy 1.csv + 2.csv + ... N.csv Resulting.csv 2394 | 2395 | If Left(sFolder, 4) <> "http" Then 2396 | sCSVfiles = Left(sCSVfiles, Len(sCSVfiles) - 1) ' remove last + 2397 | 'Call Shell("cmd.exe /S /K " & "copy " & sCSVfiles & " " & """" & sFolder & sFileName & ".csv" & """", vbNormalFocus) 2398 | Call Shell("cmd.exe /S /C " & "copy " & sCSVfiles & " " & """" & sFolder & sFileName & ".csv" & """", vbNormalFocus) 2399 | ' https://stackoverflow.com/questions/17956651/execute-a-command-in-command-prompt-using-excel-vba 2400 | ' https://stackoverflow.com/questions/15951837/wait-for-shell-command-to-complete 2401 | End If 2402 | 2403 | FileSave_XOR_Extension = sFolder & sFileName & ".csv" 2404 | Else 2405 | ' last file 2406 | FileSave_XOR_Extension = sFolder & sFileNameNew & ".csv" 2407 | End If 2408 | GoTo Close_and_Exit 2409 | ElseIf sExtension = ".PDF" Then 2410 | FileSave_XOR_Extension = Save_Sheets_To_PDF(tmp_wb, _ 2411 | Trim(.ListColumns("Save Sheets").DataBodyRange.Cells(row_id, 1).Value), _ 2412 | sFolder, sFileName) 2413 | GoTo Close_and_Exit 2414 | End If 2415 | End With 2416 | 2417 | ' ************** part of special actions with target workbook ************** 2418 | ' e.g. delete ControlPanel 2419 | ' tmp_wb.Sheets("ControlPanel").Delete 2420 | With Me.ListObjects(STableActions) 2421 | 2422 | ' transform formulas to values for specified sheets 2423 | If Trim(.ListColumns("Sheets for Formulas to Values").DataBodyRange.Cells(row_id, 1).Value) <> vbNullString Then 2424 | arr = Split(Trim(.ListColumns("Sheets for Formulas to Values").DataBodyRange.Cells(row_id, 1).Value), ",") 2425 | 2426 | For Each sh In tmp_wb.Sheets 2427 | For i = LBound(arr) To UBound(arr) 2428 | If Trim(arr(i)) = sh.Name Then 2429 | sh.Activate 2430 | ' TODO: replace only cells with Formulas 2431 | ' to avoid issue with Pivot Tables 2432 | sh.UsedRange.Value = sh.UsedRange.Value 2433 | Exit For 2434 | End If 2435 | Next i 2436 | Next sh 2437 | End If 2438 | 2439 | ' remove unspecified sheets 2440 | If Trim(.ListColumns("Save Sheets").DataBodyRange.Cells(row_id, 1).Value) <> vbNullString Then 2441 | arr = Split(Trim(.ListColumns("Save Sheets").DataBodyRange.Cells(row_id, 1).Value), ",") 2442 | 2443 | sh_id = 1 2444 | Do While sh_id <= tmp_wb.Sheets.Count 2445 | For i = LBound(arr) To UBound(arr) 2446 | If Trim(arr(i)) = tmp_wb.Sheets(sh_id).Name Then 2447 | bFound = True 2448 | Exit For 2449 | End If 2450 | Next i 2451 | 2452 | If Not bFound Then 2453 | tmp_wb.Sheets(sh_id).Visible = xlSheetVisible 2454 | tmp_wb.Sheets(sh_id).Delete 2455 | sh_id = sh_id - 1 2456 | End If 2457 | sh_id = sh_id + 1 2458 | bFound = False 2459 | Loop 2460 | End If 2461 | 2462 | ' delete specified sheets 2463 | If Trim(.ListColumns("Delete Sheets").DataBodyRange.Cells(row_id, 1).Value) <> vbNullString Then 2464 | arr = Split(Trim(.ListColumns("Delete Sheets").DataBodyRange.Cells(row_id, 1).Value), ",") 2465 | 2466 | sh_id = 1 2467 | Do While sh_id <= tmp_wb.Sheets.Count 2468 | For i = LBound(arr) To UBound(arr) 2469 | If Trim(arr(i)) = tmp_wb.Sheets(sh_id).Name Then 2470 | tmp_wb.Sheets(sh_id).Visible = xlSheetVisible 2471 | tmp_wb.Sheets(sh_id).Delete 2472 | sh_id = sh_id - 1 2473 | Exit For 2474 | End If 2475 | Next i 2476 | sh_id = sh_id + 1 2477 | Loop 2478 | End If 2479 | 2480 | ' delete wb queries in target workbook 2481 | If Trim(.ListColumns("Delete WB Queries").DataBodyRange.Cells(row_id, 1).Value) <> vbNullString Then 2482 | Call DeleteQueriesAndConnections(tmp_wb) 2483 | End If 2484 | End With 2485 | 2486 | Application.DisplayAlerts = False 2487 | Application.ScreenUpdating = False 2488 | Saving_Workbook: 2489 | If sExtension = ".xlsx" Then 2490 | sResulting_FileFormat = xlOpenXMLWorkbook 2491 | ElseIf sExtension = ".xlsb" Then 2492 | sResulting_FileFormat = xlExcel12 2493 | ElseIf sExtension = ".xlsm" Then 2494 | sResulting_FileFormat = xlOpenXMLWorkbookMacroEnabled 2495 | ' ElseIf sExtension = ".CSV" Then 2496 | ' sResulting_FileFormat = xlCSV 2497 | End If 2498 | 2499 | tmp_wb.SaveAs sPath, FileFormat:=sResulting_FileFormat, ReadOnlyRecommended:=bReadOnlyRecommended 2500 | 2501 | FileSave_XOR_Extension = sPath 2502 | 2503 | Close_and_Exit: 2504 | 2505 | Exit_Sub: 2506 | Application.Calculation = xlCalculationAutomatic 2507 | On Error Resume Next 2508 | Application.DisplayAlerts = False 2509 | tmp_wb.Close ' in case of error in tmp_wb 2510 | Kill sTmp_path 2511 | If Me.ListObjects(STableActions).ListColumns("Save Without Macro").DataBodyRange.Cells(row_id, 1).Value = "Y" Then 2512 | Kill sTmp_path_xlsx 2513 | End If 2514 | ' just in case 2515 | Application.DisplayAlerts = True 2516 | Application.EnableEvents = True 2517 | Application.ScreenUpdating = True 2518 | Application.Cursor = xlDefault 2519 | Err.Clear 2520 | Exit Function 2521 | 2522 | ErrHandler: 2523 | ' write log 2524 | Debug.Print Now, "FileSave_XOR_Extension", Err.Number, Err.Description; "" 2525 | If bManualRefresh Then Stop 2526 | Err.Clear 2527 | FileSave_XOR_Extension = vbNullString 2528 | 2529 | GoTo Exit_Sub 2530 | Resume ' for debug 2531 | End Function 2532 | 2533 | Function Save_Sheets_To_PDF(Wb As Workbook, sSheets As String, sFolder As String, sFileName As String) 2534 | ' sSheets expected as comma separated list 2535 | Dim arr 2536 | Dim i As Integer 2537 | 2538 | On Error GoTo ErrHandler 2539 | Debug.Print Now, "Save_Sheets_To_PDF" 2540 | If sSheets <> vbNullString Then 2541 | arr = Split(sSheets, ",") 2542 | 2543 | Wb.Activate 2544 | Wb.Sheets(Trim(arr(LBound(arr)))).Select Replace:=True 2545 | For i = LBound(arr) To UBound(arr) 2546 | Wb.Sheets(Trim(arr(i))).Select Replace:=False 2547 | Next i 2548 | 2549 | ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _ 2550 | Filename:=sFolder & sFileName & ".pdf", _ 2551 | Quality:=xlQualityStandard, _ 2552 | IncludeDocProperties:=False, _ 2553 | IgnorePrintAreas:=False, _ 2554 | OpenAfterPublish:=False 2555 | Else 2556 | Wb.Activate 2557 | ActiveWorkbook.ExportAsFixedFormat Type:=xlTypePDF, _ 2558 | Filename:=sFolder & sFileName & ".pdf", _ 2559 | Quality:=xlQualityStandard, _ 2560 | IncludeDocProperties:=False, _ 2561 | IgnorePrintAreas:=False, _ 2562 | OpenAfterPublish:=False 2563 | End If 2564 | 2565 | Save_Sheets_To_PDF = sFolder & sFileName & ".pdf" 2566 | Exit_Sub: 2567 | 2568 | Exit Function 2569 | 2570 | ErrHandler: 2571 | ' write log 2572 | Debug.Print Now, "Save_Sheets_To_PDF", Err.Number, Err.Description 2573 | Save_Sheets_To_PDF = vbNullString 2574 | Err.Clear 2575 | 2576 | If bManualRefresh Then Stop 2577 | GoTo Exit_Sub 2578 | Resume ' for debug 2579 | End Function 2580 | 2581 | Function Send_EMail_CDO(sFrom As String, _ 2582 | sRecipients As String, _ 2583 | sSubject As String, _ 2584 | Optional sMessage As String, _ 2585 | Optional sAttachmentPath As String, _ 2586 | Optional Importance As String = "Normal", _ 2587 | Optional sCC As String, _ 2588 | Optional sBCC As String) 2589 | 2590 | Dim iMsg As Object 2591 | Dim iConf As Object 2592 | Dim strbody As String 2593 | Dim sSendUsing As String 2594 | Dim sAuthentication As String 2595 | Dim Flds 2596 | Dim szServer As String 2597 | 2598 | 'https://www.experts-exchange.com/questions/23044027/CDO-Message-sendusing-and-smtpauthenticate.html 2599 | Const cdoSendUsingPickup = 1 'Send message using the local SMTP service pickup directory. 2600 | Const cdoSendUsingPort = 2 'Send the message using the network (SMTP over the network). 2601 | 2602 | Const cdoAnonymous = 0 'Do not authenticate 2603 | Const cdoBasic = 1 'basic (clear-text) authentication 2604 | Const cdoNTLM = 2 'NTLM 2605 | 2606 | Dim oMyMail As Object 2607 | Dim objShell As Object 2608 | 2609 | On Error GoTo ErrHandler 2610 | 2611 | If Me.Names("CP_STMP_SERVER").RefersToRange.Value = vbNullString Then 2612 | If bManualRefresh Then 2613 | MsgBox "Please, provide SMTP server!", vbExclamation 2614 | ThisWorkbook.Activate 2615 | Me.Names("CP_STMP_SERVER").RefersToRange.Select 2616 | Application.ScreenUpdating = True 2617 | Application.Cursor = xlDefault 2618 | Application.EnableEvents = True 2619 | Stop 2620 | Else 2621 | Debug.Print Now, "STMP server is not provided! Send CDO failed." 2622 | Exit Function 2623 | End If 2624 | End If 2625 | 2626 | Set objShell = CreateObject("WScript.Shell") 2627 | Set oMyMail = CreateObject("CDO.Message") 2628 | Set iConf = CreateObject("CDO.Configuration") 2629 | Set Flds = iConf.Fields 2630 | szServer = "http://schemas.microsoft.com/cdo/configuration/" 2631 | 2632 | Select Case "Network" '[SETTINGS_SMTP_SENDUSING].Value 2633 | Case "Network" 2634 | sSendUsing = cdoSendUsingPort 2635 | Case "Local Catalog" 2636 | sSendUsing = cdoSendUsingPickup 2637 | End Select 2638 | 2639 | If Trim(Me.Names("CP_SMTP_USER_NAME").RefersToRange.Value) <> vbNullString Then 2640 | sAuthentication = cdoBasic 2641 | Else 2642 | sAuthentication = cdoAnonymous 2643 | End If 2644 | 2645 | With Flds 2646 | .Item(szServer & "sendusing") = sSendUsing 2647 | .Item(szServer & "smtpserver") = Me.Names("CP_STMP_SERVER").RefersToRange.Value 2648 | .Item(szServer & "smtpserverport") = Me.Names("CP_STMP_PORT").RefersToRange.Value 2649 | .Item(szServer & "smtpconnectiontimeout") = 100 '[SETTINGS_SMTP_TIMEOUT].Value ' quick timeout 2650 | .Item(szServer & "smtpauthenticate") = sAuthentication 2651 | .Item(szServer & "smtpusessl") = IIf(Me.Names("CP_USE_SSL").RefersToRange.Value = "Y", True, False) 2652 | 2653 | If sAuthentication = cdoBasic Then 2654 | .Item(szServer & "sendusername") = Trim(Me.Names("CP_SMTP_USER_NAME").RefersToRange.Value) 2655 | 2656 | .Item(szServer & "sendpassword") = GetPassword(Me.Names("CP_STMP_SERVER").RefersToRange.Value, _ 2657 | Me.Names("CP_SMTP_USER_NAME").RefersToRange.Value) 2658 | Else 2659 | .Item(szServer & "smtpauthenticate") = 0 2660 | End If 2661 | .Update 2662 | End With 2663 | 2664 | With oMyMail 2665 | Set .Configuration = iConf 2666 | .bodypart.Charset = "utf-8" 2667 | .To = sRecipients 2668 | .cc = sCC 2669 | .From = IIf(Trim(Me.Names("CP_SMTP_USER_NAME").RefersToRange.Value) <> vbNullString, _ 2670 | Trim(Me.Names("CP_SMTP_USER_NAME").RefersToRange.Value), _ 2671 | IIf(sFrom <> vbNullString, sFrom, "BOA Automation Tool")) 2672 | 2673 | .Subject = sSubject 2674 | 2675 | .htmlbody = Replace(sMessage, Chr(10), "
") 2676 | 2677 | '& vbCrLf & _ 2678 | vbCrLf & _ 2679 | ThisWorkbook.Name & vbCrLf & _ 2680 | objShell.ExpandEnvironmentStrings("%COMPUTERNAME%") 2681 | 2682 | '.CreateMHTMLBody "file://c|/temp/test.htm" 2683 | 2684 | If sAttachmentPath <> vbNullString Then 2685 | .AddAttachment sAttachmentPath 2686 | End If 2687 | 2688 | .Send 2689 | End With 2690 | 2691 | Send_EMail_CDO = True 2692 | 2693 | Exit_Sub: 2694 | Set oMyMail = Nothing 2695 | Set iConf = Nothing 2696 | Set Flds = Nothing 2697 | Exit Function 2698 | 2699 | ErrHandler: 2700 | ' write_log... 2701 | Debug.Print Now, "Send_EMail_CDO", Err.Number, Err.Description 2702 | Err.Clear 2703 | 2704 | If bManualRefresh Then Stop 2705 | GoTo Exit_Sub 2706 | Resume 2707 | End Function 2708 | 2709 | Function Send_Email_Outlook(sRecipients As String, _ 2710 | sSubject As String, _ 2711 | Optional sMessage As String, _ 2712 | Optional sAttachmentPath As String, _ 2713 | Optional Importance As String = "Normal", _ 2714 | Optional sCC As String, _ 2715 | Optional sBCC As String, _ 2716 | Optional sFrom As String) 2717 | 2718 | Dim oOutlook As Object 2719 | Dim oMyMail As Object 2720 | Dim objShell As Object 2721 | 2722 | Const olMailItem = 0 2723 | 2724 | ' get or create outlook 2725 | On Error Resume Next 2726 | Set oOutlook = GetObject(, "Outlook.Application") 2727 | Err.Clear 2728 | 2729 | On Error GoTo ErrHandler 2730 | If oOutlook Is Nothing Then 2731 | Set oOutlook = CreateObject("Outlook.Application") 2732 | End If 2733 | 2734 | Set objShell = CreateObject("WScript.Shell") 2735 | Set oMyMail = oOutlook.CreateItem(olMailItem) 2736 | 2737 | With oMyMail 2738 | If sFrom <> vbNullString Then 2739 | .SentOnBehalfOfName = sFrom 2740 | End If 2741 | 2742 | .To = Replace(sRecipients, ",", ";") 2743 | 2744 | If sCC <> vbNullString Then 2745 | .cc = Replace(sCC, ",", ";") 2746 | End If 2747 | If sBCC <> vbNullString Then 2748 | .Bcc = Replace(sBCC, ",", ";") 2749 | End If 2750 | 2751 | .Subject = sSubject 2752 | .BodyFormat = 2 ' olFormatHTML 2753 | 2754 | .htmlbody = sMessage 2755 | '& vbCrLf & _ 2756 | vbCrLf & _ 2757 | ThisWorkbook.Name & vbCrLf & _ 2758 | objShell.ExpandEnvironmentStrings("%COMPUTERNAME%") 2759 | 2760 | If sAttachmentPath <> vbNullString Then 2761 | .Attachments.Add sAttachmentPath 2762 | End If 2763 | 2764 | ' Normal importance is default 2765 | Select Case Importance 2766 | Case "High" 2767 | .Importance = enumMailImportance.High 2768 | Case "Low" 2769 | .Importance = enumMailImportance.Low 2770 | End Select 2771 | 2772 | .Send 2773 | End With 2774 | 2775 | Send_Email_Outlook = True 2776 | 2777 | Exit_Sub: 2778 | Set oMyMail = Nothing 2779 | Set oOutlook = Nothing 2780 | Exit Function 2781 | 2782 | ErrHandler: 2783 | ' write_log... 2784 | Debug.Print Now, "Send_Email_Outlook", Err.Number, Err.Description 2785 | Err.Clear 2786 | 2787 | If bManualRefresh Then Stop 2788 | GoTo Exit_Sub 2789 | Resume 2790 | End Function 2791 | 2792 | Function ReplaceIllegalChar(strIn As String) As String 2793 | ' https://www.experts-exchange.com/questions/28025657/Vba-Code-Eliminate-Illegal-Characters-from-a-filename.html 2794 | ' adjusted to own char list 2795 | Dim j As Integer 2796 | Dim varStr As String, xStr As String 2797 | varStr = strIn 2798 | For j = 1 To Len(varStr) 2799 | Select Case Asc(Mid(varStr, j, 1)) 2800 | ' excuded resticted characters for OneDrive 2801 | 2802 | Case 32, 38, 39, 43, 45, 46, 48 To 57, 61, 64 To 91, 93 To 123, 125 To 126, 130 To 142, 145 To 151, 153 To 156, 158 To 255 2803 | xStr = xStr & Mid(varStr, j, 1) 2804 | Case Else 2805 | xStr = xStr & "_" 2806 | End Select 2807 | Next 2808 | ReplaceIllegalChar = xStr 2809 | End Function 2810 | 2811 | Function RefreshWorkbook(Optional Wb As Workbook) As Boolean 2812 | Dim cnct As Variant 2813 | Dim slc As SlicerCache 2814 | Dim BeforeAction 2815 | Dim target_wb As Workbook 2816 | Dim bCubeFormulasFound As Boolean 2817 | Dim bScreenUpdatingInitial As Boolean 2818 | Dim bEnableEventsInitial As Boolean 2819 | Dim CalcModeInitial As Double 2820 | Dim CursorStateInitial As Double 2821 | 2822 | On Error GoTo ErrHandler 2823 | Debug.Print Now, "Updating connections..." 2824 | 2825 | With Application 2826 | bScreenUpdatingInitial = .ScreenUpdating 2827 | bEnableEventsInitial = .EnableEvents 2828 | CalcModeInitial = .Calculation 2829 | CursorStateInitial = .Cursor 2830 | 2831 | ' switch everything off 2832 | .ScreenUpdating = False 2833 | .EnableEvents = False 2834 | .Calculation = xlCalculationManual 2835 | .Cursor = xlWait 2836 | End With 2837 | 2838 | If Wb Is Nothing Then 2839 | Set target_wb = ThisWorkbook 2840 | Else 2841 | Set target_wb = Wb 2842 | End If 2843 | 2844 | On Error Resume Next 2845 | If IsError(target_wb.Model.ModelTables.Count) Then 2846 | ' cannot access model 2847 | ' do nothing 2848 | Else 2849 | If target_wb.Model.ModelTables.Count > 0 Then 2850 | Application.StatusBar = "Initializing Data Model..." 2851 | target_wb.Model.Initialize 2852 | WaitSeconds 5 2853 | End If 2854 | End If 2855 | 2856 | Err.Clear 2857 | On Error GoTo ErrHandler 2858 | 2859 | ' deny background refresh 2860 | ' ToThink - probably worth to restore initial settings 2861 | ' however, if workbook is done for Power Refresh solution, it should not contain "background" connections 2862 | ' create 2D array, restore settings after update 2863 | Application.StatusBar = "Switching off background refresh..." 2864 | For Each cnct In target_wb.Connections 2865 | Select Case cnct.Type 2866 | Case xlConnectionTypeODBC 2867 | cnct.ODBCConnection.BackgroundQuery = False 2868 | Case xlConnectionTypeOLEDB 2869 | cnct.OLEDBConnection.BackgroundQuery = False 2870 | End Select 2871 | Next cnct 2872 | 2873 | Application.StatusBar = "Refreshing Data Model and Connections..." 2874 | target_wb.RefreshAll 2875 | WaitSeconds 1 2876 | Application.CalculateUntilAsyncQueriesDone 2877 | WaitSeconds 1 2878 | 2879 | For Each cnct In target_wb.Connections 2880 | Select Case cnct.Type 2881 | Case xlConnectionTypeODBC 2882 | Do While cnct.ODBCConnection.Refreshing 2883 | WaitSeconds 1 2884 | Loop 2885 | Case xlConnectionTypeOLEDB 2886 | Do While cnct.OLEDBConnection.Refreshing 2887 | WaitSeconds 1 2888 | Loop 2889 | End Select 2890 | Next cnct 2891 | 2892 | Application.StatusBar = "Calculating after connections refresh..." 2893 | Application.Calculate 2894 | Application.CalculateUntilAsyncQueriesDone 2895 | WaitSeconds 1 2896 | 2897 | Application.StatusBar = "Checking existence of cube formulas..." 2898 | bCubeFormulasFound = IsWBHasCubeFormulas(target_wb) 2899 | 2900 | ' update cache after Model refresh 2901 | ' ignore all possible errors with slicers 2902 | On Error Resume Next 2903 | Application.StatusBar = "Updating slicers..." 2904 | For Each slc In target_wb.SlicerCaches 2905 | slc.ClearManualFilter 2906 | slc.ClearAllFilters 2907 | 'slc.ClearDateFilter 2908 | Next slc 2909 | Err.Clear 2910 | On Error GoTo ErrHandler 2911 | ' if needed, slicer default value can be set in BeforeSave event of target workbook, or in custom macro 2912 | 2913 | If bCubeFormulasFound Then 2914 | ' wait for refresh of cube formulas 2915 | If target_wb.SlicerCaches.Count > 0 Then 2916 | Application.StatusBar = "Calculating after slicers refresh..." 2917 | Application.Calculate 2918 | Application.CalculateUntilAsyncQueriesDone 2919 | End If 2920 | 2921 | Application.StatusBar = "Waiting for cube formulas..." 2922 | WaitSeconds 20 2923 | End If 2924 | 2925 | If Not Application.CalculationState = xlDone Then 2926 | ' infinite loop can be trully infinite 2927 | ' so just delay 2928 | Application.StatusBar = "Waiting for application to calculate..." 2929 | WaitSeconds 5 2930 | End If 2931 | 2932 | RefreshWorkbook = True 2933 | 2934 | Exit_Function: 2935 | On Error Resume Next 2936 | 2937 | ' restore initial state 2938 | With Application 2939 | .ScreenUpdating = bScreenUpdatingInitial 2940 | .EnableEvents = bEnableEventsInitial 2941 | .Calculation = CalcModeInitial 2942 | .Cursor = CursorStateInitial 2943 | .StatusBar = vbNullString 2944 | End With 2945 | 2946 | Err.Clear 2947 | Exit Function 2948 | 2949 | ErrHandler: 2950 | Debug.Print Now, "Update Connections", Err.Number, Err.Description, Application.StatusBar 2951 | 2952 | If bManualRefresh Then 2953 | Application.Cursor = xlDefault 2954 | Stop 2955 | End If 2956 | 2957 | Err.Clear 2958 | GoTo Exit_Function 2959 | Resume ' for debug purpose 2960 | End Function 2961 | 2962 | Private Function IsWBHasCubeFormulas(Optional Wb As Workbook) As Boolean 2963 | Dim sh As Worksheet 2964 | Dim cell As Range 2965 | Dim bFound As Boolean 2966 | Dim bScreenUpdatingInitial As Boolean 2967 | Dim bEnableEventsInitial As Boolean 2968 | Dim CalcModeInitial As Integer 2969 | Dim rngFormulas As Range 2970 | 2971 | On Error GoTo ErrHandler 2972 | 2973 | If Wb Is Nothing Then 2974 | Set Wb = ThisWorkbook ' ActiveWorkbook ' alternatively 2975 | End If 2976 | 2977 | With Application 2978 | bScreenUpdatingInitial = .ScreenUpdating 2979 | bEnableEventsInitial = .EnableEvents 2980 | CalcModeInitial = .Calculation 2981 | 2982 | ' switch everything off 2983 | .ScreenUpdating = False 2984 | .EnableEvents = False 2985 | .Calculation = xlCalculationManual 2986 | End With 2987 | 2988 | For Each sh In Wb.Sheets 2989 | 'Debug.Print sh.Name 2990 | 2991 | Err.Clear 2992 | On Error Resume Next 2993 | Set rngFormulas = sh.Cells.SpecialCells(xlCellTypeFormulas) 2994 | bFound = (Err.Number = 0) ' no error, means SpecialCells returned non-empty range 2995 | Err.Clear 2996 | On Error GoTo ErrHandler 2997 | 2998 | ' if result of SpecialCells was non-empty - check formulas 2999 | If bFound Then 3000 | For Each cell In rngFormulas 3001 | 'Debug.Print cell.Formula 3002 | If Left(cell.Formula, 5) = "=CUBE" Then 3003 | IsWBHasCubeFormulas = True 3004 | GoTo Exit_Function 3005 | End If 3006 | Next cell 3007 | End If 3008 | Next sh 3009 | 3010 | Exit_Function: 3011 | On Error Resume Next 3012 | 3013 | ' restore initial state 3014 | With Application 3015 | .ScreenUpdating = bScreenUpdatingInitial 3016 | .EnableEvents = bEnableEventsInitial 3017 | .Calculation = CalcModeInitial 3018 | End With 3019 | 3020 | Err.Clear 3021 | Exit Function 3022 | 3023 | ErrHandler: 3024 | If Err.Number <> 0 Then 3025 | Debug.Print Now, "IsWBHasCubeFormulas", Err.Number & ": " & Err.Description 3026 | Err.Clear 3027 | End If 3028 | 3029 | GoTo Exit_Function 3030 | Resume ' for debug purpose 3031 | End Function 3032 | 3033 | Private Sub ClearCrosstabs() 3034 | Dim r As Long 3035 | 3036 | On Error GoTo ErrHandler 3037 | 3038 | If bCallActionFromDStable Then 3039 | ' do not go through all rows 3040 | ' clear only current ds row 3041 | If Not ThisWorkbook.Names(CStr(arrDS(currentDS_index, enumDataSource.DS_Crosstab))).RefersToRange Is Nothing Then 3042 | With ThisWorkbook.Names(CStr(arrDS(currentDS_index, enumDataSource.DS_Crosstab))).RefersToRange 3043 | If .Rows.Count > 1 Then 3044 | .Offset(1, 0).Resize(.Rows.Count - 1, _ 3045 | .Columns.Count).Clear 3046 | End If 3047 | End With 3048 | End If 3049 | End If 3050 | 3051 | With Me.ListObjects(sTableDataSourcesName) 3052 | If .DataBodyRange Is Nothing Then 3053 | Exit Sub 3054 | Else 3055 | For r = 1 To .DataBodyRange.Rows.Count 3056 | If CStr(.ListColumns("Scope").DataBodyRange.Cells(r, 1).Value) = _ 3057 | CStr(Me.Names("CP_SCOPE").RefersToRange.Value) Then 3058 | 3059 | 'If .ListColumns("Refresh?").DataBodyRange.Cells(r, 1).Value = "Y" And 3060 | If .ListColumns("Clear Crosstab").DataBodyRange.Cells(r, 1).Value = "Y" Then 3061 | ' get range of crosstab 3062 | With ThisWorkbook.Names(.ListColumns("Crosstab").DataBodyRange.Cells(r, 1).Value).RefersToRange 3063 | If .Rows.Count > 1 Then 3064 | .Offset(1, 0).Resize(.Rows.Count - 1, _ 3065 | .Columns.Count).Clear 3066 | 3067 | End If 3068 | End With 3069 | End If 3070 | End If 3071 | Next r ' row of Data Sources table 3072 | End If 3073 | End With 3074 | 3075 | Exit_Sub: 3076 | 3077 | Exit Sub 3078 | 3079 | ErrHandler: 3080 | Debug.Print Now, "ClearCrosstabs", Err.Number, Err.Description 3081 | Err.Clear 3082 | 3083 | If bManualRefresh Then Stop 3084 | GoTo Exit_Sub 3085 | Resume 3086 | End Sub 3087 | 3088 | Private Sub FillHeaders(sCrosstab As String) 3089 | Dim i As Long 3090 | Dim col As Integer 3091 | Dim bStyleMode As Boolean 3092 | Dim bMultiHeaderMode As Boolean 3093 | 3094 | On Error GoTo ErrHandler 3095 | If ThisWorkbook.Names(sCrosstab).RefersToRange Is Nothing Then Exit Sub 3096 | 3097 | With ThisWorkbook.Names(sCrosstab).RefersToRange 3098 | If .Cells(1, 1).Style.Name = "SAPDimensionCell" Then 3099 | bStyleMode = True 3100 | End If ' check style in first cell 3101 | 3102 | If .Rows.Count > 1 Then 3103 | If bStyleMode Then 3104 | If .Cells(2, 1).Style.Name = "SAPDimensionCell" Then 3105 | bMultiHeaderMode = True 3106 | End If 3107 | Else 3108 | If .Cells(1, 1).Value = vbNullString Then 3109 | bMultiHeaderMode = True 3110 | End If 3111 | End If 3112 | End If 3113 | 3114 | ' check first cell is empty - Show Scaling Factor is enabled 3115 | For i = 1 To .Rows.Count 3116 | ' when found non-empty cell in 1st column 3117 | If .Cells(i, 1) <> vbNullString Then 3118 | ' fill columns 3119 | For col = 2 To .Columns.Count 3120 | ' when found empty cell - copy value from prior cell + ' Name' 3121 | If .Cells(i, col).Value = vbNullString Then 3122 | ' when we know style - it is safe method, we don't fill Scaling Factors 3123 | If bStyleMode Then 3124 | If .Cells(i, col).Style.Name = "SAPDimensionCell" Then 3125 | .Cells(i, col).Value = .Cells(i, col - 1).Value & " Name" 3126 | ElseIf .Cells(i, col).Style.Name = "SAPMemberCell" Then 3127 | ' not repeated values of dimensions 3128 | .Cells(i, col).Value = .Cells(i, col - 1).Value 3129 | End If 3130 | Else 3131 | ' when we don't know style - have to check 3132 | If bMultiHeaderMode Then 3133 | ' do not fill if there is something in prev row (possibly header) 3134 | If .Cells(i - 1, col).Value = vbNullString Then 3135 | .Cells(i, col).Value = .Cells(i, col - 1).Value & " Name" 3136 | End If 3137 | Else 3138 | ' only one row - fill all columns 3139 | .Cells(i, col).Value = .Cells(i, col - 1).Value & " Name" 3140 | End If 3141 | End If 3142 | End If ' If .Cells(i, col).Value = vbNullString Then 3143 | Next col 3144 | 3145 | Exit For ' exit when first found line is filled 3146 | Else 3147 | ' first cell is null - fill only when we know cell's style 3148 | If bStyleMode Then 3149 | For col = 2 To .Columns.Count 3150 | If .Cells(i, col).Value = vbNullString And _ 3151 | .Cells(i, col).Style.Name = "SAPMemberCell" Then 3152 | ' for measure headers - fill members of dimensions 3153 | .Cells(i, col).Value = .Cells(i, col - 1).Value 3154 | End If 3155 | Next col 3156 | End If 3157 | End If ' if first row is not null 3158 | Next i 3159 | 3160 | End With 3161 | 3162 | Exit_Sub: 3163 | 3164 | Exit Sub 3165 | 3166 | ErrHandler: 3167 | Debug.Print Now, "FillHeaders", Err.Number, Err.Description 3168 | Err.Clear 3169 | 3170 | If bManualRefresh Then Stop 3171 | GoTo Exit_Sub 3172 | Resume 3173 | End Sub 3174 | 3175 | Private Sub CopySheetValues(target_wb As Workbook, shName As String) 3176 | Dim sh As Worksheet 3177 | 3178 | On Error GoTo ErrHandler 3179 | With ThisWorkbook.Sheets(shName) 3180 | .Activate 3181 | .Range(.Cells(1, 1), .UsedRange.SpecialCells(xlCellTypeLastCell)).Copy 3182 | End With 3183 | 3184 | On Error Resume Next 3185 | target_wb.Sheets(shName).Activate 3186 | If Err.Number <> 0 Then 3187 | Err.Clear 3188 | Set sh = target_wb.Sheets.Add ' (after:=target_wb.Sheets.Count) 3189 | sh.Name = shName 3190 | End If 3191 | 3192 | On Error GoTo ErrHandler 3193 | With target_wb.Sheets(shName) 3194 | .Activate 3195 | With .[A1] 3196 | .PasteSpecial xlPasteValues ' just values 3197 | .PasteSpecial xlPasteColumnWidths 3198 | .PasteSpecial xlPasteFormats ' formats of cells - fill, borders, + Conditional Formatting etc. 3199 | .PasteSpecial xlPasteComments 3200 | End With 3201 | End With 3202 | 3203 | Application.CutCopyMode = False 3204 | Set sh = Nothing 3205 | 3206 | Exit_Sub: 3207 | 3208 | Exit Sub 3209 | 3210 | ErrHandler: 3211 | Debug.Print Now, "CopySheetValues", Err.Number, Err.Description 3212 | Err.Clear 3213 | 3214 | If bManualRefresh Then Stop 3215 | GoTo Exit_Sub 3216 | Resume 3217 | End Sub 3218 | 3219 | 3220 | Private Sub DeleteQueriesAndConnections(target_wb As Workbook) 3221 | 3222 | On Error Resume Next 3223 | Application.Cursor = xlWait 3224 | Application.DisplayAlerts = False 3225 | Application.ScreenUpdating = False 3226 | Do While target_wb.Queries.Count > 0 3227 | target_wb.Queries(1).Delete 3228 | Loop 3229 | 3230 | Do While target_wb.Connections.Count > 0 3231 | If target_wb.Connections(1).Name <> "ThisWorkbookDataModel" Then 3232 | target_wb.Connections(1).Delete 3233 | Else 3234 | If target_wb.Connections.Count = 1 Then Exit Do 3235 | target_wb.Connections(2).Delete 3236 | End If 3237 | Loop 3238 | 3239 | Err.Clear 3240 | End Sub 3241 | 3242 | Private Sub SortDataSources() 3243 | On Error GoTo ErrHandler 3244 | Application.EnableEvents = False 3245 | With Me.ListObjects(sTableDataSourcesName) 3246 | .Sort.SortFields.Clear 3247 | 3248 | .Sort.SortFields.Add Key:=.ListColumns("Scope Order").Range, _ 3249 | SortOn:=xlSortOnValues, _ 3250 | order:=xlAscending, _ 3251 | DataOption:=xlSortNormal 3252 | 3253 | .Sort.SortFields.Add Key:=.ListColumns("Order").Range, _ 3254 | SortOn:=xlSortOnValues, _ 3255 | order:=xlAscending, _ 3256 | DataOption:=xlSortNormal 3257 | 3258 | .Sort.SortFields.Add Key:=.ListColumns("Sheet").Range, _ 3259 | SortOn:=xlSortOnValues, _ 3260 | order:=xlAscending, _ 3261 | DataOption:=xlSortNormal 3262 | 3263 | .Sort.SortFields.Add Key:=.ListColumns("Data Source Name").Range, _ 3264 | SortOn:=xlSortOnValues, _ 3265 | order:=xlAscending, _ 3266 | DataOption:=xlSortNormal 3267 | 3268 | With .Sort 3269 | .Header = xlYes 3270 | .MatchCase = False 3271 | .Orientation = xlTopToBottom 3272 | .SortMethod = xlPinYin 3273 | .Apply 3274 | End With 3275 | End With 3276 | 3277 | Exit_Sub: 3278 | 3279 | Exit Sub 3280 | 3281 | ErrHandler: 3282 | Debug.Print Now, "SortDataSources", Err.Number, Err.Description 3283 | Err.Clear 3284 | Application.ScreenUpdating = True 3285 | Application.Cursor = xlDefault 3286 | Application.EnableEvents = True 3287 | 3288 | If bManualRefresh Then Stop 3289 | GoTo Exit_Sub 3290 | Resume 3291 | End Sub 3292 | 3293 | ' *************************************************** EXPERIMENTAL PROCEDURES *************************************************** 3294 | ' ******************************************************************************************************************************* 3295 | Sub FakeCheckIfNoData(Optional t As String) 3296 | ' use this sub to test how Delay Functionality works 3297 | ' put FakeCheckIfNoData into MacrosAfter settings in data source table 3298 | If dummy = 0 Then 3299 | Me.Names("CP_DELAY").RefersToRange.Value = "Y" 3300 | dummy = 1 3301 | Else 3302 | Me.Names("CP_DELAY").RefersToRange.Value = "N" 3303 | End If 3304 | End Sub 3305 | 3306 | Sub FakeTurnRepeatRefreshOn(Optional t As String) 3307 | ' use this sub to test how Repeat Refresh works 3308 | ' put FakeTurnRepeatRefreshOn into MacrosAfter settings in data source table 3309 | If dummy = 0 Then 3310 | Me.Cells(arrDS(currentDS_index, enumDataSource.DS_Row), _ 3311 | Me.ListObjects(sTableDataSourcesName).ListColumns("Repeat Refresh").Range.Column).Value = "Y" 3312 | dummy = 1 3313 | Else 3314 | Me.Cells(arrDS(currentDS_index, enumDataSource.DS_Row), _ 3315 | Me.ListObjects(sTableDataSourcesName).ListColumns("Repeat Refresh").Range.Column).Value = vbNullString 3316 | End If 3317 | End Sub 3318 | 3319 | Private Sub Style_Remover() 3320 | Dim i As Long 3321 | Application.ScreenUpdating = True 3322 | 'Debug.Print ThisWorkbook.Styles.Count 3323 | 3324 | On Error Resume Next 3325 | For i = 1 To 1000000 3326 | If Not ThisWorkbook.Styles(i).BuiltIn Then 3327 | ThisWorkbook.Styles(i).Delete 3328 | If Err.Number = 0 Then 3329 | i = i - 1 3330 | End If 3331 | Err.Clear 3332 | End If 3333 | Next i 3334 | 3335 | Application.ScreenUpdating = True 3336 | End Sub 3337 | 3338 | Private Sub PrepareForPublishing() 3339 | ' clean tables and cells with parameters 3340 | ' 3341 | Dim i As Long 3342 | 3343 | Call ListObjectDeleteEmptyRows(Me.ListObjects(sTableDataSourcesName)) 3344 | 3345 | On Error Resume Next 3346 | Me.ListObjects(sTableDataSourcesName).DataBodyRange.Delete 3347 | Me.ListObjects(sTableVariablesName).DataBodyRange.Delete 3348 | 3349 | With Me.ListObjects(STableActions).ListColumns("Enabled").DataBodyRange 3350 | For i = 1 To .Rows.Count 3351 | .Cells(i, 1).Value = "N" 3352 | Me.ListObjects(STableActions).ListColumns("Email From").DataBodyRange.Cells(i, 1).Value = vbNullString 3353 | Me.ListObjects(STableActions).ListColumns("Email To").DataBodyRange.Cells(i, 1).Value = vbNullString 3354 | Me.ListObjects(STableActions).ListColumns("Email CC").DataBodyRange.Cells(i, 1).Value = vbNullString 3355 | Next i 3356 | End With 3357 | 3358 | Me.Names("CP_LAST_REPORT_DATE").RefersToRange.Value = vbNullString 3359 | Me.Names("CP_LAST_REFRESH_DATETIME").RefersToRange.Value = vbNullString 3360 | Me.Names("CP_PASSWORDS_PATH").RefersToRange.Value = vbNullString 3361 | Me.Names("CP_GENERAL_USER").RefersToRange.Value = vbNullString 3362 | Me.Names("CP_STMP_SERVER").RefersToRange.Value = vbNullString 3363 | Me.Names("CP_STMP_PORT").RefersToRange.Value = vbNullString 3364 | Me.Names("CP_USE_SSL").RefersToRange.Value = vbNullString 3365 | Me.Names("CP_SMTP_USER_NAME").RefersToRange.Value = vbNullString 3366 | Me.Names("CP_STMP_PORT").RefersToRange.Value = vbNullString 3367 | 3368 | Call Style_Remover 3369 | 3370 | End Sub 3371 | 3372 | Private Sub test() 3373 | Debug.Print Me.PivotTables.Count 3374 | End Sub 3375 | 3376 | Private Sub CreateNames() 3377 | 3378 | Const ReportDateCell = "CP_REPORT_DATE" 3379 | 3380 | On Error Resume Next 3381 | 3382 | ' names must be visible to be used in formulas by end-user 3383 | ' Me.Names("CP_DATE_RDM_START_END_DDMMYYYY").Visible = True 3384 | 3385 | ' Report Date Year 3386 | Me.Names.Add Name:="CP_DATE_RDY", RefersTo:="=YEAR( CP_REPORT_DATE )" 3387 | ' Prior to 'Report Date Month' Year 3388 | Me.Names.Add Name:="CP_DATE_PRDM_YYYY", RefersTo:="=YEAR( EOMONTH( CP_REPORT_DATE, -1) )" 3389 | 3390 | ' Report Date Month 3391 | Call CreateNamesWithFormats("RDM", "EOMONTH( CP_REPORT_DATE, -1 )+1", "EOMONTH( CP_REPORT_DATE, 0 )") 3392 | 3393 | ' Prior to Report Date Month 3394 | Call CreateNamesWithFormats("PRDM", "EOMONTH( CP_REPORT_DATE, -2 )+1", "EOMONTH( CP_REPORT_DATE, -1 )") 3395 | 3396 | ' Prev to Prior to Report Date Month 3397 | Call CreateNamesWithFormats("PPRDM", "EOMONTH( CP_REPORT_DATE, -3 )+1", "EOMONTH( CP_REPORT_DATE, -2 )") 3398 | 3399 | ' Last Two Months Excluding = LTM_EXC 3400 | Call CreateNamesWithFormats("LTM_EXC", "EOMONTH( CP_REPORT_DATE, -3 )+1", "EOMONTH( CP_REPORT_DATE, -1 )") 3401 | 3402 | ' RDM in PY - Same RD month in Prior Year 3403 | Call CreateNamesWithFormats("RDM_IN_PY", "EOMONTH( CP_REPORT_DATE, -13 )+1", "EOMONTH( CP_REPORT_DATE, -12 )") 3404 | 3405 | ' PRDM in PY, 'Prior to RDM' in Prior Year 3406 | Call CreateNamesWithFormats("PRDM_IN_PY", "EOMONTH( CP_REPORT_DATE, -14 )+1", "EOMONTH( CP_REPORT_DATE, -13 )") 3407 | 3408 | ' R12m RDM INC - Rolling 12 months including RDM 3409 | Call CreateNamesWithFormats("R12M_RDM_INC", "EOMONTH( CP_REPORT_DATE, -12 )+1", "EOMONTH( CP_REPORT_DATE, 0 )") 3410 | 3411 | ' R12m RDM EXC - Rolling 12 months to RDM excluding 3412 | Call CreateNamesWithFormats("R12M_RDM_EXC", "EOMONTH( CP_REPORT_DATE, -13 )+1", "EOMONTH( CP_REPORT_DATE, -1 )") 3413 | 3414 | ' R4m RDM INC - Rolling 4 months to RDM including 3415 | Call CreateNamesWithFormats("R4M_RDM_INC", "EOMONTH( CP_REPORT_DATE, -4 )+1", "EOMONTH( CP_REPORT_DATE, 0 )") 3416 | 3417 | ' R4m RDM EXC - Rolling 4 months to RDM including 3418 | Call CreateNamesWithFormats("R4M_RDM_EXC", "EOMONTH( CP_REPORT_DATE, -5 )+1", "EOMONTH( CP_REPORT_DATE, -1 )") 3419 | 3420 | ' CP_DATE_YTD_RDM - YTD to RDM including 3421 | Call CreateNamesWithFormats("YTD_RDM", "DATE( YEAR(CP_REPORT_DATE),1,1)", "EOMONTH( CP_REPORT_DATE, 0 )") 3422 | 3423 | ' CP_DATE_YTD_PRDM - YTD calculated for 'Prior RDM' 3424 | Call CreateNamesWithFormats("YTD_PRDM", "DATE( YEAR(EOMONTH(CP_REPORT_DATE,-1)),1,1)", "EOMONTH( CP_REPORT_DATE, -1 )") 3425 | 3426 | ' YTD PY to RD month - YTD calculated for 'RDM in PY' 3427 | Call CreateNamesWithFormats("YTD_RDM_IN_PY", "DATE( YEAR(CP_REPORT_DATE)-1,1,1)", "EOMONTH( CP_REPORT_DATE, -12 )") 3428 | 3429 | ' YTD PY to prior RD month - YTD calculated for 'PRDM in PY' 3430 | Call CreateNamesWithFormats("YTD_PRDM_IN_PY", "DATE( YEAR(EOMONTH(CP_REPORT_DATE,-1))-1,1,1)", "EOMONTH( CP_REPORT_DATE, -13 )") 3431 | 3432 | ' PY_CY_TO_RDM including. E.g. 01.2016 - 10.2017 3433 | Call CreateNamesWithFormats("PY_CY_TO_RDM", "DATE( YEAR(CP_REPORT_DATE)-1,1,1)", "EOMONTH( CP_REPORT_DATE, 0 )") 3434 | 3435 | ' PY_CY_TO_PRDM including. E.g. 01.2016 - 09.2017 3436 | Call CreateNamesWithFormats("PY_CY_TO_PRDM", "DATE( YEAR(EOMONTH(CP_REPORT_DATE,-1))-1,1,1)", "EOMONTH( CP_REPORT_DATE, -1 )") 3437 | 3438 | ' PY_R12M_RDM, R12m in PY to 'RDM in PY', 11.2015 - 10.2016 3439 | Call CreateNamesWithFormats("PY_R12M_RDM", "EOMONTH( CP_REPORT_DATE, -24 )+1", "EOMONTH( CP_REPORT_DATE, -12 )") 3440 | 3441 | ' PY_R12M_PRDM, R12m in PY to 'RDM in PY', 10.2015 - 09.2016 3442 | Call CreateNamesWithFormats("PY_R12M_PRDM", "EOMONTH( CP_REPORT_DATE, -25 )+1", "EOMONTH( CP_REPORT_DATE, -13 )") 3443 | 3444 | ' PY_R4M_RDM, R4m in PY for RDM, 07.2016 - 10.2016 3445 | Call CreateNamesWithFormats("PY_R4M_RDM", "EOMONTH( CP_REPORT_DATE, -12-4 )+1", "EOMONTH( CP_REPORT_DATE, -12 )") 3446 | 3447 | ' PY_R4M_PRDM, R4m in PY for PRDM, 06.2016 - 09.2016 3448 | Call CreateNamesWithFormats("PY_R4M_PRDM", "EOMONTH( CP_REPORT_DATE, -13-4 )+1", "EOMONTH( CP_REPORT_DATE, -13 )") 3449 | 3450 | ' PRDY_FULL, Prior to Report Date Year - Full, 01.2016 - 12.2016 3451 | Call CreateNamesWithFormats("PRDY_FULL", "DATE( YEAR(CP_REPORT_DATE)-1,1,1)", "DATE( YEAR(CP_REPORT_DATE)-1,12,31)") 3452 | 3453 | ' RDY_FULL, Report Date Year Full, 01.2017 - 12.2017 3454 | Call CreateNamesWithFormats("RDY_FULL", "DATE( YEAR(CP_REPORT_DATE),1,1)", "DATE( YEAR(CP_REPORT_DATE),12,31)") 3455 | 3456 | End Sub 3457 | 3458 | Private Sub CreateNamesWithFormats(sID As String, sStartFormula As String, sEndFormula As String) 3459 | Call CreateName(sID, "MMYYYY", sStartFormula, sEndFormula) 3460 | Call CreateName(sID, "0MMYYYY", sStartFormula, sEndFormula) 3461 | Call CreateName(sID, "DDMMYYYY", sStartFormula, sEndFormula) 3462 | End Sub 3463 | 3464 | Private Sub CreateName(sID As String, sFormat As String, sStartFormula As String, sEndFormula As String) 3465 | Const sPartStart = "START" 3466 | Const sPartEnd = "END" 3467 | Const sPart = "START_END" 3468 | Dim sFullID As String 3469 | Dim sFullIDStart As String 3470 | Dim sFullIDEnd As String 3471 | Dim sFullIDStartDate As String 3472 | Dim sFullIDEndDate As String 3473 | 3474 | Const sMainPrefix = "CP_DATE" 3475 | 3476 | On Error Resume Next 3477 | 3478 | ' As Date 3479 | sFullIDStartDate = sMainPrefix & "_" & sID & "_" & sPartStart & "_DATE" 3480 | Me.Names.Add Name:=sFullIDStartDate, RefersTo:="=" & sStartFormula 3481 | 3482 | sFullIDEndDate = sMainPrefix & "_" & sID & "_" & sPartEnd & "_DATE" 3483 | Me.Names.Add Name:=sFullIDEndDate, RefersTo:="=" & sEndFormula 3484 | 3485 | ' FORMATTED 3486 | ' START 3487 | sFullIDStart = sMainPrefix & "_" & sID & "_" & sPartStart & "_" & sFormat 3488 | Me.Names.Add Name:=sFullIDStart, _ 3489 | RefersTo:="=TEXT( " & sFullIDStartDate & ", CP_DATE_FORMAT_" & sFormat & " )" 3490 | ' END 3491 | sFullIDEnd = sMainPrefix & "_" & sID & "_" & sPartEnd & "_" & sFormat 3492 | Me.Names.Add Name:=sFullIDEnd, _ 3493 | RefersTo:="=TEXT( " & sFullIDEndDate & ", CP_DATE_FORMAT_" & sFormat & " )" 3494 | ' START - END 3495 | sFullID = sMainPrefix & "_" & sID & "_" & sPart & "_" & sFormat 3496 | Me.Names.Add Name:=sFullID, RefersTo:="=" & sFullIDStart & "& "" - "" & " & sFullIDEnd 3497 | 3498 | End Sub 3499 | 3500 | 3501 | --------------------------------------------------------------------------------