Visual Basic Código VBA para criar atalho

[Douglas ianes]

Bom dia pessoal.

 

tem uma planilha que preciso salvar um atalho dela em outra pasta para consulta de outro setor, consegui esse código para criar o atalho:

 

<Dim Atalho As String, Pasta As String
Dim LocalExcel As String, Livro As String

Pasta = "C:\Users\douglas.i\Desktop\Nova pasta (2)\"
Atalho = Pasta & ActiveWorkbook.Name & ".lnk"

LocalExcel = Application.Path & "\Excel.exe"
Livro = ActiveWorkbook.FullName

Open Atalho For Output As #1
    Print #1, "[InternetShortcut]" & vbCrLf & "lnk = " & Livro
    Print #1, "IconIndex=1" & vbCrLf & "IconFile=" & LocalExcel
Close #1>

 

o atalho esta sendo criado mas o arquivo da erro na hora de abrir, ja tentei url e lnk 

lnk eu clico e não acontece nada com o atalho, url da mensagem de destino de internet não é valido

 

podem me ajudar.

[Midori]

@Douglas ianes Outra forma com Wsh,

Dim Atalho, Pasta   As String
Dim W, S            As Object
    
Pasta = "C:\Users\douglas.i\Desktop\Nova pasta (2)\"
Atalho = Pasta & ThisWorkbook.Name & ".lnk"
    
Set W = CreateObject("Wscript.Shell")
Set S = W.CreateShortcut(Atalho)
    
S.TargetPath = ThisWorkbook.FullName
S.IconLocation = Application.Path & "\Excel.exe"
S.Save

 

[Douglas ianes]

@Midori Muito obrigado, estou com meio caminho andando,

 

agora o problema que surgiu é que na hora que cria o atalho estou com 2 arquivos abertos, o arquivo XLSM e um arquivos XLSX que o codigo converte pra mim e apaga o XLSM ao final.

 

esta criando atalho do arquivo xlsm, preciso que crie do arquivo xlsx que esta sendo criado.

 

segue o codigo completo

 

<Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String

    Set Sourcewb = ActiveWorkbook

    'Copia a planilha inteira
    Sheets.Copy
    
    Set Destwb = ActiveWorkbook
    
                        FileExtStr = ".xlsx": FileFormatNum = 51
    
    'Salve a nova pasta de trabalho e feche-a
    TempFilePath = ThisWorkbook.Path & "\"
    TempFileName = VBA.Left(ThisWorkbook.Name, (VBA.InStrRev(ThisWorkbook.Name, ".", -1, VBA.vbTextCompare) - 1))

    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        
Dim Atalho, Pasta   As String
Dim W, S            As Object
    
Pasta = "\\105.103.12.249\oqc\04.OQC-INSPECTION\01.ANALISES\01.Analise de Falhas OQC\02.Banco de dados\2020\" & Nome & "\"
Atalho = Pasta & ThisWorkbook.Name & ".lnk"
    
Set W = CreateObject("Wscript.Shell")
Set S = W.CreateShortcut(Atalho)
    
S.TargetPath = ActiveWorkbook.FullName
S.IconLocation = Application.Path & "\Excel.exe"
S.Save

        .Close SaveChanges:=False
        
    End With
  

Dim xFullName As String
xFullName = Application.ActiveWorkbook.FullName
ActiveWorkbook.Saved = True
Application.ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill xFullName
Application.ActiveWorkbook.Close False

  Excel.Application.Quit>

adicionado 28 minutos depois

@Midori na realidade deu certo sim, eu me confundi porque ele esta pegando a extensão e utilizando como nome.

 

no caso eu quero que o atalho tenha o mesmo nome sem a extensão .xlsm como parte do nome.

[Midori]

29 minutos atrás, Douglas ianes disse:

esta criando atalho do arquivo xlsm, preciso que crie do arquivo xlsx que esta sendo criado.

É só passar o caminho do arquivo para a propriedade TargetPath.

 

As variáveis Temp e FileExt... não são do arquivo xlsx? Tente fazer assim,

 

S.TargetPath = TempFilePath & TempFileName & FileExtStr

 

 

[Douglas ianes]

3 horas atrás, Midori disse:

É só passar o caminho do arquivo para a propriedade TargetPath.

 

As variáveis Temp e FileExt... não são do arquivo xlsx? Tente fazer assim,

 

S.TargetPath = TempFilePath & TempFileName & FileExtStr

 

 

Deu certo sim, muito obrigado pela ajuda.