Translate from VBA to VB.Net Workbook and FileDialog - vb.net

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

Related

Access VBA Form_before_update event is unnecessarily triggered

I have this code (in Form_Before_update Event) which checks for duplicate values in sdtCode field:
If DCount("[sdtCode]", "[tbl_sdt_Info]", "[sdtCode] = '" & Me.sdtCode.Value & "'") > 0 Then
Me.Undo
MsgBox "duplicates found"
End If
It works perfectly. However, after I use the following code to link the record to a picture, and when I try to move to another record the fisrst code is triggered and it gives me the "duplicates found" message!!!!
Private Sub sdtPicture_Click()
Dim fd As FileDialog
Dim i As Integer
Dim strSelectedPicture As Variant
Dim strExtension As String
Set fd = Application.FileDialog(msoFileDialogOpen)
With fd
.AllowMultiSelect = False
'show only set of extension file in dialog
.Filters.Clear
.Filters.Add "Image file", "*.jpeg;*.png;*.jpg;*.gif", 1
If .Show = -1 Then
For Each strSelectedPicture In .SelectedItems
For i = Len(strSelectedPicture) To 1 Step -1
If Mid(strSelectedPicture, i, 1) = "." Then
strExtension = Mid(strSelectedPicture, i)
Exit For
End If
Next i
Me.sdtImagePath.Value = strSelectedPicture
' if folder name doesnt exist then make new one
On Error Resume Next
MkDir "C:\dbImageArchive\students\"
' On Error GoTo 0
'if folder exist, copy image to distination folder
'file name in the drive C:\
FileCopy strSelectedPicture, "C:\dbImageArchive\students\" & "sdt_" & Me.sdtCode & strExtension
Me.sdtPicturePath.Value = "C:\dbImageArchive\students\" & "sdt_" & Me.sdtCode.Value & strExtension
'Add a text box (sdtPictureName) to display the name of the picture file
'Me.sdtPictureName = Me.sdtID & strExtension
Next strSelectedPicture
Else
'display when no file is selected
MsgBox "?? E?II ???C?", vbInformation, ""
End If
Set fd = Nothing
End With
Me.cboOrganizations.SetFocus
'Me.Refresh
End Sub
I tried the Form_after_update event. It produced further problems. Any ideas to solve this issue please. Thank you.

Deleting VB Components in Destination WB if not Found in Source WB

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

File name presists in Dir() function over multiple sessions

I have some code in a Excel VBA macro and it seems like its persisting values between sessions. The issue is with the BtnUpdate_Click event, the message box doesnt trigger even if the file path in NewDataFilePath is invalid.
Public NewDataFilePath As String
Private Sub BtnFileBrowse_Click()
Dim fdlg As FileDialog
Set fdlg = Application.FileDialog(msoFileDialogOpen)
fdlg.Title = "Select New Dataset"
fdlg.Filters.Clear
fdlg.Filters.Add "Excel Files Only", "*.xls; *.xlsx"
fdlg.Show
If fdlg.SelectedItems.Count <> 0 Then
TxtFilePath = fdlg.SelectedItems(1)
End If
NewDataFilePath = TxtFilePath.Text
End Sub
Private Sub BtnUpdate_Click()
Dim a As String
a = Dir(NewDataFilePath)
If Not Dir(NewDataFilePath) <> "" Then
MsgBox """ & NewDataFilePath & "" is not a valid file path"
End If
End Sub
I added the string a in the event handler to try and debug the code and its showing me some interesting results:
I have a breakpoint on the if statement in BtnUpdate_Click.
Then i stop debugging the macro and re-run it. if i invoke BtnUpdate_Click without selecting another file the Dir() function seems to keep the last file name:
Any ideas why this could happen?
Of course there is no persistence of any variable value once you stop a macro
While the observed behavior is due to the following:
1) FileDialog object keeps the last path chosen in its IntialFileName property
2) Dir(path) function with an empty string as "path" would return the first file in the IntialFileName path stored by last FileDialog run
so when you re-run the macro:
NewDataFilePath is an empty string
a = Dir(NewDataFilePath), would return the first file in the IntialFileName path matching the filters (if any)
What above as the answer to your question
While you could consider the following "nuance" of your code:
Private Sub BtnUpdate_Click()
If NewDataFilePath <> "" Then 'if 'NewDataFilePath' has been set
Dim a As String
a = Dir(NewDataFilePath)
If Not Dir(NewDataFilePath) <> "" Then MsgBox """ & NewDataFilePath & "" is not a valid file path"
Else 'otherwise
MsgBox "No file path specified!", vbCritical ' inform the user to do so
End If
End Sub
Try this code
Public NewDataFilePath As String
Private Sub BtnFileBrowse_Click()
Dim fdlg As FileDialog
Set fdlg = Application.FileDialog(msoFileDialogOpen)
fdlg.Title = "Select New Dataset"
fdlg.Filters.Clear
fdlg.Filters.Add "Excel Files Only", "*.xls; *.xlsx"
fdlg.Show
If fdlg.SelectedItems.Count <> 0 Then
NewDataFilePath = fdlg.SelectedItems(1)
End If
End Sub
Private Sub BtnUpdate_Click()
Dim a As String
a = Dir(NewDataFilePath)
If DoesFileExist(NewDataFilePath) And NewDataFilePath <> "" Then
MsgBox NewDataFilePath & " is a valid file path"
Else
MsgBox NewDataFilePath & " NOT a valid file path"
End If
End Sub
Function DoesFileExist(filePath) As Boolean
DoesFileExist = Dir(filePath) <> ""
End Function

VBA won't call UserForm from inside its own workbook

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.

Access VBA: Discard "can't append" message (Primary Key Violation)

I'm trying to create a macro in Access 2010 that opens an excel file, runs the macro in excel and then imports the given results. I have 2 problems with this process.
Application.DisplayAlerts = False in Excel
Nevertheless DisplayAlerts keep popping up. Do I need to do something special in the macro Access?
Alert "Can't append due to primary key violations" keeps popping up. I know what the problem is, but I want to ignore it. I can use On Error Resume? But I want a at the end a messagebox with the the table it hasn't append to. Is this possible and can you point me in the right direction. I already tried some errorhandeling but i don't know how to make the message popup at the end without interrupting the process.
code:
Private Sub Main_btn_Click()
Dim fileImport(0 To 3, 0 To 2) As String
fileImport(0, 0) = "Stock_CC"
fileImport(0, 1) = "F:\370\Hyperviseur\SITUATIE\Macro\Stock_getdata.xlsm"
fileImport(0, 2) = "GetStock"
fileImport(1, 0) = "Wips_CC"
fileImport(1, 1) = "F:\370\Hyperviseur\SITUATIE\Macro\Wips_getdata.xlsm"
fileImport(1, 2) = "Update"
fileImport(2, 0) = "CCA_cc"
fileImport(2, 1) = "F:\370\Hyperviseur\SITUATIE\Macro\SLAcc.xls"
fileImport(2, 2) = "Read_CCA"
fileImport(3, 0) = "Eps_cc"
fileImport(3, 1) = "F:\370\Hyperviseur\SITUATIE\Macro\eps.xlsm"
fileImport(3, 2) = "Update"
Dim i As Integer
For i = 0 To UBound(fileImport, 1)
RunMacroInxcel fileImport(i, 1), fileImport(i, 2)
transferSpreadsheetFunction fileImport(i, 0), fileImport(i, 1)
Next i
End Sub
Private Sub RunMacroInExcel(fName As String, macroName As String)
Dim Xl As Object
'Step 1: Start Excel, then open the target workbook.
Set Xl = CreateObject("Excel.Application")
Xl.Workbooks.Open (fName)
Xl.Visible = True
Xl.Run (macroName)
Xl.ActiveWorkbook.Close (True)
Xl.Quit
Set Xl = Nothing
End Sub
Private Sub transferSpreadsheetFunction(ByVal tableName As String, ByVal fileName As String)
If FileExist(fileName) Then
DoCmd.TransferSpreadsheet acImport, , tableName, fileName, True
Else
Dim Msg As String
Msg = "Bestand niet gevonden" & Str(Err.Number) & Err.Source & Err.Description
MsgBox (Msg)
End If
End Sub
Function FileExist(sTestFile As String) As Boolean
Dim lSize As Long
On Error Resume Next
lSize = -1
lSize = FileLen(sTestFile)
If lSize > -1 Then
FileExist = True
Else
FileExist = False
End If
End Function
Add error handling within the For Loop, concatenate to a string variable, then message box the string:
Dim i As integer, failedFiles as string
failedFiles = "List of failed tables: " & vbNewLine & vbNewLine
For i = 0 To UBound(fileImport, 1)
On Error Goto NextFile
Call RunMacroInxcel(fileImport(i, 1), fileImport(i, 2))
Call transferSpreadsheetFunction(fileImport(i, 0), fileImport(i, 1))
NextFile:
failedFiles = failedFiles & " " & fileImport(i,0) & vbNewLine
Resume NextFile2
NextFile2:
Next i
MsgBox failedFiles, vbInformation, "Failed Tables List"