Jim Dettman
jimdettman at verizon.net
Thu Jan 5 10:26:08 CST 2012
Forgive the length of this, but there are some things in here that you might
want to use (like where to create the shortcut).
Jim.
Attribute VB_Name = "OCS_Shortcuts"
Option Explicit
Function GenerateShortCuts(strDatabaseName As String, strRoot As String) As
Integer
' Using tblShortcuts, Create shortcuts required for a database.
Dim ws As DAO.Workspace
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim strShortcutName As String
' Dim pb As New Form_frm_ProgBar
Dim intNumberofDSNs As Integer
Dim intEntryCount As Integer
Dim WSHShell As Object
Dim strAllUsersDesktop As String
Dim strAllUsersPrograms As String
Dim strAllUsersStartmenu As String
Dim strAllUsersStartup As String
Dim strAllUsersMenuGroup As String
Dim strUserDesktop As String
Dim strUserPrograms As String
Dim strUserStartmenu As String
Dim strUserStartup As String
Dim strWinDirectory As String
Dim strUserMenuGroup As String
Dim strSystemMDW As String
Dim strProgPath As String
Dim strAppPath As String
Dim strIconPath As String
Dim strStartInPath As String
Dim strDatabase As String
Dim varRet As Variant
Dim intPos As Integer
On Error GoTo GenerateShortcuts_Err
Set ws = DBEngine.CreateWorkspace("", "Admin", "")
Set db = ws.OpenDatabase("P:\Traverse
Data\SetClientEnv\SetClientEnv.MDB")
Set rs = db.OpenRecordset("tblShortCuts")
intNumberofDSNs = rs.RecordCount
intEntryCount = 0
'pb.SetMessage "Creating Application Shortcuts"
' Get initial defaults
Set WSHShell = CreateObject("WScript.Shell")
strAllUsersDesktop = WSHShell.SpecialFolders("AllUsersDesktop")
strAllUsersPrograms = WSHShell.SpecialFolders("AllUsersPrograms")
strAllUsersStartmenu = WSHShell.SpecialFolders("AllUsersStartMenu")
strAllUsersStartup = WSHShell.SpecialFolders("AllUsersStartup")
strUserDesktop = WSHShell.SpecialFolders("Desktop")
strUserPrograms = WSHShell.SpecialFolders("Programs")
strUserStartmenu = WSHShell.SpecialFolders("StartMenu")
strUserStartup = WSHShell.SpecialFolders("Startup")
strWinDirectory = Left$(strUserDesktop, Len(strUserDesktop) - 8)
' Check if all users setting are correct
If strAllUsersDesktop = "" Then
strAllUsersDesktop = strWinDirectory & "\All Users\Desktop"
End If
If strAllUsersStartmenu = "" Then
strAllUsersStartmenu = strWinDirectory & "\All Users\Start Menu"
End If
If strAllUsersPrograms = "" Then
strAllUsersPrograms = strWinDirectory & "\All Users\Start
Menu\Programs"
End If
If strAllUsersStartup = "" Then
strAllUsersStartup = strWinDirectory & "\All Users\Start
Menu\Programs\Startup"
End If
With rs
While Not .EOF
' Check if this entry applies to this database.
If UCase(rs("DatabaseName")) = UCase(strDatabaseName) Then
strAllUsersMenuGroup = strAllUsersPrograms & "\" &
rs("MenuGroupName")
strUserMenuGroup = strUserPrograms & "\" & rs("MenuGroupName")
' Find Executeable path
If rs("ProgPath") = "MSACCESS.EXE" Then
' Note need to add version #'s to table
' hard coding for Access 2000 for now
' See if Access 2003 is installed.
'varRet = fReturnRegKeyValue(HKEY_CLASSES_ROOT,
"Access.Application.11\Shell\Open\Command", "")
'If Left$(varRet, 5) = "Error" Then
' Now see if Access 2000 is installed.
' Access 2000 is required. We don't want to use 2003.
varRet = fReturnRegKeyValue(HKEY_CLASSES_ROOT,
"Access.Application.9\Shell\Open\Command", "")
If Left$(varRet, 5) = "Error" Then
' Cannot locate Access
MsgBox "Access 2000 is not installed on this
machine. Please correct", vbCritical + vbOKOnly
strProgPath = ""
Else
intPos = InStr(1, varRet, "MSACCESS.EXE")
strProgPath = Mid$(varRet, 2, intPos + 10)
End If
'Else
' intPos = InStr(1, varRet, "MSACCESS.EXE")
' strProgPath = Mid$(varRet, 2, intPos + 10)
'End If
Else
strProgPath = rs("ProgPath")
End If
' Need to modify the all paths to point to the root
' drive if drive letter was not specified.
If IsNull(rs("AppPath")) Then
strAppPath = ""
Else
strAppPath = rs("AppPath")
End If
If Left$(strAppPath, 1) = "\" Then
strAppPath = strRoot & rs("AppPath")
End If
If Left$(rs("IconPath"), 1) = "\" Then
strIconPath = strRoot & rs("IconPath")
Else
strIconPath = rs("IconPath")
End If
If Left$(rs("StartinPath"), 1) = "\" Then
strStartInPath = strRoot & rs("StartinPath")
Else
strStartInPath = rs("StartinPath")
End If
' OK if we have everything, then let's do it!
If strProgPath <> "" Then
If rs("Desktop") Then
If rs("AllUsers") Then
Call CreateShortcut(strProgPath, _
strAppPath, _
strIconPath, _
strStartInPath, _
strAllUsersDesktop, _
rs("ShortcutName"))
Else
Call CreateShortcut(strProgPath, _
strAppPath, _
strIconPath, _
strStartInPath, _
strUserDesktop, _
rs("ShortcutName"))
End If
End If
If rs("StartMenu") Then
If rs("AllUsers") Then
Call CreateShortcut(strProgPath, _
strAppPath, _
strIconPath, _
strStartInPath, _
strAllUsersStartmenu, _
rs("ShortcutName"))
Else
Call CreateShortcut(strProgPath, _
strAppPath, _
strIconPath, _
strStartInPath, _
strUserStartmenu, _
rs("ShortcutName"))
End If
End If
If rs("ProgramMenu") Then
If rs("AllUsers") Then
Call CreateShortcut(strProgPath, _
strAppPath, _
strIconPath, _
strStartInPath, _
strAllUsersPrograms, _
rs("ShortcutName"))
Else
Call CreateShortcut(strProgPath, _
strAppPath, _
strIconPath, _
strStartInPath, _
strUserPrograms, _
rs("ShortcutName"))
End If
End If
If rs("MenuGroup") Then
If rs("AllUsers") Then
Call CreateShortcut(strProgPath, _
strAppPath, _
strIconPath, _
strStartInPath, _
strAllUsersMenuGroup, _
rs("ShortcutName"))
Else
Call CreateShortcut(strProgPath, _
strAppPath, _
strIconPath, _
strStartInPath, _
strUserMenuGroup, _
rs("ShortcutName"))
End If
End If
If rs("Startup") Then
If rs("AllUsers") Then
Call CreateShortcut(strProgPath, _
strAppPath, _
strIconPath, _
strStartInPath, _
strAllUsersStartup, _
rs("ShortcutName"))
Else
Call CreateShortcut(strProgPath, _
strAppPath, _
strIconPath, _
strStartInPath, _
strUserStartup, _
rs("ShortcutName"))
End If
End If
End If
End If
intEntryCount = intEntryCount + 1
'pb.SetBarPercent (intEntryCount / intNumberofDSNs) * 100
rs.MoveNext
Wend
End With
GenerateShortCuts = True
GenerateShortcuts_End:
On Error Resume Next
If Not rs Is Nothing Then
rs.Close
Set rs = Nothing
End If
If Not db Is Nothing Then
db.Close
Set db = Nothing
End If
If Not ws Is Nothing Then
ws.Close
Set ws = Nothing
End If
Set WSHShell = Nothing
Exit Function
GenerateShortcuts_Err:
GenerateShortCuts = False
Resume GenerateShortcuts_End
End Function
Private Function CreateShortcut(strProgramLocation As String, _
strAppPath As String, _
strIconPath As String, _
strStartInPath As String, _
strShortcutPath As String, _
strShortcutName As String) As Integer
Dim objWshShell As Object
Dim objWshShortcut As Object
' On Error GoTo CreateShortcut_Err
CreateShortcut = True
Set objWshShell = CreateObject("WScript.Shell")
If Len(Dir$(strShortcutPath & "\.", vbDirectory)) = 0 Then
' Folder doesn't exist. Need to create.
MkDir (strShortcutPath)
End If
Set objWshShortcut = objWshShell.CreateShortcut( _
strShortcutPath & "\" & strShortcutName & ".lnk")
With objWshShortcut
.TargetPath = strProgramLocation
If strAppPath <> "" Then
.Arguments = Chr$(34) & strAppPath & Chr$(34)
End If
.IconLocation = strIconPath & ",0"
.WorkingDirectory = strStartInPath
.WindowStyle = 4
.Save
End With
CreateShortcut_End:
On Error Resume Next
Set objWshShortcut = Nothing
Set objWshShell = Nothing
Exit Function
CreateShortcut_Err:
CreateShortcut = False
Resume CreateShortcut_End
End Function
-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of jwcolby
Sent: Thursday, January 05, 2012 10:08 AM
To: Access Developers discussion and problem solving
Subject: Re: [AccessD] Creating a shortcut programmatically
And then a new version to add things I need:
Public Enum ShellWindowStyle
SWS_None = -1
SWS_Hide = vbHide
SWS_MaximizedFocus = vbMaximizedFocus
SWS_MinimizedFocus = vbMinimizedFocus
SWS_NormalFocus = vbNormalFocus
End Enum
'
' CreateShellShortcut()
'
' TargetName - The file that would be launched when the shortcut is clicked.
' TargetArguments - Command line parameters to TargetName.
' TargetDescription - The description of the shortcut.
' ShortcutFileName - The shortcut file name including the .lnk extension.
'
' Copyright (C) 2002 OfficeOne
' http://support.microsoft.com/kb/244677
'
Sub CreateShellShortcut(ByVal TargetName As String, _
ByVal TargetArguments As String, _
ByVal TargetDescription As String, _
ByVal ShortcutFileName As String, _
WindowStyle As ShellWindowStyle, _
Optional strWorkingDir As String = "")
Dim WSH As Object
Dim Shortcut As Object
'dim sc as Wscript.shell.
Set WSH = CreateObject("WScript.Shell")
Set Shortcut = WSH.CreateShortcut(ShortcutFileName)
With Shortcut
.TargetPath = TargetName
.Arguments = TargetArguments
.Description = TargetDescription
.WindowStyle = WindowStyle
If Len(strWorkingDir) Then
.WorkingDirectory = strWorkingDir
End If
.Save
End With
Set Shortcut = Nothing
Set WSH = Nothing
End Sub
John W. Colby
Colby Consulting
Reality is what refuses to go away
when you do not believe in it
On 1/5/2012 8:52 AM, jwcolby wrote:
> I am building an application to Copy files and then open one of the files
copied which is an Access
> application. I have an Access Fe to handle the data entry for setting up
the files being copied etc,
> plus a C# application to handle the actual automation required to do the
copy and open. I then point
> the user to a shortcut to perform this Copy and Open.
>
> I found the following code on the internet which allows me to create the
shortcut itself
> programmatically using the information entered into the Access tables.
>
> '
> ' CreateShellShortcut()
> '
> ' TargetName - The file that would be launched when the shortcut is
clicked.
> ' TargetArguments - Command line parameters to TargetName.
> ' TargetDescription - The description of the shortcut.
> ' ShortcutFileName - The shortcut file name including the .lnk extension.
> '
> ' Copyright (C) 2002 OfficeOne
> '
> Sub CreateShellShortcut(ByVal TargetName As String, _
> ByVal TargetArguments As String, _
> ByVal TargetDescription As String, _
> ByVal ShortcutFileName As String)
>
> Dim WSH As Object
> Dim Shortcut As Object
>
> Set WSH = CreateObject("WScript.Shell")
> Set Shortcut = WSH.CreateShortcut(ShortcutFileName)
> With Shortcut
> .TargetPath = TargetName
> .Arguments = TargetArguments
> .Description = TargetDescription
> .Save
> End With
> Set Shortcut = Nothing
> Set WSH = Nothing
> End Sub
>
--
AccessD mailing list
AccessD at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/accessd
Website: http://www.databaseadvisors.com