NerishaB
asked on
VBA - Adding message to indicate progress of import
Hi,
I have an export function, that allows the user to export all their modules and forms to any location they choose. If they have hundreds of modules, it takes a long time to export. What I would like, is some sort of message, that will display which module is being exported as it goes though the function. Can anyone help me. See attached code.
I have an export function, that allows the user to export all their modules and forms to any location they choose. If they have hundreds of modules, it takes a long time to export. What I would like, is some sort of message, that will display which module is being exported as it goes though the function. Can anyone help me. See attached code.
Sub ExportFiles()
Dim wbkModules As Workbook
Dim myString As String
Dim FromProj As Workbook
Set wbkModules = GetModuleWorkbook("Please select the file you want modules exported from")
If wbkModules Is Nothing Then
MsgBox "Can't open module workbook!"
Exit Sub
End If
Set FromProj = wbkModules
ExpName = FromProj.Name
ImpExp = 1
UserForm1.Show
End Sub
Sub ExportVBAFiles(FromProj As VBIDE.VBProject)
Dim VBComp As VBComponent 'VBA module, form, etc...
Dim strSavePath As String 'Path to save the exported files to
Dim S As String
strSavePath = GetFolderPath
' If this folder doesn't exist, create it
If Dir(strSavePath, vbDirectory) = "" Then
MkDir strSavePath
End If
' Get the VBA project
Set FromProj = Application.Workbooks(ExpName).VBProject
' Loop through all the components (modules, forms, etc) in the VBA project
For Each VBComp In FromProj.VBComponents
Select Case VBComp.Type
Case vbext_ct_StdModule
VBComp.Export strSavePath & "\" & VBComp.Name & ".bas"
Case vbext_ct_ClassModule
' ThisDocument and class modules
VBComp.Export strSavePath & "\" & VBComp.Name & ".cls"
Case vbext_ct_MSForm
VBComp.Export strSavePath & "\" & VBComp.Name & ".frm"
End Select
Next
UserForm2.Label1.Caption = "VBA files have been exported to: "
UserForm2.Label2.Caption = strSavePath
UserForm2.Label3.Caption = "Click on the button below to remove all modules and forms."
UserForm2.Show
End Sub
Function GetFolderPath() As String
Dim oShell As Object
Set oShell = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please select folder", 0, "c:\\")
If Not oShell Is Nothing Then
GetFolderPath = oShell.Items.Item.Path
Else
GetFolderPath = vbNullString
End If
Set oShell = Nothing
End Function
Public Function GetFileExtension(VBComp As VBIDE.VBComponent) As String
' This returns the appropriate file extension based on the Type of
' the VBComponent.
Select Case VBComp.Type
Case vbext_ct_ClassModule
GetFileExtension = ".cls"
Case vbext_ct_MSForm
GetFileExtension = ".frm"
Case vbext_ct_StdModule
GetFileExtension = ".bas"
Case Else
GetFileExtension = ".bas"
End Select
End Function
Public Function ExportVBComponent(VBComp As VBIDE.VBComponent, _
FolderName As String, _
Optional FileName As String, _
Optional OverwriteExisting As Boolean = True) As String
' This function exports the code module of a VBComponent to a text file. If FileName is missing, the code will be exported to
' a file with the same name as the VBComponent followed by the appropriate extension.
Dim Extension As String
Dim FName As String
Extension = GetFileExtension(VBComp:=VBComp)
If Trim(FileName) = vbNullString Then
FName = VBComp.Name & Extension
Else
FName = FileName
If InStr(1, FName, ".", vbBinaryCompare) = 0 Then
FName = FName & Extension
End If
End If
If StrComp(Right(FolderName, 1), "\", vbBinaryCompare) = 0 Then
FName = FolderName & FName
Else
FName = FolderName & "\" & FName
End If
If Dir(FName, vbNormal + vbHidden + vbSystem) <> vbNullString Then
If OverwriteExisting = True Then
Kill FName
Else
ExportVBComponent = ""
Exit Function
End If
End If
VBComp.Export FileName:=FName
ExportVBComponent = FName
End Function
Public Function VBComponentExists(VBCompName As String, Optional vbProj As VBIDE.VBProject = Nothing) As Boolean
' This returns True or False indicating whether a VBComponent named VBCompName exists in the VBProject referenced by VBProj. If VBProj
' is omitted, the VBProject of the ActiveWorkbook is used.
Dim VBP As VBIDE.VBProject
If vbProj Is Nothing Then
Set VBP = ActiveWorkbook.VBProject
Else
Set VBP = vbProj
End If
On Error Resume Next
VBComponentExists = CBool(Len(VBP.VBComponents(VBCompName).Name))
End Function
Function GetModuleWorkbook(GetTitle As String) As Workbook
Dim FileFilter As String, FilterIndex As Integer, i As Integer, FileName
Dim FullFileName As String
Dim wbk As Workbook, wb As Workbook
On Error Resume Next
Set wbk = Nothing
FileFilter = "All Files (*.*),*.*," & _
"Excel Files (*.xls; *.xlsm),*.xls;*.xlsm"
FilterIndex = 5
ChDrive ("C")
ChDir ("C:\Netserver")
With Application
FileName = Application.GetOpenFilename(FileFilter:=FileFilter, FilterIndex:=FilterIndex, _
Title:=GetTitle, MultiSelect:=False)
ChDrive (Left(.DefaultFilePath, 1))
ChDir (.DefaultFilePath)
End With
If wbk Is Nothing Then
Dim secAutomation As MsoAutomationSecurity
secAutomation = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityForceDisable
Set wbk = Application.Workbooks.Open(FileName, , ReadOnly:=False, IgnoreReadOnlyRecommended:=True)
Else
MsgBox "No File selected.", vbExclamation
End If
If wbk Is Nothing Then
For Each wb In Application.Workbooks
If wb.FullName = FileName Then
Set wbk = wb
Exit For
End If
Next wb
End If
Set GetModuleWorkbook = wbk
End Function
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Glad that helped you!
ASKER