Solved

VBA - Adding message to indicate progress of import

Posted on 2010-09-07
3
397 Views
Last Modified: 2012-06-21
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

0
Comment
Question by:NerishaB
  • 2
3 Comments
 
LVL 8

Accepted Solution

by:
dandraka earned 500 total points
ID: 33616309
Hey there...First of all you could speed up your code a bit if you add:

Application.ScreenUpdating = False
'At the begining of your code and

Application.ScreenUpdating = True
'at the end of your code!

Now, as for the Please wait message box, or a similar informative progress message box, read on here:
(1) http://spreadsheetpage.com/index.php/site/tip/displaying_a_progress_indicator/
(2) http://www.ozgrid.com/VBA/slow-excel-macro-progress.htm
(3)

it should solve your problem!
0
 

Author Closing Comment

by:NerishaB
ID: 33616341
Thanks.
0
 
LVL 8

Expert Comment

by:dandraka
ID: 33616376
Glad that helped you!
0

Featured Post

Networking for the Cloud Era

Join Microsoft and Riverbed for a discussion and demonstration of enhancements to SteelConnect:
-One-click orchestration and cloud connectivity in Azure environments
-Tight integration of SD-WAN and WAN optimization capabilities
-Scalability and resiliency equal to a data center

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Improved? Move/Copy Add-in Replacement - How to avoid the annoying, “A formula or sheet you want to move or copy contains the name XXX, which already exists on the destination worksheet.” David Miller (dlmille)  It was one of those days… I wa…
When you see single cell contains number and text, and you have to get any date out of it seems like cracking our heads.
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

860 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question