Solved

VBA - Adding message to indicate progress of import

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

What Security Threats Are You Missing?

Enhance your security with threat intelligence from the web. Get trending threat insights on hackers, exploits, and suspicious IP addresses delivered to your inbox with our free Cyber Daily.

Join & Write a Comment

Drop Down List with Unique/Distinct Values (Part II - ComboBox or ListBox and Data Validation List Bonus!) David Miller (dlmille) Intro This article focuses on delivering unique, sorted lists to list objects (e.g., ComboBox, ListBox) and Dat…
Introduction This Article briefly covers methods of calculating the NPV and IRR variants in Excel as well as the limitations in calculating and interpreting IRR results. Paraphrasing Richard Shockley, author of my favourite finance reference tex…
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

760 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

22 Experts available now in Live!

Get 1:1 Help Now