Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Menu de Atalho Past...
 
Notifications
Clear all

Menu de Atalho Pasta e Arquivos

 
2024 - VBA & Macros
Post Recente por xmiguelx 5 anos atrás
10 Posts
2 Usuários
0 Reactions
3,041 Visualizações
RSS
 xmiguelx
(@xmiguelx)
Posts: 34
Eminent Member
Topic starter
 

Olá amigos,

Estou criando uma planilha com vários botões de atalho, seja para arquivo ou pastas, o qual irei informar o caminho na planilha.
Gerei uma planilha de modelo para facilitar o entendimento. https://drive.google.com/file/d/1o9fDMDtVutefbvN_rovn4AVNCjyTtDKg/view?usp=sharing

O botão de abrir pasta, está funcionando perfeitamente.
Porém o botão de abrir arquivo tem algum problema, quando é feito a tentativa de abrir o arquivo, apresenta um erro de tempo de execução '9'.
Teria como solucionar?

Outra pergunta seria, é possível informar o caminho do arquivo ou pasta na planilha sem que tenha código de programação diferente para o botão? Pois para arquivo eu utilizo (Shell "C:WINDOWSexplorer.exe) e para Arquivo (Workbooks.Open Filename:)

Agradeço quem possa ajudar.


Private Sub bt_arquivo_Click()
Dim X, Y

X = 2
        For Contador = 3 To Sheets("CAMINHOS").Range("B30000").End(xlUp).Row
            If X = Sheets("CAMINHOS").Range("B" & Contador).Value Then
                    Y = Sheets("CAMINHOS").Range("D" & Contador).Value 'CAMINHO


 Application.ScreenUpdating = False
    Dim FilePath As String
    FilePath = ""
    On Error Resume Next
    FilePath = Dir(Y)
    On Error GoTo 0
    If FilePath = "" Then
        MsgBox "Acesso ao diretório de rede indisponível. Favor verificar!", vbInformation, "Kutools for Excel"
    Else
        Workbooks.Open Filename:=Y
End If
    End If
    Application.ScreenUpdating = False

Next Contador

End Sub


Private Sub bt_pasta_Click()
Dim X, Y

X = 1
        For Contador = 3 To Sheets("CAMINHOS").Range("B30000").End(xlUp).Row
            If X = Sheets("CAMINHOS").Range("B" & Contador).Value Then
                    Y = Sheets("CAMINHOS").Range("D" & Contador).Value 'CAMINHO


 Application.ScreenUpdating = False
    Dim FilePath As String
    FilePath = ""
    On Error Resume Next
    FilePath = Dir(Y)
    On Error GoTo 0
    If FilePath = "" Then
        MsgBox "Acesso ao diretório de rede indisponível. Favor verificar!", vbInformation, "Kutools for Excel"
    Else
 Shell "C:WINDOWSexplorer.exe """ & Y & "", vbNormalFocus
End If
    End If
    Application.ScreenUpdating = False

Next Contador




End Sub

abs

 
Postado : 25/12/2019 3:08 pm
 xmiguelx
(@xmiguelx)
Posts: 34
Eminent Member
Topic starter
 

Olá meu amigo!

Com sua ajuda, repliquei o mesmo comando para ambos os casos, e está funcionando, porem existe um erro ainda.

Quando clico no botão para abrir um arquivo que já esteja aberto, apresenta um erro de tempo de execução.
Seria possível se o arquivo já tiver aberto e for pressionado o botão não dar erro e apresentar uma mensagem avisando que o arquivo já esta aberto?

Abs


Private Sub bt_arquivo_Click()
Dim X, Y

X = 2
        For Contador = 3 To Sheets("CAMINHOS").Range("B30000").End(xlUp).Row
            If X = Sheets("CAMINHOS").Range("B" & Contador).Value Then
                    Y = Sheets("CAMINHOS").Range("D" & Contador).Value 'CAMINHO


 Application.ScreenUpdating = False
    Dim FilePath As String
    FilePath = ""
    On Error Resume Next
    FilePath = Dir(Y)
    On Error GoTo 0
    If FilePath = "" Then
        MsgBox "Acesso ao diretório de rede indisponível. Favor verificar!", vbInformation, "Kutools for Excel"
    Else
 Shell "C:WINDOWSexplorer.exe """ & Y & "", vbNormalFocus
        Exit Sub
End If
    End If
    Application.ScreenUpdating = False

Next Contador

End Sub


Private Sub bt_pasta_Click()
Dim X, Y

X = 1
        For Contador = 3 To Sheets("CAMINHOS").Range("B30000").End(xlUp).Row
            If X = Sheets("CAMINHOS").Range("B" & Contador).Value Then
                    Y = Sheets("CAMINHOS").Range("D" & Contador).Value 'CAMINHO


 Application.ScreenUpdating = False
    Dim FilePath As String
    FilePath = ""
    On Error Resume Next
    FilePath = Dir(Y)
    On Error GoTo 0
    If FilePath = "" Then
        MsgBox "Acesso ao diretório de rede indisponível. Favor verificar!", vbInformation, "Kutools for Excel"
    Else
 Shell "C:WINDOWSexplorer.exe """ & Y & "", vbNormalFocus
 Exit Sub
End If
    End If
    Application.ScreenUpdating = False

Next Contador


End Sub
 
Postado : 26/12/2019 6:03 am
 klarc28
(@klarc28)
Posts: 971
Prominent Member
 

Private Sub bt_arquivo_Click()
Dim X, Y
    Dim strPath As Variant
    Dim NomeArquivo As String
    Dim Posição As Variant


X = 2
        For Contador = 3 To Sheets("CAMINHOS").Range("B30000").End(xlUp).Row
            If X = Sheets("CAMINHOS").Range("B" & Contador).Value Then
                    Y = Sheets("CAMINHOS").Range("D" & Contador).Value 'CAMINHO
    strPath = Y
    Posição = InStrRev(strPath, "", , vbTextCompare)
    NomeArquivo = Mid(strPath, Posição + 1, Len(strPath) - Posição)
    
If IsFileOpen(NomeArquivo) Then
MsgBox "O arquivo se encontra em aberto!"
Exit Sub
End If

 Application.ScreenUpdating = False
    Dim FilePath As String
    FilePath = ""
    On Error Resume Next
    FilePath = Dir(Y)
    On Error GoTo 0
    If FilePath = "" Then
        MsgBox "Acesso ao diretório de rede indisponível. Favor verificar!", vbInformation, "Kutools for Excel"
    Else
        Workbooks.Open filename:=Y
        Exit Sub
End If
    End If
    Application.ScreenUpdating = False

Next Contador

End Sub


Private Sub bt_pasta_Click()
Dim X, Y

X = 1
        For Contador = 3 To Sheets("CAMINHOS").Range("B30000").End(xlUp).Row
            If X = Sheets("CAMINHOS").Range("B" & Contador).Value Then
                    Y = Sheets("CAMINHOS").Range("D" & Contador).Value 'CAMINHO


 Application.ScreenUpdating = False
    Dim FilePath As String
    FilePath = ""
    On Error Resume Next
    FilePath = Dir(Y)
    On Error GoTo 0
    If FilePath = "" Then
        MsgBox "Acesso ao diretório de rede indisponível. Favor verificar!", vbInformation, "Kutools for Excel"
    Else
 Shell "C:WINDOWSexplorer.exe """ & Y & "", vbNormalFocus
 Exit Sub
End If
    End If
    Application.ScreenUpdating = False

Next Contador




End Sub

Function IsFileOpen(ByVal filename As String)
'Verificar se o arquivo está em aberto
Dim FileNum As Integer, errnum As Integer
On Error Resume Next
FileNum = FreeFile()
Open filename For Input Lock Read As #FileNum
Close FileNum
errnum = Err
On Error GoTo 0
Select Case errnum
Case 0
IsFileOpen = False
Case 70
IsFileOpen = True
Case Else
Error errnum
End Select
End Function
 
Postado : 26/12/2019 6:45 am
 xmiguelx
(@xmiguelx)
Posts: 34
Eminent Member
Topic starter
 

Amigo klarc,

Tentei utilizar o código informado, porém está apresentando o seguinte erro:

Erro de copilação:
Tipo incompatível de argumento ByRef.

Planilha de exemplo:
https://drive.google.com/file/d/1ODi71G ... sp=sharing

Abs

 
Postado : 26/12/2019 7:00 am
 klarc28
(@klarc28)
Posts: 971
Prominent Member
 
Private Sub bt_arquivo_Click()
Dim X, Y
    Dim strPath As Variant
    Dim NomeArquivo As String
    Dim Posição As Variant


X = 2
        For Contador = 3 To Sheets("CAMINHOS").Range("B30000").End(xlUp).Row
            If X = Sheets("CAMINHOS").Range("B" & Contador).Value Then
                    Y = Sheets("CAMINHOS").Range("D" & Contador).Value 'CAMINHO
    strPath = Y
    Posição = InStrRev(strPath, "", , vbTextCompare)
    NomeArquivo = Mid(strPath, Posição + 1, Len(strPath) - Posição)
   
If IsFileOpen(NomeArquivo) Then
MsgBox "O arquivo se encontra em aberto!"
Exit Sub
End If

Application.ScreenUpdating = False
    Dim FilePath As String
    FilePath = ""
    On Error Resume Next
    FilePath = Dir(Y)
    On Error GoTo 0
    If FilePath = "" Then
        MsgBox "Acesso ao diretório de rede indisponível. Favor verificar!", vbInformation, "Kutools for Excel"
    Else
        Workbooks.Open filename:=Y
        Exit Sub
End If
    End If
    Application.ScreenUpdating = False

Next Contador

End Sub


Private Sub bt_pasta_Click()
Dim X, Y

X = 1
        For Contador = 3 To Sheets("CAMINHOS").Range("B30000").End(xlUp).Row
            If X = Sheets("CAMINHOS").Range("B" & Contador).Value Then
                    Y = Sheets("CAMINHOS").Range("D" & Contador).Value 'CAMINHO


Application.ScreenUpdating = False
    Dim FilePath As String
    FilePath = ""
    On Error Resume Next
    FilePath = Dir(Y)
    On Error GoTo 0
    If FilePath = "" Then
        MsgBox "Acesso ao diretório de rede indisponível. Favor verificar!", vbInformation, "Kutools for Excel"
    Else
Shell "C:WINDOWSexplorer.exe """ & Y & "", vbNormalFocus
Exit Sub
End If
    End If
    Application.ScreenUpdating = False

Next Contador




End Sub

Function IsFileOpen(ByVal filename As String)
'Verificar se o arquivo está em aberto
Dim FileNum As Integer, errnum As Integer
On Error Resume Next
FileNum = FreeFile()
Open filename For Input Lock Read As #FileNum
Close FileNum
errnum = Err
On Error GoTo 0
Select Case errnum
Case 0
IsFileOpen = False
Case 70
IsFileOpen = True
Case Else
'Error errnum
End Select
End Function
 
Postado : 26/12/2019 7:22 am
 xmiguelx
(@xmiguelx)
Posts: 34
Eminent Member
Topic starter
 

Amigo klarc,

Agora está apresentando o seguinte erro:

Erro em tempo de execução '53'
O arquivo não foi localizado.

Abs

 
Postado : 26/12/2019 7:43 am
 klarc28
(@klarc28)
Posts: 971
Prominent Member
 
Private Sub bt_arquivo_Click()
Dim X, Y
    Dim strPath As Variant
    Dim NomeArquivo As String
    Dim Posição As Variant


X = 2
        For Contador = 3 To Sheets("CAMINHOS").Range("B30000").End(xlUp).Row
            If X = Sheets("CAMINHOS").Range("B" & Contador).Value Then
                    Y = Sheets("CAMINHOS").Range("D" & Contador).Value 'CAMINHO
    strPath = Y
    Posição = InStrRev(strPath, "", , vbTextCompare)
    NomeArquivo = Mid(strPath, Posição + 1, Len(strPath) - Posição)
   
If IsFileOpen(NomeArquivo) Then
MsgBox "O arquivo se encontra em aberto!"
Exit Sub
End If

Application.ScreenUpdating = False
    Dim FilePath As String
    FilePath = ""
    On Error Resume Next
    FilePath = Dir(Y)
    On Error GoTo 0
    If FilePath = "" Then
        MsgBox "Acesso ao diretório de rede indisponível. Favor verificar!", vbInformation, "Kutools for Excel"
    Else
        Workbooks.Open filename:=Y
        Exit Sub
End If
    End If
    Application.ScreenUpdating = False

Next Contador

End Sub


Private Sub bt_pasta_Click()
Dim X, Y

X = 1
        For Contador = 3 To Sheets("CAMINHOS").Range("B30000").End(xlUp).Row
            If X = Sheets("CAMINHOS").Range("B" & Contador).Value Then
                    Y = Sheets("CAMINHOS").Range("D" & Contador).Value 'CAMINHO


Application.ScreenUpdating = False
    Dim FilePath As String
    FilePath = ""
    On Error Resume Next
    FilePath = Dir(Y)
    On Error GoTo 0
    If FilePath = "" Then
        MsgBox "Acesso ao diretório de rede indisponível. Favor verificar!", vbInformation, "Kutools for Excel"
    Else
Shell "C:WINDOWSexplorer.exe """ & Y & "", vbNormalFocus
Exit Sub
End If
    End If
    Application.ScreenUpdating = False

Next Contador




End Sub

Function IsFileOpen(ByVal filename As String)
'Verificar se o arquivo está em aberto
Dim FileNum As Integer, errnum As Integer
On Error Resume Next
FileNum = FreeFile()
Open filename For Input Lock Read As #FileNum
Close FileNum
errnum = Err
On Error GoTo 0
Select Case errnum
Case 0
IsFileOpen = False
Case 70
IsFileOpen = True
Case Else
'Error errnum
End Select
End Function
 
Postado : 26/12/2019 7:50 am
 xmiguelx
(@xmiguelx)
Posts: 34
Eminent Member
Topic starter
 

Klarc

Estava apresentando o erro ainda, porém percebi que o arquivo já aberto estava ativo e ao clicar novamente para abrir o arquivo, era necessário ativar a planilha onde estava o Menu, pois o formulário estava ativo sobre o arquivo aberto.

Inclui a seguinte linha: Workbooks("MENU - teste3.xlsm").Activate

Porém agora ele não apresenta erro, mas ele não avisa que o arquivo já está aberto, e reabre o arquivo.

Private Sub bt_arquivo_Click()
Dim X, Y
    Dim strPath As Variant
    Dim NomeArquivo As String
    Dim Posição As Variant


X = 2
Workbooks("MENU - teste3.xlsm").Activate
        For Contador = 3 To Sheets("CAMINHOS").Range("B30000").End(xlUp).Row
            If X = Sheets("CAMINHOS").Range("B" & Contador).Value Then
                    Y = Sheets("CAMINHOS").Range("D" & Contador).Value 'CAMINHO
    strPath = Y
    Posição = InStrRev(strPath, "", , vbTextCompare)
    NomeArquivo = Mid(strPath, Posição + 1, Len(strPath) - Posição)
   
If IsFileOpen(NomeArquivo) Then
MsgBox "O arquivo se encontra em aberto!"
Exit Sub
End If

Application.ScreenUpdating = False
    Dim FilePath As String
    FilePath = ""
    On Error Resume Next
    FilePath = Dir(Y)
    On Error GoTo 0
    If FilePath = "" Then
        MsgBox "Acesso ao diretório de rede indisponível. Favor verificar!", vbInformation, "Kutools for Excel"
    Else
Shell "C:WINDOWSexplorer.exe """ & Y & "", vbNormalFocus
        Exit Sub
End If
    End If
    Application.ScreenUpdating = False

Next Contador

End Sub


Private Sub bt_pasta_Click()
Dim X, Y

X = 1
        For Contador = 3 To Sheets("CAMINHOS").Range("B30000").End(xlUp).Row
            If X = Sheets("CAMINHOS").Range("B" & Contador).Value Then
                    Y = Sheets("CAMINHOS").Range("D" & Contador).Value 'CAMINHO


Application.ScreenUpdating = False
    Dim FilePath As String
    FilePath = ""
    On Error Resume Next
    FilePath = Dir(Y)
    On Error GoTo 0
    If FilePath = "" Then
        MsgBox "Acesso ao diretório de rede indisponível. Favor verificar!", vbInformation, "Kutools for Excel"
    Else
Shell "C:WINDOWSexplorer.exe """ & Y & "", vbNormalFocus
Exit Sub
End If
    End If
    Application.ScreenUpdating = False

Next Contador




End Sub

Function IsFileOpen(ByVal filename As String)
'Verificar se o arquivo está em aberto
Dim FileNum As Integer, errnum As Integer
On Error Resume Next
FileNum = FreeFile()
Open filename For Input Lock Read As #FileNum
Close FileNum
errnum = Err
On Error GoTo 0
Select Case errnum
Case 0
IsFileOpen = False
Case 70
IsFileOpen = True
Case Else
'Error errnum
End Select
End Function
 
Postado : 26/12/2019 9:01 am
 xmiguelx
(@xmiguelx)
Posts: 34
Eminent Member
Topic starter
 

Klarc,

De qualquer forma, muito obrigado, seus retornos agregaram muitos conhecidos.

Abs

 
Postado : 26/12/2019 4:55 pm
 xmiguelx
(@xmiguelx)
Posts: 34
Eminent Member
Topic starter
 

Amigo Klarc,

Muito obrigado pela ajuda, conforme sugerido, utilizei o comando abaixo e funcionou perfeitamente.

Abs

Private Sub bt_arquivo_Click()

Dim X As Variant
Dim Y As Variant
Dim strPath As Variant
Dim NomeArquivo As Variant
Dim Posição As Variant


X = 2
Workbooks("MENU - X.xlsm").Activate
        For Contador = 3 To Sheets("CAMINHOS").Range("B30000").End(xlUp).Row
            If X = Sheets("CAMINHOS").Range("B" & Contador).Value Then
                    Y = Sheets("CAMINHOS").Range("D" & Contador).Value 'CAMINHO


strPath = Sheets("CAMINHOS").Range("D" & Contador).Value
Posição = InStrRev(Sheets("CAMINHOS").Range("D" & Contador).Value, "", , vbTextCompare)
NomeArquivo = Mid(Sheets("CAMINHOS").Range("D" & Contador).Value, Posição + 1, Len(strPath) - Posição)


If Dir(Sheets("CAMINHOS").Range("D" & Contador).Value) = vbNullString Then
strCheck = False
Else
strCheck = True
End If
If strCheck Then
If IsFileOpen(Y) Then
MsgBox "O arquivo se encontra em aberto!"
Workbooks(NomeArquivo).Activate
Exit Sub
Else
Workbooks.Open (Sheets("CAMINHOS").Range("D" & Contador).Value)
Exit Sub
End If
Else
Mensagem = MsgBox("O arquivo " & NomeArquivo & " não foi encontrado!", vbInformation)

End If
End If
Next Contador
End Sub

Function IsFileOpen(ByVal filename As String)
'Verificar se o arquivo está em aberto
Dim FileNum As Integer, errnum As Integer
On Error Resume Next
FileNum = FreeFile()
Open filename For Input Lock Read As #FileNum
Close FileNum
errnum = Err
On Error GoTo 0
Select Case errnum
Case 0
IsFileOpen = False
Case 70
IsFileOpen = True
Case Else
'Error errnum
End Select
End Function
 
Postado : 27/12/2019 12:36 pm
Forum Jump:
  Tópico Anterior
Próximo Tópico