Criando atalhos no VB

Criando atalhos no Visual Basic

Que tal um programa feito em Visual Basic para criar atalhos para qualquer aplicação. Para começar vou mostrar o formulário do projeto em execução . Na figura abaixo eu estou criando um atalho para o aplicativo Visdata.exe com o nome de Visdata em c:\Windows\Desktop

Inicie um novo projeto no VB tipo Standard EXE e insira no formulário os seguintes controles :

2 componentes TextBox alterando seus nomes para : txtPath e txtNome
3 componentes CommandButton com os seguintes nomes : cmdBrowse , cmdCria , cmdExclui
Inclua os seguintes componentes : DriveListBox - Drive1 , DirListBox - Dir1 e FileListBox - File1
1 componente CommonDialog com o nome de dlg
1 componente ListBox com o nome de lst

Faça uma referência através do menu Project|References a biblioteca - Windows Script Host Object Model

1- Na seção General Declarations informe :

Option Explicit
Dim wShell As IWshShell_Class

2- No evento Load do formulário digite o código :

Private Sub Form_Load()

Dim temp
Set wShell = New IWshShell_Class

For Each temp In wShell.SpecialFolders
lst.AddItem temp
If InStr(temp, "Start Menu") <> 0 Then lst.ListIndex = lst.ListCount - 1
Next
End Sub

3- Agora no evento click dos componentes : DriveListBox , DirListBox e ListBox temos o código:

Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive & "\"
End Sub

Private Sub Dir1_Change()
File1.Path = Dir1.List(Dir1.ListIndex)
If File1.ListCount > 0 Then File1.ListIndex = 0
End Sub

Private Sub lst_Click()
Drive1.Drive = Left(lst.List(lst.ListIndex), 2)
Dir1.Path = lst.List(lst.ListIndex)
End Sub

4- Agora o código do evento Click dos botões - CmdCria , CmdExclui e CmdProcura:

'Cria um atalho
Private Sub cmdCria_Click()

On Error Resume Next
Dim wShortcut As IWshShortcut_Class

If Dir(txtPath) = "" Then
   MsgBox "Aplicação não localizada..."
ElseIf Trim(txtName) = "" Then
   MsgBox "Nome do atalho esta faltando."
Else
   Set wShortcut = wShell.CreateShortcut(Dir1.Path & "\" & txtName & ".lnk")
   wShortcut.TargetPath = txtPath
   wShortcut.Save
   File1.Refresh
End If

If Err <> 0 Then MsgBox "Impossível criar atalho"
End Sub

'Exclui um atalho
Private Sub cmdExclui_Click()
    If File1.ListIndex > -1 Then
         Kill File1.Path & "\" & File1.FileName
         File1.Refresh
         If File1.ListCount > 0 Then File1.ListIndex = 0
    End If
End Sub

'Procura por uma aplicação
Private Sub cmdProcura_Click()
   dlg.FileName = "*.exe"
   dlg.ShowOpen
   txtPath = dlg.FileName
End Sub

Com pouco código temos uma aplicação bem legal ...

Creio que a novidade seja a utilização do Windows Script Host Object Model. Vale a pena dar uma olhada no Help do VB sobre ele.

Até a próxima dica VB

José Carlos Macoratti