jwcolby
jwcolby at colbyconsulting.com
Thu Jan 5 11:35:38 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).
Yes. I actually do that in the line that creates the thing.
John W. Colby
Colby Consulting
Reality is what refuses to go away
when you do not believe in it
On 1/5/2012 11:26 AM, Jim Dettman wrote:
> 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
>