Dear All,

Is there a way I can create a database shortcut from Access on the desktop
of the current user entering the database? I would presume that you would
need to get the path of the database, get the path of the current user's
desktop and then create the desktop shortcut.

The first 2 are relatively easy but creating the shortcut is the problem
step.

I came across the code below which works well with VB but fails within
Access. The problem is with the creation of the text file:

Open Shortcut0 For Binary Access Read As #n0
'Wait for the file is correctly feed.
Do Until LOF(n0) > 0
Loop

At this point it gets stuck in a loop and sometimes creates the shortcut and
sometimes fails. Can someone offer me some guidance on this issue?

I currently create the shortcut as follows:

m_CreateShortcut CSIDL_DESKTOP, "MyFile", _
"C:\Documents and Settings\Alastair\Desktop\Shortcut.mdb", "C:\Documents
and Settings\Alastair\Desktop\Shortcut.mdb"

Thanks again.

Alastair MacFarlane


Option Explicit

'---------------------------
'Skrol 29
'(E-Mail Removed)
'http://www.rezo.net/dir/skrol29/
'---------------------------
'Version 1.00, on 02/13/1999
'Version 1.01, on 04/19/1999
'---------------------------
Public Const CSIDL_DESKTOP = &H0
Public Const CSIDL_PROGRAMS = &H2
Public Const CSIDL_PERSONAL = &H5
Public Const CSIDL_FAVORITES = &H6
Public Const CSIDL_STARTUP = &H7
Public Const CSIDL_RECENT = &H8
Public Const CSIDL_STARTMENU = &HB
Public Const CSIDL_COMMON_STARTMENU = &H16
Public Const CSIDL_COMMON_PROGRAMS = &H17
Public Const CSIDL_COMMON_STARTUP = &H18
Public Const CSIDL_COMMON_FAVORITES = &H1F

Public Declare Function api_SHAddToRecentDocs Lib _
"shell32.dll" Alias "SHAddToRecentDocs" (ByVal dwFlags As _
Long, ByVal dwData As String) As Long

Public Declare Function api_SHGetSpecialFolderLocation Lib _
"shell32.dll" Alias "SHGetSpecialFolderLocation" (ByVal _
hwndOwner As Long, ByVal nFolder As Long, pidl As Long) As Long

Public Declare Function api_SHGetPathFromIDList Lib _
"shell32.dll" Alias "SHGetPathFromIDList" _
(ByVal pidl As Long, ByValsPath As String) _
As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public AccessHwnd As Long




Public Sub m_CreateShortcut(ScFolder As Variant, ScCaption As _
String, TargetPath As String, Optional ScParam As String, _
Optional StartFolder As String, Optional IcoNum As Integer, _
Optional IcoPath As String, Optional WindowMode As Integer)

'If you want to use one of the windows folders for the shortcut
'location, you can pass one of the constants defined in the declarations,
e.g.,
' CSIDL_PROGRAMS = Programs
' CSIDL_STARTUP = Startup
' CSIDL_RECENT = RecentDocs
' CSIDL_DESKTOP = Desktop

'NOTE: AS WRITTEN THIS CODE MUST BE PLACED
'WITHIN A FORM MODULE

'Example: Puts a shortcut to Notepad on the desktop with
' a .txt document to be opened

' m_CreateShortcut CSIDL_DESKTOP, "MyFile", _
' "C:\windows\Notepad.exe", "C:\MyFile.txt"

Dim Shortcut0 As String 'Full path for the temporary shortcut
'created in the RecentDocs folder.
Dim n0 As Integer 'Cusror position in Shortcut0.
Dim x0 As String * 1 'Variable while reading Shortcut0.
Dim l0 As Long 'Lenth of the Shortcut0 file.
Dim Shortcut1 As String 'Full path for the final shortcut.
Dim n1 As Integer 'Cusror position in Shortcut1
Dim x1 As String * 1 'Variable while reading Shortcut1.
Dim l1 As Long 'Lenth of the Shortcut1 file

Dim T As Double
Dim p As Long
Dim i As Integer
Dim x As String
Dim y0 As String * 2

'Check for the target folder
If IsNumeric(ScFolder) Then
ScFolder = p_GetSpecialFolder(CInt(ScFolder))
ElseIf Dir$(ScFolder, vbDirectory) = "" Then
MsgBox "Le r·?rtoire '" & ScFolder & "' est introuvable.", _
vbCritical, "Cr?·on d'un raccrourci"
Exit Sub
End If

'Create a temporary shortcut with only the
'target in the the RecentDocs.
If api_SHAddToRecentDocs(2, TargetPath) > 0 Then

'Full path of the created shortcut
Shortcut0 = p_GetSpecialFolder(8) & "\" & _
p_File_Folder(TargetPath) & ".lnk"

'Waiting for the end of the creation.
T = Now()
Do Until (Dir$(Shortcut0) <> "")

If (Now() - T) > 0.00006 Then 'wait 5 seconds
If MsgBox("Attendre encore la cr?·on du raccourci ?", _
vbQuestion + vbOKCancel, "Raccourci") <> vbOK Then
Exit Sub
Else
T = Now()
End If
End If

Loop

'Open the temporary shortcut file in read mode.
n0 = FreeFile()

'****************** Problem Area Here *************************
Open Shortcut0 For Binary Access Read As #n0
'Wait for the file is correctly feed.
Do Until LOF(n0) > 0
Loop
'***********************************************************
l0 = LOF(n0)

'Open the shortcut file to create
Shortcut1 = ScFolder & "\" & ScCaption & ".lnk"
n1 = FreeFile()
Open Shortcut1 For Binary Access Write As #n1

'Look for the last byte to get
p = (l0 - 4)
y0 = ""
Do Until (p <= 0) Or (y0 = vbNullChar & vbNullChar)
Get #n0, p, y0
p = p - 1
Loop
l1 = p + 2

'Copy bytes
For p = 1 To l1

Get #n0, p, x0

Select Case p
Case 21 'path for icon, startup, parameters
i = 3
If StartFolder <> "" Then
i = i + 16
End If
If ScParam <> "" Then
i = i + 32
End If
If (IcoPath <> "") Or (IcoNum > 0) Then
i = i + 64
End If
x1 = Chr$(i)
Case 57 'Icon index
x1 = Chr$(IcoNum)
Case 61 'Window mode
x1 = Chr$(WindowMode)
Case Else
x1 = x0
End Select

Put #n1, p, x1

Next p

'Close and delete the temporary shorcut
Close #n0
Kill Shortcut0

'Add the Start folder, parameters and icon file
x = ""
If StartFolder <> "" Then
x = x & Chr$(Len(StartFolder)) & vbNullChar & StartFolder
End If
If ScParam <> "" Then
x = x & Chr$(Len(ScParam)) & vbNullChar & ScParam
End If
If IcoPath = "" Then
If IcoNum > 0 Then
x = x & Chr$(Len(TargetPath)) & vbNullChar _
& TargetPath
End If
Else
x = x & Chr$(Len(IcoPath)) & vbNullChar & IcoPath
End If
x = x & String(4, vbNullChar)
Put #n1, l1 + 1, x

Close #n1

Else

MsgBox "Error when creating the shortcut.", _
vbCritical, "Shortcut"

End If

End Sub

Private Function p_GetSpecialFolder(CsIdl As Long) As String

'Returns the full path of the folder corresponding to the
'Windows's id system folder.

Dim r As Long
Dim pidl As Long
Dim sPath As String

r = api_SHGetSpecialFolderLocation(AccessHwnd, CsIdl, pidl)

If r = 0 Then

sPath = Space$(260)
r = api_SHGetPathFromIDList(ByVal pidl, ByVal sPath)
If r Then
p_GetSpecialFolder = Left$(sPath, _
InStr(sPath, Chr$(0)) - 1)
End If

End If

End Function

Private Function p_File_Folder(FullPath As String) As String
'Returns the name of the file alone.

Dim i As Integer

p_File_Folder = FullPath
i = Len(FullPath)
Do Until i = 0
If Mid$(FullPath, i, 1) = "\" Then
p_File_Folder = Mid$(FullPath, i + 1)
i = 0
Else
i = i - 1
End If
Loop

End Function

There are examples of two different methods of creating shortcuts in the
following archived discussion. Hopefully at least one of them should work
for you ...

http://groups.google.com/group/comp....dcab3f11fb8780

--
Brendan Reynolds
Access MVP

"Alastair MacFarlane" <(E-Mail Removed)> wrote in message
news:%23Ob%(E-Mail Removed)...
> Dear All,
>
> Is there a way I can create a database shortcut from Access on the desktop
> of the current user entering the database? I would presume that you would
> need to get the path of the database, get the path of the current user's
> desktop and then create the desktop shortcut.
>
> The first 2 are relatively easy but creating the shortcut is the problem
> step.
>
> I came across the code below which works well with VB but fails within
> Access. The problem is with the creation of the text file:
>
> Open Shortcut0 For Binary Access Read As #n0
> 'Wait for the file is correctly feed.
> Do Until LOF(n0) > 0
> Loop
>
> At this point it gets stuck in a loop and sometimes creates the shortcut
> and sometimes fails. Can someone offer me some guidance on this issue?
>
> I currently create the shortcut as follows:
>
> m_CreateShortcut CSIDL_DESKTOP, "MyFile", _
> "C:\Documents and Settings\Alastair\Desktop\Shortcut.mdb", "C:\Documents
> and Settings\Alastair\Desktop\Shortcut.mdb"
>
> Thanks again.
>
> Alastair MacFarlane
>
>
> Option Explicit
>
> '---------------------------
> 'Skrol 29
> '(E-Mail Removed)
> 'http://www.rezo.net/dir/skrol29/
> '---------------------------
> 'Version 1.00, on 02/13/1999
> 'Version 1.01, on 04/19/1999
> '---------------------------
> Public Const CSIDL_DESKTOP = &H0
> Public Const CSIDL_PROGRAMS = &H2
> Public Const CSIDL_PERSONAL = &H5
> Public Const CSIDL_FAVORITES = &H6
> Public Const CSIDL_STARTUP = &H7
> Public Const CSIDL_RECENT = &H8
> Public Const CSIDL_STARTMENU = &HB
> Public Const CSIDL_COMMON_STARTMENU = &H16
> Public Const CSIDL_COMMON_PROGRAMS = &H17
> Public Const CSIDL_COMMON_STARTUP = &H18
> Public Const CSIDL_COMMON_FAVORITES = &H1F
>
> Public Declare Function api_SHAddToRecentDocs Lib _
> "shell32.dll" Alias "SHAddToRecentDocs" (ByVal dwFlags As _
> Long, ByVal dwData As String) As Long
>
> Public Declare Function api_SHGetSpecialFolderLocation Lib _
> "shell32.dll" Alias "SHGetSpecialFolderLocation" (ByVal _
> hwndOwner As Long, ByVal nFolder As Long, pidl As Long) As Long
>
> Public Declare Function api_SHGetPathFromIDList Lib _
> "shell32.dll" Alias "SHGetPathFromIDList" _
> (ByVal pidl As Long, ByValsPath As String) _
> As Long
> Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
> Public AccessHwnd As Long
>
>
>
>
> Public Sub m_CreateShortcut(ScFolder As Variant, ScCaption As _
> String, TargetPath As String, Optional ScParam As String, _
> Optional StartFolder As String, Optional IcoNum As Integer, _
> Optional IcoPath As String, Optional WindowMode As Integer)
>
> 'If you want to use one of the windows folders for the shortcut
> 'location, you can pass one of the constants defined in the declarations,
> e.g.,
> ' CSIDL_PROGRAMS = Programs
> ' CSIDL_STARTUP = Startup
> ' CSIDL_RECENT = RecentDocs
> ' CSIDL_DESKTOP = Desktop
>
> 'NOTE: AS WRITTEN THIS CODE MUST BE PLACED
> 'WITHIN A FORM MODULE
>
> 'Example: Puts a shortcut to Notepad on the desktop with
> ' a .txt document to be opened
>
> ' m_CreateShortcut CSIDL_DESKTOP, "MyFile", _
> ' "C:\windows\Notepad.exe", "C:\MyFile.txt"
>
> Dim Shortcut0 As String 'Full path for the temporary shortcut
> 'created in the RecentDocs folder.
> Dim n0 As Integer 'Cusror position in Shortcut0.
> Dim x0 As String * 1 'Variable while reading Shortcut0.
> Dim l0 As Long 'Lenth of the Shortcut0 file.
> Dim Shortcut1 As String 'Full path for the final shortcut.
> Dim n1 As Integer 'Cusror position in Shortcut1
> Dim x1 As String * 1 'Variable while reading Shortcut1.
> Dim l1 As Long 'Lenth of the Shortcut1 file
>
> Dim T As Double
> Dim p As Long
> Dim i As Integer
> Dim x As String
> Dim y0 As String * 2
>
> 'Check for the target folder
> If IsNumeric(ScFolder) Then
> ScFolder = p_GetSpecialFolder(CInt(ScFolder))
> ElseIf Dir$(ScFolder, vbDirectory) = "" Then
> MsgBox "Le r·?rtoire '" & ScFolder & "' est introuvable.", _
> vbCritical, "Cr?·on d'un raccrourci"
> Exit Sub
> End If
>
> 'Create a temporary shortcut with only the
> 'target in the the RecentDocs.
> If api_SHAddToRecentDocs(2, TargetPath) > 0 Then
>
> 'Full path of the created shortcut
> Shortcut0 = p_GetSpecialFolder(8) & "\" & _
> p_File_Folder(TargetPath) & ".lnk"
>
> 'Waiting for the end of the creation.
> T = Now()
> Do Until (Dir$(Shortcut0) <> "")
>
> If (Now() - T) > 0.00006 Then 'wait 5 seconds
> If MsgBox("Attendre encore la cr?·on du raccourci ?", _
> vbQuestion + vbOKCancel, "Raccourci") <> vbOK Then
> Exit Sub
> Else
> T = Now()
> End If
> End If
>
> Loop
>
> 'Open the temporary shortcut file in read mode.
> n0 = FreeFile()
>
> '****************** Problem Area Here *************************
> Open Shortcut0 For Binary Access Read As #n0
> 'Wait for the file is correctly feed.
> Do Until LOF(n0) > 0
> Loop
> '***********************************************************
> l0 = LOF(n0)
>
> 'Open the shortcut file to create
> Shortcut1 = ScFolder & "\" & ScCaption & ".lnk"
> n1 = FreeFile()
> Open Shortcut1 For Binary Access Write As #n1
>
> 'Look for the last byte to get
> p = (l0 - 4)
> y0 = ""
> Do Until (p <= 0) Or (y0 = vbNullChar & vbNullChar)
> Get #n0, p, y0
> p = p - 1
> Loop
> l1 = p + 2
>
> 'Copy bytes
> For p = 1 To l1
>
> Get #n0, p, x0
>
> Select Case p
> Case 21 'path for icon, startup, parameters
> i = 3
> If StartFolder <> "" Then
> i = i + 16
> End If
> If ScParam <> "" Then
> i = i + 32
> End If
> If (IcoPath <> "") Or (IcoNum > 0) Then
> i = i + 64
> End If
> x1 = Chr$(i)
> Case 57 'Icon index
> x1 = Chr$(IcoNum)
> Case 61 'Window mode
> x1 = Chr$(WindowMode)
> Case Else
> x1 = x0
> End Select
>
> Put #n1, p, x1
>
> Next p
>
> 'Close and delete the temporary shorcut
> Close #n0
> Kill Shortcut0
>
> 'Add the Start folder, parameters and icon file
> x = ""
> If StartFolder <> "" Then
> x = x & Chr$(Len(StartFolder)) & vbNullChar & StartFolder
> End If
> If ScParam <> "" Then
> x = x & Chr$(Len(ScParam)) & vbNullChar & ScParam
> End If
> If IcoPath = "" Then
> If IcoNum > 0 Then
> x = x & Chr$(Len(TargetPath)) & vbNullChar _
> & TargetPath
> End If
> Else
> x = x & Chr$(Len(IcoPath)) & vbNullChar & IcoPath
> End If
> x = x & String(4, vbNullChar)
> Put #n1, l1 + 1, x
>
> Close #n1
>
> Else
>
> MsgBox "Error when creating the shortcut.", _
> vbCritical, "Shortcut"
>
> End If
>
> End Sub
>
> Private Function p_GetSpecialFolder(CsIdl As Long) As String
>
> 'Returns the full path of the folder corresponding to the
> 'Windows's id system folder.
>
> Dim r As Long
> Dim pidl As Long
> Dim sPath As String
>
> r = api_SHGetSpecialFolderLocation(AccessHwnd, CsIdl, pidl)
>
> If r = 0 Then
>
> sPath = Space$(260)
> r = api_SHGetPathFromIDList(ByVal pidl, ByVal sPath)
> If r Then
> p_GetSpecialFolder = Left$(sPath, _
> InStr(sPath, Chr$(0)) - 1)
> End If
>
> End If
>
> End Function
>
> Private Function p_File_Folder(FullPath As String) As String
> 'Returns the name of the file alone.
>
> Dim i As Integer
>
> p_File_Folder = FullPath
> i = Len(FullPath)
> Do Until i = 0
> If Mid$(FullPath, i, 1) = "\" Then
> p_File_Folder = Mid$(FullPath, i + 1)
> i = 0
> Else
> i = i - 1
> End If
> Loop
>
> End Function
>
>
>
>

Brendan,

Thanks for the link. I have tested it and it works. I appreciate your time.

Alastair MacFarlane

"Brendan Reynolds" <(E-Mail Removed)> wrote in message
news:%23%(E-Mail Removed)...
>
> There are examples of two different methods of creating shortcuts in the
> following archived discussion. Hopefully at least one of them should work
> for you ...
>
> http://groups.google.com/group/comp....dcab3f11fb8780
>
> --
> Brendan Reynolds
> Access MVP
>
> "Alastair MacFarlane" <(E-Mail Removed)> wrote in message
> news:%23Ob%(E-Mail Removed)...
>> Dear All,
>>
>> Is there a way I can create a database shortcut from Access on the
>> desktop of the current user entering the database? I would presume that
>> you would need to get the path of the database, get the path of the
>> current user's desktop and then create the desktop shortcut.
>>
>> The first 2 are relatively easy but creating the shortcut is the problem
>> step.
>>
>> I came across the code below which works well with VB but fails within
>> Access. The problem is with the creation of the text file:
>>
>> Open Shortcut0 For Binary Access Read As #n0
>> 'Wait for the file is correctly feed.
>> Do Until LOF(n0) > 0
>> Loop
>>
>> At this point it gets stuck in a loop and sometimes creates the shortcut
>> and sometimes fails. Can someone offer me some guidance on this issue?
>>
>> I currently create the shortcut as follows:
>>
>> m_CreateShortcut CSIDL_DESKTOP, "MyFile", _
>> "C:\Documents and Settings\Alastair\Desktop\Shortcut.mdb",
>> "C:\Documents and Settings\Alastair\Desktop\Shortcut.mdb"
>>
>> Thanks again.
>>
>> Alastair MacFarlane
>>
>>
>> Option Explicit
>>
>> '---------------------------
>> 'Skrol 29
>> '(E-Mail Removed)
>> 'http://www.rezo.net/dir/skrol29/
>> '---------------------------
>> 'Version 1.00, on 02/13/1999
>> 'Version 1.01, on 04/19/1999
>> '---------------------------
>> Public Const CSIDL_DESKTOP = &H0
>> Public Const CSIDL_PROGRAMS = &H2
>> Public Const CSIDL_PERSONAL = &H5
>> Public Const CSIDL_FAVORITES = &H6
>> Public Const CSIDL_STARTUP = &H7
>> Public Const CSIDL_RECENT = &H8
>> Public Const CSIDL_STARTMENU = &HB
>> Public Const CSIDL_COMMON_STARTMENU = &H16
>> Public Const CSIDL_COMMON_PROGRAMS = &H17
>> Public Const CSIDL_COMMON_STARTUP = &H18
>> Public Const CSIDL_COMMON_FAVORITES = &H1F
>>
>> Public Declare Function api_SHAddToRecentDocs Lib _
>> "shell32.dll" Alias "SHAddToRecentDocs" (ByVal dwFlags As _
>> Long, ByVal dwData As String) As Long
>>
>> Public Declare Function api_SHGetSpecialFolderLocation Lib _
>> "shell32.dll" Alias "SHGetSpecialFolderLocation" (ByVal _
>> hwndOwner As Long, ByVal nFolder As Long, pidl As Long) As Long
>>
>> Public Declare Function api_SHGetPathFromIDList Lib _
>> "shell32.dll" Alias "SHGetPathFromIDList" _
>> (ByVal pidl As Long, ByValsPath As String) _
>> As Long
>> Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
>> Public AccessHwnd As Long
>>
>>
>>
>>
>> Public Sub m_CreateShortcut(ScFolder As Variant, ScCaption As _
>> String, TargetPath As String, Optional ScParam As String, _
>> Optional StartFolder As String, Optional IcoNum As Integer, _
>> Optional IcoPath As String, Optional WindowMode As Integer)
>>
>> 'If you want to use one of the windows folders for the shortcut
>> 'location, you can pass one of the constants defined in the declarations,
>> e.g.,
>> ' CSIDL_PROGRAMS = Programs
>> ' CSIDL_STARTUP = Startup
>> ' CSIDL_RECENT = RecentDocs
>> ' CSIDL_DESKTOP = Desktop
>>
>> 'NOTE: AS WRITTEN THIS CODE MUST BE PLACED
>> 'WITHIN A FORM MODULE
>>
>> 'Example: Puts a shortcut to Notepad on the desktop with
>> ' a .txt document to be opened
>>
>> ' m_CreateShortcut CSIDL_DESKTOP, "MyFile", _
>> ' "C:\windows\Notepad.exe", "C:\MyFile.txt"
>>
>> Dim Shortcut0 As String 'Full path for the temporary shortcut
>> 'created in the RecentDocs folder.
>> Dim n0 As Integer 'Cusror position in Shortcut0.
>> Dim x0 As String * 1 'Variable while reading Shortcut0.
>> Dim l0 As Long 'Lenth of the Shortcut0 file.
>> Dim Shortcut1 As String 'Full path for the final shortcut.
>> Dim n1 As Integer 'Cusror position in Shortcut1
>> Dim x1 As String * 1 'Variable while reading Shortcut1.
>> Dim l1 As Long 'Lenth of the Shortcut1 file
>>
>> Dim T As Double
>> Dim p As Long
>> Dim i As Integer
>> Dim x As String
>> Dim y0 As String * 2
>>
>> 'Check for the target folder
>> If IsNumeric(ScFolder) Then
>> ScFolder = p_GetSpecialFolder(CInt(ScFolder))
>> ElseIf Dir$(ScFolder, vbDirectory) = "" Then
>> MsgBox "Le r·?rtoire '" & ScFolder & "' est introuvable.", _
>> vbCritical, "Cr?·on d'un raccrourci"
>> Exit Sub
>> End If
>>
>> 'Create a temporary shortcut with only the
>> 'target in the the RecentDocs.
>> If api_SHAddToRecentDocs(2, TargetPath) > 0 Then
>>
>> 'Full path of the created shortcut
>> Shortcut0 = p_GetSpecialFolder(8) & "\" & _
>> p_File_Folder(TargetPath) & ".lnk"
>>
>> 'Waiting for the end of the creation.
>> T = Now()
>> Do Until (Dir$(Shortcut0) <> "")
>>
>> If (Now() - T) > 0.00006 Then 'wait 5 seconds
>> If MsgBox("Attendre encore la cr?·on du raccourci ?", _
>> vbQuestion + vbOKCancel, "Raccourci") <> vbOK Then
>> Exit Sub
>> Else
>> T = Now()
>> End If
>> End If
>>
>> Loop
>>
>> 'Open the temporary shortcut file in read mode.
>> n0 = FreeFile()
>>
>> '****************** Problem Area Here *************************
>> Open Shortcut0 For Binary Access Read As #n0
>> 'Wait for the file is correctly feed.
>> Do Until LOF(n0) > 0
>> Loop
>> '***********************************************************
>> l0 = LOF(n0)
>>
>> 'Open the shortcut file to create
>> Shortcut1 = ScFolder & "\" & ScCaption & ".lnk"
>> n1 = FreeFile()
>> Open Shortcut1 For Binary Access Write As #n1
>>
>> 'Look for the last byte to get
>> p = (l0 - 4)
>> y0 = ""
>> Do Until (p <= 0) Or (y0 = vbNullChar & vbNullChar)
>> Get #n0, p, y0
>> p = p - 1
>> Loop
>> l1 = p + 2
>>
>> 'Copy bytes
>> For p = 1 To l1
>>
>> Get #n0, p, x0
>>
>> Select Case p
>> Case 21 'path for icon, startup, parameters
>> i = 3
>> If StartFolder <> "" Then
>> i = i + 16
>> End If
>> If ScParam <> "" Then
>> i = i + 32
>> End If
>> If (IcoPath <> "") Or (IcoNum > 0) Then
>> i = i + 64
>> End If
>> x1 = Chr$(i)
>> Case 57 'Icon index
>> x1 = Chr$(IcoNum)
>> Case 61 'Window mode
>> x1 = Chr$(WindowMode)
>> Case Else
>> x1 = x0
>> End Select
>>
>> Put #n1, p, x1
>>
>> Next p
>>
>> 'Close and delete the temporary shorcut
>> Close #n0
>> Kill Shortcut0
>>
>> 'Add the Start folder, parameters and icon file
>> x = ""
>> If StartFolder <> "" Then
>> x = x & Chr$(Len(StartFolder)) & vbNullChar & StartFolder
>> End If
>> If ScParam <> "" Then
>> x = x & Chr$(Len(ScParam)) & vbNullChar & ScParam
>> End If
>> If IcoPath = "" Then
>> If IcoNum > 0 Then
>> x = x & Chr$(Len(TargetPath)) & vbNullChar _
>> & TargetPath
>> End If
>> Else
>> x = x & Chr$(Len(IcoPath)) & vbNullChar & IcoPath
>> End If
>> x = x & String(4, vbNullChar)
>> Put #n1, l1 + 1, x
>>
>> Close #n1
>>
>> Else
>>
>> MsgBox "Error when creating the shortcut.", _
>> vbCritical, "Shortcut"
>>
>> End If
>>
>> End Sub
>>
>> Private Function p_GetSpecialFolder(CsIdl As Long) As String
>>
>> 'Returns the full path of the folder corresponding to the
>> 'Windows's id system folder.
>>
>> Dim r As Long
>> Dim pidl As Long
>> Dim sPath As String
>>
>> r = api_SHGetSpecialFolderLocation(AccessHwnd, CsIdl, pidl)
>>
>> If r = 0 Then
>>
>> sPath = Space$(260)
>> r = api_SHGetPathFromIDList(ByVal pidl, ByVal sPath)
>> If r Then
>> p_GetSpecialFolder = Left$(sPath, _
>> InStr(sPath, Chr$(0)) - 1)
>> End If
>>
>> End If
>>
>> End Function
>>
>> Private Function p_File_Folder(FullPath As String) As String
>> 'Returns the name of the file alone.
>>
>> Dim i As Integer
>>
>> p_File_Folder = FullPath
>> i = Len(FullPath)
>> Do Until i = 0
>> If Mid$(FullPath, i, 1) = "\" Then
>> p_File_Folder = Mid$(FullPath, i + 1)
>> i = 0
>> Else
>> i = i - 1
>> End If
>> Loop
>>
>> End Function
>>
>>
>>
>>
>
>

I'm glad it worked for you, Alastair, but the credit really belongs to Tom
Mitchell and Terry Kreft, who posted the examples in that thread.

--
Brendan Reynolds
Access MVP

"Alastair MacFarlane" <(E-Mail Removed)> wrote in message
news:(E-Mail Removed)...
> Brendan,
>
> Thanks for the link. I have tested it and it works. I appreciate your
> time.
>
> Alastair MacFarlane
>
> "Brendan Reynolds" <(E-Mail Removed)> wrote in message
> news:%23%(E-Mail Removed)...
>>
>> There are examples of two different methods of creating shortcuts in the
>> following archived discussion. Hopefully at least one of them should work
>> for you ...
>>
>> http://groups.google.com/group/comp....dcab3f11fb8780
>>
>> --
>> Brendan Reynolds
>> Access MVP
>>
>> "Alastair MacFarlane" <(E-Mail Removed)> wrote in message
>> news:%23Ob%(E-Mail Removed)...
>>> Dear All,
>>>
>>> Is there a way I can create a database shortcut from Access on the
>>> desktop of the current user entering the database? I would presume that
>>> you would need to get the path of the database, get the path of the
>>> current user's desktop and then create the desktop shortcut.
>>>
>>> The first 2 are relatively easy but creating the shortcut is the problem
>>> step.
>>>
>>> I came across the code below which works well with VB but fails within
>>> Access. The problem is with the creation of the text file:
>>>
>>> Open Shortcut0 For Binary Access Read As #n0
>>> 'Wait for the file is correctly feed.
>>> Do Until LOF(n0) > 0
>>> Loop
>>>
>>> At this point it gets stuck in a loop and sometimes creates the shortcut
>>> and sometimes fails. Can someone offer me some guidance on this issue?
>>>
>>> I currently create the shortcut as follows:
>>>
>>> m_CreateShortcut CSIDL_DESKTOP, "MyFile", _
>>> "C:\Documents and Settings\Alastair\Desktop\Shortcut.mdb",
>>> "C:\Documents and Settings\Alastair\Desktop\Shortcut.mdb"
>>>
>>> Thanks again.
>>>
>>> Alastair MacFarlane
>>>
>>>
>>> Option Explicit
>>>
>>> '---------------------------
>>> 'Skrol 29
>>> '(E-Mail Removed)
>>> 'http://www.rezo.net/dir/skrol29/
>>> '---------------------------
>>> 'Version 1.00, on 02/13/1999
>>> 'Version 1.01, on 04/19/1999
>>> '---------------------------
>>> Public Const CSIDL_DESKTOP = &H0
>>> Public Const CSIDL_PROGRAMS = &H2
>>> Public Const CSIDL_PERSONAL = &H5
>>> Public Const CSIDL_FAVORITES = &H6
>>> Public Const CSIDL_STARTUP = &H7
>>> Public Const CSIDL_RECENT = &H8
>>> Public Const CSIDL_STARTMENU = &HB
>>> Public Const CSIDL_COMMON_STARTMENU = &H16
>>> Public Const CSIDL_COMMON_PROGRAMS = &H17
>>> Public Const CSIDL_COMMON_STARTUP = &H18
>>> Public Const CSIDL_COMMON_FAVORITES = &H1F
>>>
>>> Public Declare Function api_SHAddToRecentDocs Lib _
>>> "shell32.dll" Alias "SHAddToRecentDocs" (ByVal dwFlags As _
>>> Long, ByVal dwData As String) As Long
>>>
>>> Public Declare Function api_SHGetSpecialFolderLocation Lib _
>>> "shell32.dll" Alias "SHGetSpecialFolderLocation" (ByVal _
>>> hwndOwner As Long, ByVal nFolder As Long, pidl As Long) As Long
>>>
>>> Public Declare Function api_SHGetPathFromIDList Lib _
>>> "shell32.dll" Alias "SHGetPathFromIDList" _
>>> (ByVal pidl As Long, ByValsPath As String) _
>>> As Long
>>> Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
>>> Public AccessHwnd As Long
>>>
>>>
>>>
>>>
>>> Public Sub m_CreateShortcut(ScFolder As Variant, ScCaption As _
>>> String, TargetPath As String, Optional ScParam As String, _
>>> Optional StartFolder As String, Optional IcoNum As Integer, _
>>> Optional IcoPath As String, Optional WindowMode As Integer)
>>>
>>> 'If you want to use one of the windows folders for the shortcut
>>> 'location, you can pass one of the constants defined in the
>>> declarations, e.g.,
>>> ' CSIDL_PROGRAMS = Programs
>>> ' CSIDL_STARTUP = Startup
>>> ' CSIDL_RECENT = RecentDocs
>>> ' CSIDL_DESKTOP = Desktop
>>>
>>> 'NOTE: AS WRITTEN THIS CODE MUST BE PLACED
>>> 'WITHIN A FORM MODULE
>>>
>>> 'Example: Puts a shortcut to Notepad on the desktop with
>>> ' a .txt document to be opened
>>>
>>> ' m_CreateShortcut CSIDL_DESKTOP, "MyFile", _
>>> ' "C:\windows\Notepad.exe", "C:\MyFile.txt"
>>>
>>> Dim Shortcut0 As String 'Full path for the temporary shortcut
>>> 'created in the RecentDocs folder.
>>> Dim n0 As Integer 'Cusror position in Shortcut0.
>>> Dim x0 As String * 1 'Variable while reading Shortcut0.
>>> Dim l0 As Long 'Lenth of the Shortcut0 file.
>>> Dim Shortcut1 As String 'Full path for the final shortcut.
>>> Dim n1 As Integer 'Cusror position in Shortcut1
>>> Dim x1 As String * 1 'Variable while reading Shortcut1.
>>> Dim l1 As Long 'Lenth of the Shortcut1 file
>>>
>>> Dim T As Double
>>> Dim p As Long
>>> Dim i As Integer
>>> Dim x As String
>>> Dim y0 As String * 2
>>>
>>> 'Check for the target folder
>>> If IsNumeric(ScFolder) Then
>>> ScFolder = p_GetSpecialFolder(CInt(ScFolder))
>>> ElseIf Dir$(ScFolder, vbDirectory) = "" Then
>>> MsgBox "Le r·?rtoire '" & ScFolder & "' est introuvable.", _
>>> vbCritical, "Cr?·on d'un raccrourci"
>>> Exit Sub
>>> End If
>>>
>>> 'Create a temporary shortcut with only the
>>> 'target in the the RecentDocs.
>>> If api_SHAddToRecentDocs(2, TargetPath) > 0 Then
>>>
>>> 'Full path of the created shortcut
>>> Shortcut0 = p_GetSpecialFolder(8) & "\" & _
>>> p_File_Folder(TargetPath) & ".lnk"
>>>
>>> 'Waiting for the end of the creation.
>>> T = Now()
>>> Do Until (Dir$(Shortcut0) <> "")
>>>
>>> If (Now() - T) > 0.00006 Then 'wait 5 seconds
>>> If MsgBox("Attendre encore la cr?·on du raccourci ?", _
>>> vbQuestion + vbOKCancel, "Raccourci") <> vbOK Then
>>> Exit Sub
>>> Else
>>> T = Now()
>>> End If
>>> End If
>>>
>>> Loop
>>>
>>> 'Open the temporary shortcut file in read mode.
>>> n0 = FreeFile()
>>>
>>> '****************** Problem Area Here *************************
>>> Open Shortcut0 For Binary Access Read As #n0
>>> 'Wait for the file is correctly feed.
>>> Do Until LOF(n0) > 0
>>> Loop
>>> '***********************************************************
>>> l0 = LOF(n0)
>>>
>>> 'Open the shortcut file to create
>>> Shortcut1 = ScFolder & "\" & ScCaption & ".lnk"
>>> n1 = FreeFile()
>>> Open Shortcut1 For Binary Access Write As #n1
>>>
>>> 'Look for the last byte to get
>>> p = (l0 - 4)
>>> y0 = ""
>>> Do Until (p <= 0) Or (y0 = vbNullChar & vbNullChar)
>>> Get #n0, p, y0
>>> p = p - 1
>>> Loop
>>> l1 = p + 2
>>>
>>> 'Copy bytes
>>> For p = 1 To l1
>>>
>>> Get #n0, p, x0
>>>
>>> Select Case p
>>> Case 21 'path for icon, startup, parameters
>>> i = 3
>>> If StartFolder <> "" Then
>>> i = i + 16
>>> End If
>>> If ScParam <> "" Then
>>> i = i + 32
>>> End If
>>> If (IcoPath <> "") Or (IcoNum > 0) Then
>>> i = i + 64
>>> End If
>>> x1 = Chr$(i)
>>> Case 57 'Icon index
>>> x1 = Chr$(IcoNum)
>>> Case 61 'Window mode
>>> x1 = Chr$(WindowMode)
>>> Case Else
>>> x1 = x0
>>> End Select
>>>
>>> Put #n1, p, x1
>>>
>>> Next p
>>>
>>> 'Close and delete the temporary shorcut
>>> Close #n0
>>> Kill Shortcut0
>>>
>>> 'Add the Start folder, parameters and icon file
>>> x = ""
>>> If StartFolder <> "" Then
>>> x = x & Chr$(Len(StartFolder)) & vbNullChar & StartFolder
>>> End If
>>> If ScParam <> "" Then
>>> x = x & Chr$(Len(ScParam)) & vbNullChar & ScParam
>>> End If
>>> If IcoPath = "" Then
>>> If IcoNum > 0 Then
>>> x = x & Chr$(Len(TargetPath)) & vbNullChar _
>>> & TargetPath
>>> End If
>>> Else
>>> x = x & Chr$(Len(IcoPath)) & vbNullChar & IcoPath
>>> End If
>>> x = x & String(4, vbNullChar)
>>> Put #n1, l1 + 1, x
>>>
>>> Close #n1
>>>
>>> Else
>>>
>>> MsgBox "Error when creating the shortcut.", _
>>> vbCritical, "Shortcut"
>>>
>>> End If
>>>
>>> End Sub
>>>
>>> Private Function p_GetSpecialFolder(CsIdl As Long) As String
>>>
>>> 'Returns the full path of the folder corresponding to the
>>> 'Windows's id system folder.
>>>
>>> Dim r As Long
>>> Dim pidl As Long
>>> Dim sPath As String
>>>
>>> r = api_SHGetSpecialFolderLocation(AccessHwnd, CsIdl, pidl)
>>>
>>> If r = 0 Then
>>>
>>> sPath = Space$(260)
>>> r = api_SHGetPathFromIDList(ByVal pidl, ByVal sPath)
>>> If r Then
>>> p_GetSpecialFolder = Left$(sPath, _
>>> InStr(sPath, Chr$(0)) - 1)
>>> End If
>>>
>>> End If
>>>
>>> End Function
>>>
>>> Private Function p_File_Folder(FullPath As String) As String
>>> 'Returns the name of the file alone.
>>>
>>> Dim i As Integer
>>>
>>> p_File_Folder = FullPath
>>> i = Len(FullPath)
>>> Do Until i = 0
>>> If Mid$(FullPath, i, 1) = "\" Then
>>> p_File_Folder = Mid$(FullPath, i + 1)
>>> i = 0
>>> Else
>>> i = i - 1
>>> End If
>>> Loop
>>>
>>> End Function
>>>
>>>
>>>
>>>
>>
>>
>
>