活动屏幕上的VBA中心用户表单

时间:2015-04-24 07:36:32

标签: excel-vba excel-2013 vba excel

我想知道是否有人可以帮助我。

我正在使用下面的“提取”代码,只需单击一个按钮即可,正如您可能看到的那样,通过滚动进度条初始化“Splash”表单。

Private Sub btnFetchFiles_Click()

    Dim j As Integer

    'Display the splash form non-modally.
    Set frm = New frmSplash
    frm.TaskDone = False
    frm.prgStatus.Value = 0
'    frm.Show False

    For j = 1 To 1000
        DoEvents
        Next j

        iRow = 20
        fPath = "\\c\s\CAF1\Dragon Mentor Group\Dragon Scripts\Current\April 2015"
        If fPath <> "" Then
            Set FSO = New Scripting.FileSystemObject
            frm.prgStatus.Value = 10
            If FSO.FolderExists(fPath) <> False Then
                frm.prgStatus.Value = 20
                Set SourceFolder = FSO.GetFolder(fPath)
                IsSubFolder = True
                frm.prgStatus.Value = 30
                Call DeleteRows
                frm.prgStatus.Value = 40
                If AllFilesCheckBox.Value = True Then
                    frm.prgStatus.Value = 50
                    Call ListFilesInFolder(SourceFolder, IsSubFolder)
                    frm.prgStatus.Value = 60
                    Call ResultSorting(xlAscending, "C20")
                    frm.prgStatus.Value = 70
                Else
                    Call ListFilesInFolderXtn(SourceFolder, IsSubFolder)
                    frm.prgStatus.Value = 80
                    Call ResultSorting(xlAscending, "C20")
                    frm.prgStatus.Value = 90
                End If
                Call FormatCells
                lblFCount.Caption = iRow - 20
                frm.prgStatus.Value = 100
            End If
        End If
 frm.TaskDone = True
        Unload frm
'The row below creates a 'On Screen' message telling the user that the workbook has been built.
        iMessage = MsgBox("All the files have been extracted", vbOKOnly)
'The row below automatically takes the user to the "Launch Sheet".
    End Sub

因为我正在使用双显示器,所以我一直在研究如何将启动画面置于“活动窗口”的中心位置,并且其中一篇帖子让我使用下面的代码:

Private Sub UserForm_Initialize()

    Me.BackColor = RGB(174, 198, 207)
        With frmSplash
            .StartUpPosition = 0
            .Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
            .Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
    .Show
End With
End Sub

我现在遇到的问题是,虽然'Splash'屏幕可见并且现在以活动窗口为中心,但提取宏不再有效,我真的不确定原因。

我只是想知道是否有人可以看到这个,让我知道我哪里出错了。

非常感谢和亲切的问候

克里斯

2 个答案:

答案 0 :(得分:2)

您遇到的问题是您将表单显示为模式,这会停止执行后台代码。

在表单属性中将ShowModal设置为false。

答案 1 :(得分:1)

我只是想发布我的工作解决方案,该解决方案基于我所写的内容,工作同事能够完成。

代码如下:

Private Sub UserForm_Initialize()

    Me.BackColor = RGB(174, 198, 207)
End Sub

Private Sub Workbook_Open()

    Dim j As Integer

    'Display the splash form non-modally.
    Set frm = New frmSplash
    With frm
        .TaskDone = False
        .prgStatus.Value = 0
        .StartUpPosition = 0
        .Left = Application.Left + (0.5 * Application.Width) - (0.5 * .Width)
        .Top = Application.Top + (0.5 * Application.Height) - (0.5 * .Height)
        .Show False
    End With

    For j = 1 To 1000
        DoEvents
        Next j

        iRow = 17
        fPath = "\\c\s\CAF1\Dragon Mentor Group\Dragon Scripts\Current\April 2015"
        If fPath <> "" Then
            Set FSO = New Scripting.FileSystemObject
            frm.prgStatus.Value = 15
            If FSO.FolderExists(fPath) <> False Then
                frm.prgStatus.Value = 30
                Set SourceFolder = FSO.GetFolder(fPath)
                IsSubFolder = True
                frm.prgStatus.Value = 45
                Call DeleteRows
                frm.prgStatus.Value = 60
                    Call ListFilesInFolder(SourceFolder, IsSubFolder)
                    frm.prgStatus.Value = 75
                Call FormatCells
                frm.prgStatus.Value = 100
            End If
        End If
 frm.TaskDone = True
        Unload frm
'The row below creates a 'On Screen' message telling the user that the workbook has been built.
        iMessage = MsgBox("All the files have been extracted", vbOKOnly)
'The row below automatically takes the user to the "Launch Sheet".
End Sub

非常感谢和亲切的问候

克里斯