title image


Smiley Mit API gehts auch :-)
So:







Option Compare Database

Option Explicit



'---------------------------

'Skrol 29

'skrol29@freesurf.fr

'http://www.rezo.net/dir/skrol29/

'---------------------------

'Version 1.00, on 02/13/1999

'Version 1.01, on 04/19/1999

'---------------------------

Private Const CSIDL_DESKTOP = &H0

Private Const CSIDL_PROGRAMS = &H2

Private Const CSIDL_PERSONAL = &H5

Private Const CSIDL_FAVORITES = &H6

Private Const CSIDL_STARTUP = &H7

Private Const CSIDL_RECENT = &H8

Private Const CSIDL_STARTMENU = &HB

Private Const CSIDL_COMMON_STARTMENU = &H16

Private Const CSIDL_COMMON_PROGRAMS = &H17

Private Const CSIDL_COMMON_STARTUP = &H18

Private Const CSIDL_COMMON_FAVORITES = &H1F



Private Declare Function api_SHAddToRecentDocs Lib _

"shell32.dll" Alias "SHAddToRecentDocs" (ByVal dwFlags As _

Long, ByVal dwData As String) As Long



Private Declare Function api_SHGetSpecialFolderLocation Lib _

"shell32.dll" Alias "SHGetSpecialFolderLocation" (ByVal _

hwndOwner As Long, ByVal nFolder As Long, pidl As Long) As Long



Private Declare Function api_SHGetPathFromIDList Lib _

"shell32.dll" Alias "SHGetPathFromIDList" _

(ByVal pidl As Long, ByValsPath As String) _

As Long



Sub Teste_m_CreateShortcut()

'TESTAUFRUF

m_CreateShortcut CSIDL_DESKTOP, "MyFile", _

"C:\windows\Notepad.exe", "C:\MyFile.txt", , 0, "C:\windows\Notepad.exe"

End Sub



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épertoire '" & ScFolder & "' est introuvable.", _

vbCritical, "Création 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éation 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()

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(Application.hWndAccessApp, 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






Schöne Grüße
Ralf

(Ich verwende: Windows XP / Office XP)


Meine Links:
Meine Homepage
DBWiki
The Access Web


geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: