Link to home
Start Free TrialLog in
Avatar of NerishaB
NerishaBFlag for South Africa

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.
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

Open in new window

ASKER CERTIFIED SOLUTION
Avatar of dandraka
dandraka
Flag of Greece image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of NerishaB

ASKER

Thanks.
Glad that helped you!