I have a CMD button on my sheet with the following code:
Private Sub cmdBlastoff_Click()
UserForm2.Show vbModeless 'launch gateway userform
End Sub
This code worked for a long time, but is now generating "Error 9: Subscript out of range."
The userform I am trying to call (UserForm2) is located in the same workbook.
I will put the full code of the userform below in case it's relevant, but the code in its Userform_initialize sub is:
Private Sub userform_initialize()
Sheets("hiddensheet1").Range("B5").Value = "v7.04" 'sets version # in hidden sheet
FileNameChecker_local 'runs a sub (located below in the userform module) to determine the filename and path
ValueInjector 'runs a sub (located below in the userform module) to put some values into text fields on the userform
cmdBigGo.Font.Size = 15 'sets font size of a button
End Sub
As I said earlier, this was working until recently and I am out of ideas.
So far I have tried:
1) Finding some way to explicitly point to the exact location of
userform2 by specifying the workbook in front of it:
ActiveWorkbook.UserForm2.show (doesn't work for reasons that are
now obvious) I regard a more explicit call as the most likely fix,
but don't know how to do it
2) Removing vbModeless from the call button call
3) Explicitly setting the ActiveWorkbook to the one all my stuff is
stored on, which is where the call button sits (this shouldn't be
necessary, I know)
Any other ideas?
Full code of the UserForm2 (probably not relevant, all working prior to this problem arising):
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" _
(ByVal pCaller As Long, _
ByVal szURL As String, _
ByVal szFileName As String, _
ByVal dwReserved As Long, _
ByVal lpfnCB As Long) As Long
'should check to see if there is an output folder in the directory where COGENT sits and if not create it
'should pull default filepath to the outputs folder from the hiddensheet
'should call data baster on terminate
'DONE should allow the user to change the default save location
'DONE should allow them to change the save location THIS time.
'DONE should pull filepath from hiddensheet, check against original (?) and
'DONE Should create a default filename
Public strFileFullName As String
Public strFileJustPath As String
Public strUserFolderName As String
Public strFileName As String
Public strRawDate As String
Public strDLlink As String
Public strDLdest As String
Public strDLlocalName As String
Public strDLNameOnWeb As String
Public strOpenURLPointer As String
Dim strSaveAsErrHandler As String
Dim strQueryID As String
Private Sub userform_initialize()
Sheets("hiddensheet1").Range("B5").Value = "v7.04" 'sets version # in hidden sheet
FileNameChecker_local 'runs a sub (located below in the userform module) to determine the filename and path
ValueInjector 'runs a sub (located below in the userform module) to put some values into text fields on the userform
cmdBigGo.Font.Size = 15 'sets font size of a button
End Sub
Private Sub chkCyberDiv_Click()
If chkCyberDiv.Value = True Then
'==Cyber OUs visible==
chkNDIO.Visible = True
txtQueryID.Value = "169436"
'==Other Div OUs invisible==
chkCivilDiv.Value = False
Else
chkNDIO.Visible = False
End If
End Sub
Private Sub chkCivilDiv_Click()
If chkCivilDiv.Value = True Then
'==Civil OUs visible==
chkCivilInfoSys.Visible = True
'==Other Div OUs invisible==
chkCyberDiv.Value = False
Else
chkCivilInfoSys.Visible = False
End If
End Sub
Sub cmdBigGo_Click()
'==========Check if SaveAsNewName worked and if not kill sub==========
SaveAsNewName
If strSaveAsErrHandler = "Filename/path not viable." Then
MsgBox strSaveAsErrHandler
Exit Sub
Else
'==========Startup==========
Application.ScreenUpdating = False
Sheets("LoadingData").Visible = True
Sheets("Launchpad").Visible = False
'==========Check for/create Temp Directory==========
If FileFolderExists(strFileJustPath & "\temp") = True Then
'MsgBox "temp Folder already exists."
Else
MkDir strFileJustPath & "\temp"
'MsgBox "temp Folder didn't exist, but it do now."
End If
'==========Download Section==========
'=====Set up===== 'big gap for now = 169436
strQueryID = txtQueryID.Value
strDLlink = "https://workbench.northgrum.com/xauth/login.aspx?&ActionPageID=37&ActionParameters=QueryID%3d" & strQueryID & "%26View%3d0%26OutputToExcel%3d1"
strDLdest = strFileJustPath & "\temp\dump.xlsx"
'=====Run=====
'MsgBox "cmdBigGo thinks strDLdest = " & strDLdest
Dim done
done = URLDownloadToFile(0, strDLlink, strDLdest, 0, 0)
'==========Copy Targets from temp file==========
Sheets("LoadingData").Select
copyPathName = strFileJustPath & "\temp\"
copyFileName = "dump.xlsx"
copyTabName = "Targets"
ControlFile = ActiveWorkbook.Name
Workbooks.Open FileName:=copyPathName & "\" & copyFileName
ActiveSheet.Name = copyTabName
Sheets(copyTabName).Copy After:=Workbooks(ControlFile).Sheets(1)
Windows(copyFileName).Activate
ActiveWorkbook.Close SaveChanges:=False
Windows(ControlFile).Activate
ActiveWorkbook.Sheets("Targets").Name = "COGENT Targets"
'^source: https://msdn.microsoft.com/en-us/library/office/ff194819.aspx
'==========Delete Temp Directory==========
On Error Resume Next
Kill copyPathName & "\*.*" ' delete all files in the folder
RmDir copyPathName ' delete folder
On Error GoTo 0
'==========Create Userform1 Button on "Targets"==========
Rows("1:1").RowHeight = 26
Dim btnCOGENT As Button
Set btnCOGENT = Sheets("COGENT Targets").Buttons.Add(10.5, 4.5, 84.75, 19.5)
With btnCOGENT
.OnAction = "CallUserform1"
.Characters.Text = "COGENT"
End With
With btnCOGENT.Characters(Start:=1, Length:=6).Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
End With
Sheets("COGENT Targets").Shapes("Button 1").ScaleWidth 0.7433628319, msoFalse, _
msoScaleFromTopLeft
'==========Finish up==========
Worksheets("COGENT Targets").Activate
Sheets("LoadingData").Visible = False
Application.ScreenUpdating = True
End If
UserForm1.Show vbModeless
End Sub
Private Sub SaveAsNewName()
strSaveAsErrHandler = ""
On Error GoTo ErrorHandler
'==========Save the file with a new name==========
Dim strExpectedFileFullName As String
strExpectedFileFullName = txtFilePath.Value & "\" & txtFileName & ".xlsm"
ActiveWorkbook.SaveAs strExpectedFileFullName
FileNameChecker_local 'get the new filename
Exit Sub
ErrorHandler:
'==========Error Handler==========
If Err.Number = 1004 Then
lblSaveAsText.Caption = "That name and location didn't work... Try using 'Browse' or 'Create Outbox."
lblSaveAsText.BackColor = &H8080FF
strSaveAsErrHandler = "Filename/path not viable."
Else
MsgBox "unknown error...email Owen.Britton#NGC.com; it's probably his fault."
strSaveAsErrHandler = ""
End If
End Sub
Sub FileNameChecker_local()
'==========Check Filename and SaveAs if needed==========
strFileJustPath = ActiveWorkbook.Path
strFileFullName = ActiveWorkbook.FullName
'==========Get Filename==========
Dim i As Integer
Dim intBackSlash As Integer, intPoint As Integer
For i = Len(strFileFullName) To 1 Step -1
If Mid$(strFileFullName, i, 1) = "." Then
intPoint = i
Exit For
End If
Next i
If intPoint = 0 Then intPoint = Len(strFileFullName) + 1
For i = intPoint - 1 To 1 Step -1
If Mid$(strFileFullName, i, 1) = "\" Then
intBackSlash = i
Exit For
End If
Next i
strFileName = Mid$(strFileFullName, intBackSlash + 1, intPoint - intBackSlash - 1)
'MsgBox "strFileName = " & strFileName & vbNewLine & _
"strFileJustPath = " & strFileJustPath & vbNewLine & _
"strFileFullName = " & strFileFullName & vbNewLine & _
"ran from userform2"
End Sub
Private Sub ValueInjector()
strRawDate = Format(Date, "mm-d-yy")
'==========Inject File Name==========
If strFileName = "COGENT Launchpad" Then
txtFileName.Value = "COGENT_Pull_" & strRawDate 'might be better to include query number\
lblSaveAsText.Caption = "Give your output a descriptive name. Here's a suggestion:"
Else
'txtFileName.Value = strFileName
lblSaveAsText.Caption = "This file should be named 'COGENT Launchpad.' Some features break if you rename it."
lblSaveAsText.BackColor = &H8080FF
'MsgBox "Please rename this file 'COGENT Launchpad'"
End If
'==========Inject File Path==========
Application.ScreenUpdating = False
If IsEmpty(Worksheets("Hiddensheet1").Range("B6")) Then
cmdCreateOutbox_click
Worksheets("Hiddensheet1").Range("B6") = strFileJustPath & "\Outbox"
txtFilePath.Value = Worksheets("Hiddensheet1").Range("B6")
Else
txtFilePath.Value = Worksheets("Hiddensheet1").Range("B6")
End If
Application.ScreenUpdating = True
Worksheets("Launchpad").Activate
End Sub
Private Sub cmdBrowse_Click()
FileNameChecker_local
GetFolder (strFileJustPath)
End Sub
Private Sub cmdMakeDefault_Click()
Worksheets("Hiddensheet1").Range("B6") = txtFilePath.Value
imgCheckMark.Visible = True
End Sub
Private Sub cmdCreateOutbox_click()
'MsgBox "looking for" & strFileJustPath & "\Outbox"
If FileFolderExists(strFileJustPath & "\Outbox") Then
MsgBox "Outbox Folder already exists."
Else
MsgBox "Outbox Folder did not exist, but it does now."
MkDir strFileJustPath & "\Outbox"
txtFilePath.Value = strFileJustPath & "\Outbox"
End If
End Sub
Function GetFolder(strFilePath As String) As String
Dim fldr As FileDialog
Dim strGetFolderOutput As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strFilePath
If .Show <> -1 Then GoTo NextCode
strGetFolderOutput = .SelectedItems(1)
End With
NextCode:
GetFolder = strGetFolderOutput
txtFilePath.Value = strGetFolderOutput
Set fldr = Nothing
End Function
Private Sub userform_terminate()
Unload Me
End Sub
Somehow the hidden sheet got deleted, and it gets referred to before I check its existence and create it if missing. Thanks guys; I was barking up totally the wrong tree. Fixed and working.
Nothing was wrong with the calling of the userform at all.
Related
I'm writing a procedure to update the components in one macro-enabled Excel workbook (Destination) from another macro-enabled Excel workbook (Source). The end result is to make the Destination components (worksheets, user forms, modules, etc.) match the Source components.
So far I have successfully (1) Added components from source that are not found in destination, (2) Replaced worksheet(s) with newer versions, (3) Globally updated the code in all modules, class modules and user forms, and (4) Updated miscellaneous cell formulas and values in various worksheets.
Where I have been struggling is deleting components in destination that are not found in source. I've been trying all kinds of approaches and believe I'm close but can't get past various errors in the actual VBComponents.Remove line. Here's my code:
Sub UpdateDest()
'Purpose:
'Sources: (1) https://www.excel-easy.com/vba/examples/import-sheets.html
' (2) https://stackoverflow.com/questions/16174469/unprotect-vbDestProject-from-vb-code
' (3) https://stackoverflow.com/questions/18497527/copy-vba-code-from-a-sheet-in-one-workbook-to-another
'=== Declare Variables
Dim booCompFound As Boolean
Dim cmSrc As CodeModule, cmDest As CodeModule
Dim xlWBDest As Excel.Workbook, xlWSDest As Excel.Worksheet
Dim xlWBSrc As Excel.Workbook, xlWSSrc As Excel.Worksheet
Dim i As Integer, j As Integer
Dim lngVBUnlocked As Long
Dim vbDestComp As Object, vbDestComps As Object, vbDestProj As Object, vbDestMod As Object
Dim vbSrcComp As Object, vbSrcComps As Object, vbSrcProj As Object, vbSrcMod As Object
Dim modModule As Object
Dim strDestName As String, strDestPath As String, strSrcName As String, strSrcPath As String
Dim strUpdName As String, strUpdPath As String
'On Error GoTo ErrorHandler
'=== Initialize Variables and Prepare for Execution
Application.ScreenUpdating = True
Application.DisplayAlerts = True
strUpdPath = ThisWorkbook.Path & "\"
'=== (Code execution)
'--- Select Dest and source workbooks for the update, and remove workbook, worksheet and VBA Project protection from both
strSrcPath = Application.GetOpenFilename(Title:="Select SOURCE workbook for the update", FileFilter:="Excel Files *.xls* (*.xls*),")
If strSrcPath = "" Then
MsgBox "No source workbook was selected.", vbExclamation, "Sorry!"
Exit Sub
Else
Set xlWBSrc = Workbooks.Open(strSrcPath)
UnprotectAll xlWBSrc
'For Each xlWSSrc In xlWBSrc.Worksheets
' xlWSSrc.Visible = xlSheetVisible
'Next xlWSSrc
Set vbSrcProj = xlWBSrc.VBProject
lngVBUnlocked = UnlockProject(vbSrcProj, "FMD090")
Debug.Print lngVBUnlocked
If lngVBUnlocked <> 0 And lngVBUnlocked <> 2 Then
MsgBox "The source VB Project could not be unlocked.", vbExclamation, "Error!"
Exit Sub
Else
Set vbSrcComps = vbSrcProj.VBComponents
End If
End If
strDestPath = Application.GetOpenFilename(Title:="Select DESTINATION workbook to update", FileFilter:="Excel Files *.xls* (*.xls*),")
If strDestPath = "" Then
MsgBox "No destination workbook was selected.", vbExclamation, "Sorry!"
Exit Sub
Else
Set xlWBDest = Workbooks.Open(strDestPath)
UnprotectAll xlWBDest
'For Each xlWSDest In xlWBDest.Worksheets
' xlWSDest.Visible = xlSheetVisible
'Next xlWSDest
Set vbDestProj = xlWBDest.VBProject
lngVBUnlocked = UnlockProject(vbDestProj, "FMD090")
Debug.Print lngVBUnlocked
If lngVBUnlocked <> 0 And lngVBUnlocked <> 2 Then
MsgBox "The destination VB Project could not be unlocked.", vbExclamation, "Error!"
Exit Sub
Else
Set vbDestComps = vbDestProj.VBComponents
End If
End If
'--- Add components from source that are not found in destination
For Each vbSrcComp In vbSrcComps
Debug.Print vbSrcComp.Name
booCompFound = False
For Each vbDestComp In vbDestComps
If vbSrcComp.Name = vbDestComp.Name Then
booCompFound = True
Exit For
End If
Next vbDestComp
If booCompFound = False Then
Application.EnableEvents = False
vbSrcComp.Export strSrcPath & vbSrcComp.Name
vbDestComps.Import strSrcPath & vbSrcComp.Name
Kill strSrcPath & vbSrcComp.Name
Application.EnableEvents = True
End If
Next vbSrcComp
'--- Delete components in destination that are not found in source
Set vbDestComps = vbDestProj.VBComponents
For i = vbDestComps.Count To 1 Step -1
'For Each vbDestComp In vbDestComps
booCompFound = False
For Each vbSrcComp In vbSrcComps
Debug.Print "Src: "; vbSrcComp.Name; " Dest: "; vbDestComps(i).Name
If vbDestComps(i).Name = vbSrcComp.Name Then
booCompFound = True
Exit For
End If
Next vbSrcComp
If booCompFound = False Then
Application.EnableEvents = False
'>>> PROBLEM LINE
vbDestProj.VBComponents.Remove vbDestComps(i)
'<<<
Application.EnableEvents = True
End If
'Next vbDestComp
Next i
'--- Replace worksheet(s) with newer versions
strUpdName = "Lists_WS_3_1.xlsx"
If Dir(strUpdPath & strUpdName) <> "" Then
Application.EnableEvents = False
Set xlWBSrc = Workbooks.Open(strUpdPath & strUpdName)
xlWBDest.Worksheets("Lists").Visible = xlSheetVisible
Application.DisplayAlerts = False
xlWBDest.Worksheets("Lists").Name = "Lists_Old"
xlWBSrc.Worksheets("Lists").Copy After:=xlWBDest.Worksheets("FYMILES")
xlWBDest.Worksheets("Lists_Old").Delete
xlWBSrc.Close
Application.EnableEvents = True
Else
MsgBox "The file " & strUpdName & " is missing.", vbExclamation, "File Missing!"
Exit Sub
End If
'--- Globally update code in modules, class modules and user forms
For Each vbSrcComp In vbSrcComps
Set cmSrc = vbSrcComp.CodeModule
Debug.Print vbSrcComp.Name
Set cmDest = vbDestComps(vbSrcComp.Name).CodeModule
If cmSrc.CountOfLines > 0 Then
Application.EnableEvents = False
cmDest.DeleteLines 1, cmDest.CountOfLines 'Delete all lines in Dest component
cmDest.AddFromString cmSrc.Lines(1, cmSrc.CountOfLines) 'Copy all lines from source component to Dest component
Application.EnableEvents = True
End If
Next vbSrcComp
'--- Update miscellaneous cell formulas and values
Application.EnableEvents = False
xlWBDest.Sheets("Inventory Data and July").Range("E2").Formula = "=TEXT(Lists!$O$5, " & Chr(34) & "000" & Chr(34) & ")"
Application.EnableEvents = True
'=== Error Handling
ErrorHandler:
Application.EnableEvents = True
'=== Release Variables and Cleanup
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
The problem code is about 2/3rds of the way down following '>>> PROBLEM LINE. This line of code produces a run-time error 5, invalid procedure call or argument when attempting to delete the Sheet18 code module.
During the run the original Sheet16 (Lists) is removed and replaced with a new Lists worksheet that Excel numbers Sheet18. After a weekend of contemplation I believe the issue stems from component naming. Attempting to address this, the code references the component names, but VB Properties for the new sheet are (Name) = (Sheet18) and Name = Lists (note the parentheses).
I've now tried saving the workbook following each operation without any change in the error or on what part of the structure the error occurs.
As it is currently written I'm looping backward through the destination components collection and attempting to delete when a component in Destination isn't found in Source. Commented out are the remnants of the original forward loop that also didn't work. I've tried many variations and either get an invalid procedure call or that the property or method isn't found in the object.
I've spend a day playing with this. Please take a look and help me see the light!
I'm running Excel 2016
Following on # Comintern's comment, I added tests to ensure the Remove method was only applied to non-document modules. This is the rewritten code block for removing the modules:
'--- Delete non-document components in destination that are not found in source
Set vbDestComps = vbDestProj.VBComponents
For Each vbDestComp In vbDestComps
If vbDestComp.Type >= 1 And vbDestComp.Type <= 3 Then
booCompFound = False
For Each vbSrcComp In vbSrcComps
Debug.Print "Src: "; vbSrcComp.Name; " Dest: "; vbDestComp.Name; " Type: "; vbDestComp.Type
If vbDestComp.Name = vbSrcComp.Name Then
booCompFound = True
Exit For
End If
Next vbSrcComp
If booCompFound = False Then
Application.EnableEvents = False
vbDestProj.VBComponents.Remove vbDestComp
Application.EnableEvents = True
End If
End If
Next vbDestComp
I need help with inserting a sizeable code into "ThisWorkbook" module in Excel using VBA.
Using the code below I'm able to insert the code into "ThisWorkbook" module, but this method (as I've learned recently) has limitations of 24 lines due to line beak (& _).
Sub AddCode()
Dim VBP As Object
Dim newmod As Object
Set VBP = ActiveWorkbook.VBProject
Set newmod = VBP.VBComponents.Add(1)
Dim StartLine As Long
Dim cLines As Long
With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
cLines = .CountOfLines + 1
.InsertLines cLines, _
"Private Sub Workbook_Open()" & Chr(13) & _
" Application.Calculation = xlManual" & Chr(13) & _
" Application.CalculateBeforeSave = False" & Chr(13) & _
" Application.DisplayFormulaBar = False" & Chr(13) & _
"Call Module1.ProtectAll" & Chr(13) & _
"End Sub"
End With
End Sub
The code I want to inject in addition to the code above is below (code found on another site). This allows me to track changes on the workbook that I share with others. I do not want to use Excel's built-in "Track Changes" feature.
Dim vOldVal
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim bBold As Boolean
If Target.Cells.Count > 1 Then Exit Sub
On Error Resume Next
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
If IsEmpty(vOldVal) Then vOldVal = "Empty Cell"
bBold = Target.HasFormula
With Sheet1
.Unprotect Password:="Passcode"
If .Range("A1") = vbNullString Then
.Range("A1:E1") = Array("CELL CHANGED", "OLD VALUE", _
"NEW VALUE", "TIME OF CHANGE", "DATE OF CHANGE")
End If
With .Cells(.Rows.Count, 1).End(xlUp)(2, 1)
.Value = Target.Address
.Offset(0, 1) = vOldVal
With .Offset(0, 2)
If bBold = True Then
.ClearComments
.AddComment.Text Text:= _
"Note:" & Chr(10) & "" & Chr(10) & _
"Bold values are the results of formulas"
End If
.Value = Target
.Font.Bold = bBold
End With
.Offset(0, 3) = Time
.Offset(0, 4) = Date
End With
.Cells.Columns.AutoFit
.Protect Password:="Passcode"
End With
vOldVal = vbNullString
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
vOldVal = Target
End Sub
How can I achieve this? What is the best and the most efficient way to do this?
I've tried splitting the code in chunks of 20 lines and create 3 "AddCode" sub-routines, but I get an error at "bBold = Target.HasFormula". I have searched the web for alternatives, but nothing seems to be working.
Thanks in advance.
This is an abbreviated version of what I'm doing to create on load code. I create the onload event, then add a new module.
Sub AddOnload()
''Create on load sub
With ActiveWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
.InsertLines 1, "Private Sub Workbook_Open()"
.InsertLines 2, " call CallMe"
.InsertLines 3, "End Sub"
End With
Call CreateCode
End Sub
''Add new module with code
Sub CreateCode()
Dim vbp As VBProject
Dim vbc As VBComponent
Dim strCode
Set vbp = Application.VBE.ActiveVBProject
Set vbc = vbp.VBComponents.Add(vbext_ct_StdModule)
vbc.Name = "tracker"
strCode = "Sub CallMe()" & vbCrLf & "End Sub"
vbc.CodeModule.AddFromString strCode
End Sub
My current situation:
I am developing a culmination of VBA programs embedded in an excel file (named "Dashboard.xlsm" and an access file "Dashboard.accdb"). These two files talk to one another via VBA in order to help me do some heavy lifting on data that I need to analyze for my company. Because these programs are being distributed to several managers who panic when something doesn't complete within 3 seconds, I need a good way to indicate the progress of the SQL queries that are being run in Access through Excel (because Access is running invisibly in the background).
My current Excel code:
Sub generateFRMPComprehensive_ButtonClick(Optional sheetName As Variant)
Application.ScreenUpdating = False
Dim directoryPath As String
Dim cn As Object
Dim rs As Object
Dim strCon As String
Dim strSQL, strInput As String
Dim sArray As Variant
Dim appAccess As Access.Application
Dim directoryName
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
directoryName = Application.ActiveWorkbook.Path
directoryPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\Dashboard Exports"
Application.ScreenUpdating = False
If IsMissing(sheetName) Then
sheetName = Application.InputBox("Sheet Name?", "Sheet Selection")
If sheetName = "False" Then
Exit Sub
Else
End If
If FileFolderExists(directoryPath) = 0 Then
Application.StatusBar = "Creating Export Folder"
MkDir directoryPath
End If
End If
'-- Set the workbook path and name
reportWorkbookName = "Report for " & sheetName & ".xlsx"
reportWorkbookPath = directoryPath & "\" & reportWorkbookName
'-- end set
'-- Check for a report already existing
If FileExists(reportWorkbookPath) = True Then
Beep
alertBox = MsgBox(reportWorkbookName & " already exists in " & directoryPath & ". Do you want to replace it?", vbYesNo, "File Exists")
If alertBox = vbYes Then
Kill reportWorkbookPath
'-- Run the sub again with the new sheetName, exit on completion.
generateFRMPComprehensive_ButtonClick (sheetName)
Exit Sub
ElseIf alertBox = vbNo Then
Exit Sub
ElseIf alertBox = "False" Then
Exit Sub
End If
End If
'-- End check
'- Generate the report
'-- Create new access object
Set appAccess = New Access.Application
'-- End Create
'-- Open the acces project
Application.StatusBar = "Updating Access DB"
Call appAccess.OpenCurrentDatabase(directoryName & "\Dashboard.accdb")
appAccess.Visible = False
'-- End open
'-- Import New FRMP Data
Application.StatusBar = "Running SQL Queries"
appAccess.Application.Run "CleanFRMPDB", sheetName, directoryName & "\Dashboard.xlsm"
'-- End Import
Workbooks.Add
ActiveWorkbook.SaveAs "Report for " & sheetName
ActiveWorkbook.Close
appAccess.Application.Run "generateFRMPReport_Access", reportWorkbookPath
Workbooks.Open (reportWorkbookPath)
End Sub
My current Access Code:
Public Sub generateFRMPReport_Access(excelReportFileLocation As String)
Dim queriesList As Variant
queriesList = Array("selectAppsWithNoHolds", _
"selectAppsWithPartialHolds", _
"selectAppsCompleted", _
"selectAppsCompletedEPHIY", _
"selectAppsByDivision", _
"selectAppsByGroup", _
"selectAppsEPHIY", _
"selectAppsEPHIN", _
"selectAppsEPHIYN", _
"selectApps")
For i = 0 To 9
DoCmd.TransferSpreadsheet acExport, , queriesList(i), _
excelReportFileLocation, True
Next i
End Sub
My Request:
Is there a way that I can call the Application.DisplayStatusBar from within the 'for' loop within Access and pass the name of the query being run?
Alternatively, what other ways could I display this information?
Thank you!!
You have a few options for achieving this, but the two most obvious are to:
Execute the queries from Excel, and update the status bar from Excel
Execute the queries from Access, but pass the Excel Application reference to Access, so that Access can call back to the Excel status bar.
As your'e driving the activity from Excel, and you already have a reference to the Access Application, the first option is the most logical. The second approach is possible - you just need to pass the Excel object to Access, but then you'd be using Excel to automate Access to automate Excel.
You'll need to move the generateFRMPReport_Access procedure from the Access VBA into the Excel VBA, and modify your call to the procedure in generateFRMPComprehensive_ButtonClick
Sub generateFRMPComprehensive_ButtonClick(Optional sheetName As Variant)
'...
'appAccess.Application.Run "generateFRMPReport_Access", reportWorkbookPath
generateFRMPReport_Access reportWorkbookPath, appAccess
'...
End Sub
Public Sub generateFRMPReport_Access(excelReportFileLocation As String, appAccess As Access.Application)
Dim queriesList As Variant
Dim i As Long
queriesList = Array("selectAppsWithNoHolds", _
"selectAppsWithPartialHolds", _
"selectAppsCompleted", _
"selectAppsCompletedEPHIY", _
"selectAppsByDivision", _
"selectAppsByGroup", _
"selectAppsEPHIY", _
"selectAppsEPHIN", _
"selectAppsEPHIYN", _
"selectApps")
Application.DisplayStatusBar = True
For i = 0 To 9
Application.StatusBar = "Running query " & (i + 1) & " of 9"
appAccess.DoCmd.TransferSpreadsheet acExport, , queriesList(i), _
excelReportFileLocation, True
Next i
Application.StatusBar = False
Application.DisplayStatusBar = False
End Sub
I am having an issue with active x control command buttons being renamed in Word 2007 without the user actually renaming them. I have directly observed the user saving the document with embedded active x controls and the names appear to be okay when they open the document, but when they save the document, they are renamed.
For example, the name property for CommandButton11 will be renamed to CommandButton111. In some cases it appears that 1 is being added to the end of the Command Button Name so 10 becomes 101, while in other cases 1 is being added to the actual value of the command button so say CommandButton10 becomes CommandButton11. The code for the command buttons does not change, but because I reference the names of the individual command buttons within the code, it obviously breaks.
The purpose of the code is to embed an OLE object in the document and place it correctly in a table.
Below is the specific code for the command button:
Private Sub CommandButton10_Click()
wrdTbl = 1
wrdRow = 11
wrdCol = 2
Set obj = CommandButton10
Call buttontransformer
End Sub
Button transformer is as follows:
Private Sub buttontransformer()
If ActiveDocument.Tables(wrdTbl).Cell(wrdRow, wrdCol).Range.Text = Chr(13) & Chr(7) Then
obj.Caption = "Remove File"
Call OLEObjectAdd
Else
ActiveDocument.Tables(wrdTbl).Cell(wrdRow, wrdCol).Select
Selection.EndKey unit:=wdRow, Extend:=wdExtend
Selection.Delete
obj.Caption = "Click to Add File"
ireply = MsgBox("Add another file?", buttons:=vbYesNo, Title:="UPLOAD NEW FILE?")
If ireply = vbYes Then
obj.Caption = "Remove File"
Call OLEObjectAdd
Else
Exit Sub
End If
End If
End Sub
And OleObjectAdd is as follows:
Private Sub OLEObjectAdd()
Dim fd As FileDialog
Dim ofd As Variant
Dim FP As String
Dim FN As String
Dim Ext As String
Dim fType As String
'Selection.MoveRight Unit:=wdCharacter, Count:=1
Set fd = Application.FileDialog(msoFileDialogFilePicker)
ActiveDocument.Tables(wrdTbl).Cell(wrdRow, wrdCol + 1).Select
With fd
.ButtonName = "Select"
.AllowMultiSelect = False
.Filters.Clear
If .Show = -1 Then
For Each ofd In .SelectedItems
FP = ofd
Debug.Print FP
FN = Right(FP, Len(FP) - InStrRev(FP, "\"))
Debug.Print FN
Ext = Right(FP, Len(FP) - InStrRev(FP, "."))
Debug.Print Ext
Next ofd
On Error GoTo 0
Else
Exit Sub
End If
End With
If Ext = "pdf" Then
fType = "adobe.exe"
ElseIf Ext = "doc" Or Ext = "docx" Or Ext = "docm" Then
fType = "word.exe"
ElseIf Ext = "xls" Or Ext = "xlsx" Or Ext = "xlsm" Then
fType = "Excel.exe"
End If
Selection.InlineShapes.AddOLEObject ClassType:=fType, _
fileName:=FP, LinkToFile:=False, _
DisplayAsIcon:=True, IconFileName:= _
fType, IconIndex:=0, IconLabel:= _
FN
Selection.Move unit:=wdCell, Count:=-2
Selection = FN
End Sub
I had done the Microsoft Fixit to address the Active-X broken controls and it works fine on several other computers I have tested this on.
I have searched high and low for an answer and cant seem to find one. Any help would be appreciated.
I have been working on translating the code below from VBA to VB.Net. I am about 90% of the way there but I am stuck on 3 issues.
First, In VBA I used the Application.GetOpenFilename to open a file dialog from within my code, I can't seem to get that done on VB.
Second, I am trying to export a sheet and copy the data onto a sheet on my workbook. I use the following line of code:
With Globals.ThisWorkbook.Application.ActiveWorkbook.Open(strImportFile)
.Worksheets(1).Cells.Copy Workbooks(strSourceFile).Worksheets(sDestSheet).Range("A1")
.Close(savechanges:=False)
Unfortunately, the middle line is not working the Workbooks gives me an error that it cannot be used as type.
And finally, I am trying to get the Application ScreenUpdating, but that also fails. Here is the rest of my code:
Imports Microsoft.Office.Interop.Excel
Module adminModule
Function GetImportFile(Index As Long) As String
'This function is used in the import_Module to name all of the files
'that will be imported to the template. The function is primarily used by
'Sub import_OC_Data
Select Case Index
Case 1 : GetImportFile = "byemployee.csv"
Case 2 : GetImportFile = "byposition.csv"
Case 3 : GetImportFile = "statusreport.xls"
Case 4 : GetImportFile = "bydepartment.csv"
End Select
Return ""
End Function
Function GetDestSheet(Index As Long) As String
'This function is used in the import_Module to name all of the sheets
'where the files will be imported to in template.The function is primarily used by
'Sub import_OC_Data
Select Case Index
Case 1 : GetDestSheet = "byDepartment"
Case 2 : GetDestSheet = "byPosition"
Case 3 : GetDestSheet = "statusReport"
Case 4 : GetDestSheet = "byDepartment"
End Select
Return ""
End Function
Sub importRawData()
Dim xlWBPath As String = Globals.ThisWorkbook.Application.ActiveWorkbook.Path
Dim n As Long
Dim strSourceFile As String
Dim strImportFile As String
Dim sDestSheet As String
Dim strTitle As String = "Verify Source File"
Dim strPrompt As String = " source file does not exist." & vbNewLine & "Press OK to browse for the file or Cancel to quit"
Dim strAlert As String = ("You have not selected a workbook." & vbNewLine & "Press Retry to select a workbook or Cancel to exit program")
Dim strVmbProceedResults As String = ("Procedure Canceled. Your workbook will now close")
Dim vmbContinue As MsgBoxResult
Dim vmbProceed As MsgBoxResult
strSourceFile = Globals.ThisWorkbook.Application.ActiveWorkbook.Na
For n = 1 To 4 Step 1
strImportFile = xlWBPath & GetImportFile(n)
sDestSheet = GetDestSheet(n)
If Len(Dir(strImportFile)) > 0 Then
With Globals.ThisWorkbook.Application.ActiveWorkbook.Open(strImportFile)
.Worksheets(1).Cells.Copy Workbooks(strSourceFile).Worksheets(sDestSheet).Range("A1")
.Close(savechanges:=False)
End With
Else
vmbProceed = MsgBox(strImportFile & strPrompt, vbOKCancel + vbQuestion, strTitle)
If vmbProceed = vbCancel Then
vmbProceed = MsgBox(strVmbProceedResults, vbOKOnly + vbCritical)
Globals.ThisWorkbook.Close(saveChanges:=False)
Exit Sub
Else
strImportFile = Application.GetOpenFilename("Excel Files (*.xls;*.xlsx; *.xlsm; *.csv), *.xls; *.csv; *.xlsx; *.xlsm")
If strImportFile = "False" Then Application.ScreenUpdating = True
vmbContinue = MsgBox(strAlert, vbRetryCancel + vbCritical, "No Workbook Selected")
If vmbContinue = vbCancel Then
Globals.ThisWorkbook.Close(saveChanges:=False)
Exit Sub
Else
strImportFile = Application.GetOpenFilename("Excel Files (*.xls;*.xlsx; *.xlsm; *.csv), *.xls; *.csv; *.xlsx; *.xlsm")
Globals.ThisWorkbook.Application.ActiveWorkbook.Open(Filename:=strImportFile)
With Globals.ThisWorkbook.Application.ActiveWorkbook.Open(strImportFile)
.Worksheets(1).Cells.Copy Workbooks(strSourceFile).Worksheets(sDestSheet).Range("A1")
.Close(saveChanges:=False)
End With
End If
On Error GoTo exit_
Application.ScreenUpdating = False
Globals.ThisWorkbook.Application.ActiveWorkbook.Open(Filename:=strImportFile)
With Globals.ThisWorkbook.Application.ActiveWorkbook.Openn(strImportFile)
.Worksheets(1).Cells.Copy Workbooks(strSourceFile).Worksheets(sDestSheet).Range("A1")
.Close(savechanges:=False)
End With
exit_:
Application.ScreenUpdating = True
If Err() Then MsgBox(Err.Description, vbCritical, "Error")
End If
End If
Next n
End Sub
End Module