Solved

VBA - Adding message to indicate progress of import

Posted on 2010-09-07
3
394 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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Suggested Solutions

Introduction While answering a recent question (http:/Q_27311462.html), I created an alternative function to the Excel Concatenate() function that you might find useful.  I tested several solutions and share the results in this article as well as t…
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…
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.

910 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

Need Help in Real-Time?

Connect with top rated Experts

18 Experts available now in Live!

Get 1:1 Help Now