Question

在VBA中，我有一个打开文本文件的函数。这允许我在表单上放置一个按钮，并在单击时显示一个文件。

该功能正常，但上述按钮被多次点击，它会一遍又一遍地打开同一个文件，而不仅仅是一次。

如何才能使文件只打开一次？

Sub OpenTextFile(ByVal filePath As String)

    If Len(Dir(filePath)) = 0 Then Exit Sub ' Ensure that the file to open actaully exists

    Dim txtFile As Variant
    txtFile = Shell("C:\WINDOWS\notepad.exe " & filePath, 1)

End Sub

Answer 1

首先检查先前是否已将Shell ID分配给Workbooks .CustomDocumentProperties属性。如果有，那么我们需要检查Shell ID实例是否仍然打开。我们可以通过使用Shell ID并将其传递到针对WHERE的查询的Win32_Process子句中来实现。

如果没有为该属性分配Shell ID，我们可以直接打开文本文件。打开文本文件后，我们使用新的文本文件Shell ID更新.CustomDocumentProperties属性。

Option Explicit

Sub OpenTextFile()

    Dim filePath As String
    Dim txtFile As Long
    Dim txtOpenCount As Integer

    Dim wb As Workbook
    Dim wmiService As Object, winQry As Object

    Set wb = ThisWorkbook

    On Error Resume Next
    txtFile = CLng(wb.CustomDocumentProperties("txtFileNum"))

    If Err.Number = 0 Then '' If CustomDocumentProperty returned _
                              without an error then use this to close txt file.

        Set wmiService = GetObject("winmgmts:" _
                                 & "{impersonationLevel=impersonate}!\\" _
                                 & ".\root\cimv2")
        Set winQry = wmiService.ExecQuery _
                     ("SELECT * from Win32_Process WHERE ProcessID = " & txtFile)

        txtOpenCount = winQry.Count

    End If

    On Error GoTo 0

    If txtOpenCount = 0 Then '' If the txtFile is not found, then open.

        filePath = "F:\test.txt"

        If txtFile > 0 Then
            wb.CustomDocumentProperties("txtFileNum").Delete
        End If

        txtFile = Shell("C:\WINDOWS\notepad.exe " & filePath, vbNormalFocus)

        '' Update CustomDocumentProperty with the new txtFile number.
        wb.CustomDocumentProperties.Add Name:="txtFileNum", _
                                        Value:=txtFile, _
                                        LinkToContent:=False, _
                                        Type:=msoPropertyTypeString

    End If

End Sub

如果您使用的是Access，则可以使用.CreateProperty方法，然后使用.Properties.Append方法。您必须将从.CreateProperty创建的属性传递到.Properties.Append方法。更新了以下代码。

Option Explicit

Sub OpenTextFile()

    Dim filePath As String
    Dim txtFile As Long, oTxt As Object
    Dim txtOpenCount As Integer

    Dim db As Database
    Dim wmiService As Object, winQry As Object

    Set db = CurrentDb

    On Error Resume Next
    txtFile = db.Properties("txtFileNum").Value

    If Err.Number = 0 Then '' If CustomDocumentProperty returned _
                              without an error then use this to close txt file.

        Set wmiService = GetObject("winmgmts:" _
                                 & "{impersonationLevel=impersonate}!\\" _
                                 & ".\root\cimv2")
        Set winQry = wmiService.ExecQuery _
                     ("SELECT * from Win32_Process WHERE ProcessID = " & txtFile)

        txtOpenCount = winQry.Count

    End If

    On Error GoTo 0

    If txtOpenCount = 0 Then '' If the txtFile is not found, then open.

        filePath = "F:\test.txt"

        If txtFile > 0 Then
            db.Properties.Delete "txtFileNum"
        End If

        txtFile = Shell("C:\WINDOWS\notepad.exe " & filePath, vbNormalFocus)

        '' Update db Properties with the new txtFile number.
        Set oTxt = db.CreateProperty("txtFileNum", dbLong, txtFile, False)
        db.Properties.Append oTxt


    End If

End Sub

Answer 2

如果你需要它。这是一个查看记事本是否正在运行的功能。

将这些声明为最佳。

Private Declare Function OpenProcess Lib "kernel32" ( _
    ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
    ByVal hObject As Long) As Long
Private Declare Function EnumProcesses Lib "PSAPI.DLL" ( _
    lpidProcess As Long, ByVal cb As Long, cbNeeded As Long) As Long
Private Declare Function EnumProcessModules Lib "PSAPI.DLL" ( _
    ByVal hProcess As Long, lphModule As Long, ByVal cb As Long, lpcbNeeded As Long) As Long
Private Declare Function GetModuleBaseName Lib "PSAPI.DLL" Alias "GetModuleBaseNameA" ( _
    ByVal hProcess As Long, ByVal hModule As Long, ByVal lpFileName As String, ByVal nSize As Long) As Long
Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_QUERY_INFORMATION = &H400

然后发送进程名称。 b = IsProcessRunning("notepad.exe")

Private Function IsProcessRunning(ByVal sProcess As String) As Boolean
'Check to see if a process is currently running
Const MAX_PATH      As Long = 260
Dim lProcesses()    As Long
Dim lModules()      As Long
Dim N               As Long
Dim lRet            As Long
Dim hProcess        As Long
Dim sName           As String

sProcess = UCase$(sProcess)
ReDim lProcesses(1023) As Long

If EnumProcesses(lProcesses(0), 1024 * 4, lRet) Then
    For N = 0 To (lRet \ 4) - 1
        hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or PROCESS_VM_READ, 0, lProcesses(N))
        If hProcess Then
            ReDim lModules(1023)
            If EnumProcessModules(hProcess, lModules(0), 1024 * 4, lRet) Then
                sName = String$(MAX_PATH, vbNullChar)
                GetModuleBaseName hProcess, lModules(0), sName, MAX_PATH
                sName = Left$(sName, InStr(sName, vbNullChar) - 1)
                If sProcess = UCase$(sName) Then
                    IsProcessRunning = True
                    Exit Function
                End If
            End If
        End If
        CloseHandle hProcess
    Next N
End If
End Function

仅打开文本文件的一个实例

2 个答案: