excel - VBA - 检查工作簿的状态和位置以运行外部宏

问题描述

这是情况（我会尽量让它清楚）；上下文优先：我正在制作一个 Excel 文件，我的团队将用作仪表板，其中包含指向各种文件、应用程序、弹出窗口等的链接。还有一个我们在工作中使用的显示错误目录，但对于文件大小缘故，我选择使用不同的工作簿并在打开后在那里调用宏。

所以我们有：

带有 Tab1 和 Tab2 的 FileA

带有宏的 FileB 可通过 FileA、Tab2 中的按钮运行

当我在 FileA、Tab1 中并单击一个按钮转到 Tab2 时，会运行一个自动打开 FileB 的宏。

当我在 FileA 的 Tab2 中时，我点击 Button1 以激活 FileB 中的相应宏

我放了一个代码来检查 FileA 是否位于它应该在的位置，如果 FileA 不在，一条消息询问我们是否要找到它并打开它。

在 Tab2 中，每当我们单击按钮运行宏时，都会在继续之前检查 FileB 是否打开。

还有一种无需打开 FileB（用于更新）即可进入 Tab2 的方法。在 Tab2 中，有一个打开 FileB 的链接和一个关闭它的链接。

我现在要做的是，当我单击将在 FileB 中启动宏的按钮时，会检查 FileB 是否打开，如果不打开它，还要检查它是否存储在正确的位置，以及是否没有，那么就问我们要不要找它。

我试着玩弄，但我就是无法解决这个问题，总是有冲突，或者我无法绕过的冗余。我的编码背景是不存在的，我通过查看在线修改了我的代码，到目前为止，我总能找到一些我可以轻松适应我的需求的代码，但在这种情况下不是。

以下是我一直在使用的代码......也许它可以帮助确定我打算做什么。任何帮助将不胜感激！另外，就像我说的那样，我在这里和那里进行了修补，所以添加的代码层可能变得多余了吗？我不确定......我已经暂停了几天，试图稍后再回来，但无济于事。

另外，请原谅我的法语评论……毕竟我在法国工作。

并且，是的，我知道，缩进不是那么好，但我计划在完成原型后对代码进行全面检查。

//////////////////////////////

这是我在 Tab1 和 Tab2 之间正常工作的代码：

'Permet d'assigner une navigation de Sheet en Sheet via des boutons (en l'occurence, les pastilles vertes) :
'ici, vers l'Herbier, qui ouvrira automatiquement un autre fichier
Sub Bascule_herbier_Click()
  
Sheets("Herbier").Visible = True
Sheets("Kiosk").Visible = False
Sheets("Support").Visible = False
Sheets("Divers").Visible = False
Sheets("CR200").Visible = False

MsgBox "Un fichier va s'ouvrir en arrière plan ; il se peut qu'il faille y accepter les macros : pour ce faire, cliquez sur le bouton jaune dans le bandeau supérieur de ce fichier, ou avant, sur la fenêtre qui pourrait s'ouvrir au milieu de l'écran.", vbOKOnly + vbInformation, "Action utilisateur"

'Par Excel-Malin.com ( https://excel-malin.com ) - Lance l'ouverture automatique du fichier cible pour les macros liées à l'Herbier

Dim Verification As Boolean
    Dim MonClasseur As String
   
    MonClasseur = "W:\Ateliers\PHOTO\Masks\Kiosk support\Kiosk - Fichiers utilitaires\Maskiosk_Companion_Herbier.xlsm"
   
    'D'abord tester si le fichier existe
    If Len(Dir(MonClasseur)) = 0 Then 's'il n'existe pas, montrer un avertissement et quitter la macro
        MsgBox "ERREUR: Le Classeur: [" & MonClasseur & "] n'est pas là où il devrait être"
       
        'Si le fichier n'est pas présent, on peut le le chercher et l'ouvrir ; le filtre est ciblé pour les fichiers Excel
        Dim Myfile_Name As Variant
Myfile_Name = Application.GetOpenFilename(FileFilter:="Excel Files(*.xl*),*.xl*)")

If Myfile_Name <> False Then
  Workbooks.Open FileName:=Myfile_Name
End If
    Exit Sub
    End If
 
  'Si le test est valide, le fichier va être ouvert ; dans cet autre fichier, une macro à l'ouverture va réduire la fenêtre pour rendre le focus sur le Kiosk
   On Error GoTo OuvertureFichierErreur
   Dim MonApplication As Object
   Dim MonFichier As String
   Set MonApplication = CreateObject("Shell.Application")
 
   MonFichier = "W:\Ateliers\PHOTO\Masks\Kiosk support\Kiosk - Fichiers utilitaires\Maskiosk_Companion_Herbier.xlsm"
   MonApplication.Open (MonFichier)
    
   Set MonApplication = Nothing
Exit Sub

OuvertureFichierErreur:
   Set MonApplication = Nothing
    MsgBox "Erreur lors de l'ouverture du fichier..."
  End Sub

//////////////////////////////

我一直在尝试使用的内容：

Sub Herbier_Appel_09()
Dim Ret

Dim wb As Workbook
For Each wb In Workbooks

    Ret = IsWorkBookOpen("\\crodisk.cro.st.com\w\Ateliers\PHOTO\Masks\Kiosk support\Kiosk - Fichiers utilitaires\Maskiosk_Companion_Herbier.xlsm")

    If Ret = True Then
       
    Else
        answer = MsgBox("Le Herbier Companion n'est pas ouvert ; voulez-vous l'ouvrir ?", vbYesNo + vbQuestion)
       
                On Error Resume Next
  If answer = vbYes Then

    Workbooks.Open "\\crodisk.cro.st.com\w\Ateliers\PHOTO\Masks\Kiosk support\Kiosk - Fichiers utilitaires\Maskiosk_Companion_Herbier.xlsm"

Else: End

End If
End If

Next

Application.Run "Maskiosk_Companion_Herbier.xlsm!RPR_01"

End Sub

'Variable necéssaire au check d'ouverture du Companion_Herbier ; chaque appel à cette variable est
'dans les divers Sub Herbier_Appel_##.

Function IsWorkBookOpen(FileName As String)
    Dim ff As Long, ErrNo As Long

    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0

    Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function

///////////////////////////////////////// ////////////

这也是：

Sub Sample020()
    Dim xRet As Boolean
    xRet = IsWorkBookOpen("Maskiosk_Companion_Herbier.xlsm")
    If xRet Then
    
    Else
         
    answer = MsgBox("Le Herbier Companion n'est pas ouvert ; voulez-vous l'ouvrir ?", vbYesNo + vbQuestion)
       
                On Error Resume Next
  If answer = vbYes Then

'D'abord tester si le fichier existe
    If Workbooks("Maskiosk_Companion_Herbier.xlsm").Open = 0 Then 's'il n'existe pas, montrer un avertissement et quitter la macro
        MsgBox "ERREUR: Le Classeur: [" & MonClasseur & "] n'est pas là où il devrait être"
       
        'Si le fichier n'est pas présent, on peut le le chercher et l'ouvrir ; le filtre est ciblé pour les fichiers Excel
        Dim Myfile_Name As Variant
Myfile_Name = Application.GetOpenFilename(FileFilter:="Excel Files(*.xl*),*.xl*)")

If Myfile_Name <> False Then
  Workbooks.Open FileName:=Myfile_Name
End If

    Workbooks.Open "\\crodisk.cro.st.com\w\Ateliers\PHOTO\Masks\Kiosk support\Kiosk - Fichiers utilitaires\Maskiosk_Companion_Herbier.xlsm"

Else: End

End If
End If
End If

Application.Run "Maskiosk_Companion_Herbier.xlsm!RPR_01"
End Sub

标签： excelvbastatus

尝试这个：

Option Explicit

Public Const MACRO_PATH As String = "\\crodisk.cro.st.com\w\Ateliers\PHOTO\Masks\" & _
                                    "Kiosk support\Kiosk - Fichiers utilitaires\"
Public Const MACRO_FILE As String = "Maskiosk_Companion_Herbier.xlsm"

Sub Tester()

     RunMacro "RPR_01"

End Sub

'Utility - run a macro by name
Function RunMacro(macroName As String) As Boolean
    'add quotes in case macro file name ever has spaces
    If MacroWorkbookOK Then Application.Run "'" & MACRO_FILE & "'!" & macroName
End Function

'utility - check for the macro workbook - return True if open or can be opened
Function MacroWorkbookOK() As Boolean
    Dim wb As Workbook, f
    
    'already open?
    On Error Resume Next
    Set wb = Workbooks(MACRO_FILE)
    On Error GoTo 0
    
    'not open - see if it can be opened from the expected path
    If wb Is Nothing Then
        On Error Resume Next 'in case network location is not found
        f = Dir(MACRO_PATH & MACRO_FILE)
        On Error GoTo 0
        If Len(f) > 0 Then
            Set wb = Workbooks.Open(MACRO_PATH & MACRO_FILE, ReadOnly:=True)
            ThisWorkbook.Activate
        End If
    End If
    
    'not open and not at expected path - ask user to browse
    If wb Is Nothing Then
        f = Application.GetOpenFilename(FileFilter:="Excel Files(*.xl*),*.xl*)", _
                                        Title:="Please locate the macro file '" & MACRO_FILE & "'")
        If f <> False Then
            If UCase(Dir(f)) <> UCase(MACRO_FILE) Then
                'warn user to select the correct file
                MsgBox "Selected file must be named '" & MACRO_FILE & "'"
            Else
                Set wb = Workbooks.Open(f, ReadOnly:=True)
                ThisWorkbook.Activate
            End If
        End If
    End If
    MacroWorkbookOK = Not wb Is Nothing
End Function

excel - VBA - 检查工作簿的状态和位置以运行外部宏

问题描述

解决方案

推荐阅读