1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89
| Option Explicit
Type SH_ITEMID
cb As Long
aID As Byte
End Type
Type ITEMIDLIST
mkid As SH_ITEMID
End Type
Const CSIDL_RECENT = &H8
Const NOERROR = &H0
Dim Obj As Object
Const Key = "HKCU\Software\Microsoft\Windows\CurrentVersion\"
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function lOpen Lib "kernel32" Alias "_lopen" (ByVal lpPathName As String, ByVal iReadWrite As Long) As Long
Private Declare Function lClose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long
Dim FSO As New FileSystemObject, FF&
Private Function GetSpecialfolder(CSIDL As Long) As String
Dim Ret&
Dim IDL As ITEMIDLIST, sPath$
Ret = SHGetSpecialFolderLocation(100, CSIDL, IDL)
If Ret = NOERROR Then
sPath$ = Space$(512)
Ret = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal sPath$)
GetSpecialfolder = Left$(sPath, InStr(sPath, Chr$(0)) - 1)
Exit Function
End If
GetSpecialfolder = ""
End Function
Private Function IsFileInUse(FileName) As Boolean
Dim hFile As Long
Dim lastErr As Long
hFile = -1
lastErr = 0
hFile = lOpen(FileName, &H10)
If hFile = -1 Then
lastErr = Err.LastDllError
Else
lClose (hFile)
End If
IsFileInUse = (hFile = -1) And (lastErr = 32)
End Function
Public Sub Main()
Dim Fold As Folder, ApName$, Apath$, f As File, fd As Folder
Dim strSave As String
Dim strTemp As String
strTemp = String(100, Chr$(0))
GetTempPath 100, strTemp
strTemp = Left$(strTemp, InStr(strTemp, Chr$(0)) - 1)
ApName = UCase(App.EXEName) + ".EXE"
Apath = IIf(Right(App.Path, 1) = "\", UCase(App.Path), UCase(App.Path) + "\")
Set Fold = FSO.GetFolder(GetSpecialfolder(CSIDL_RECENT))
For Each f In Fold.Files
f.Attributes = 0
f.Delete True
Next f
Set Fold = FSO.GetFolder(strTemp)
For Each f In Fold.Files
'On Error Resume Next
If Not IsFileInUse(f) Then
f.Attributes = 0
f.Delete True
End If
Next f
For Each fd In Fold.SubFolders
fd.Attributes = 0
fd.Delete True
Next fd
Set Obj = CreateObject("Wscript.Shell")
With Obj
On Error GoTo CREER
If .RegRead(Key & "Run\" & ApName) = "" Then
.RegWrite Key & "Run\" & ApName, Apath & ApName
Else
GoTo FIN
End If
End With
CREER:
Obj.RegWrite Key & "Run\" & ApName, Apath & ApName
Err.Clear
FIN:
Err.Clear
End Sub |
Partager