VBA Kill file but send it to recycle bin, Not permanently delete it.

Copy the code to a new module:

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Windows API functions, constants,and types.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Declare Function SHFileOperation Lib "shell32.dll" Alias _
    "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long

Private Declare Function PathIsNetworkPath Lib "shlwapi.dll" _
    Alias "PathIsNetworkPathA" ( _
    ByVal pszPath As String) As Long

Private Declare Function GetSystemDirectory Lib "kernel32" _
    Alias "GetSystemDirectoryA" ( _
    ByVal lpBuffer As String, _
    ByVal nSize As Long) As Long

Private Declare Function SHEmptyRecycleBin _
    Lib "shell32" Alias "SHEmptyRecycleBinA" _
    (ByVal hwnd As Long, _
     ByVal pszRootPath As String, _
     ByVal dwFlags As Long) As Long

Private Declare Function PathIsDirectory Lib "shlwapi" (ByVal pszPath As String) As Long

Private Const FO_DELETE = &H3
Private Const FOF_ALLOWUNDO = &H40
Private Const FOF_NOCONFIRMATION = &H10
Private Const MAX_PATH As Long = 260

Private Type SHFILEOPSTRUCT
    hwnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Boolean
    hNameMappings As Long
    lpszProgressTitle As String
End Type


Public Function Recycle(FileSpec As String, Optional ErrText As String) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Recycle
' This function sends FileSpec to the Recycle Bin. There
' are no restriction on what can be recycled. FileSpec
' must be a fully qualified folder or file name on the
' local machine.
' The function returns True if successful or False if
' an error occurs. If an error occurs, the reason for the
' error is placed in the ErrText varaible.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim SHFileOp As SHFILEOPSTRUCT
Dim Res As Long
Dim sFileSpec As String

ErrText = vbNullString
sFileSpec = FileSpec

If InStr(1, FileSpec, ":", vbBinaryCompare) = 0 Then
    ''''''''''''''''''''''''''''''''''''''
    ' Not a fully qualified name. Get out.
    ''''''''''''''''''''''''''''''''''''''
    ErrText = "'" & FileSpec & "' is not a fully qualified name on the local machine"
    Recycle = False
    Exit Function
End If

If Dir(FileSpec, vbDirectory) = vbNullString Then
    ErrText = "'" & FileSpec & "' does not exist"
    Recycle = False
    Exit Function
End If

''''''''''''''''''''''''''''''''''''
' Remove trailing '\' if required.
''''''''''''''''''''''''''''''''''''
If Right(sFileSpec, 1) = "\" Then
    sFileSpec = Left(sFileSpec, Len(sFileSpec) - 1)
End If


With SHFileOp
    .wFunc = FO_DELETE
    .pFrom = sFileSpec
    .fFlags = FOF_ALLOWUNDO
    '''''''''''''''''''''''''''''''''
    ' If you want to supress the
    ' "Are you sure?" message, use
    ' the following:
    '''''''''''''''''''''''''''''''
    .fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION
End With

Res = SHFileOperation(SHFileOp)
If Res = 0 Then
    Recycle = True
Else
    Recycle = False
End If

End Function


Public Function RecycleSafe(FileSpec As String, Optional ByRef ErrText As String) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' RecycleSafe
' This sends a file or folder to the Recycle Bin as long as it is not
' a protected file or folder. Protected files or folders are:
'   ThisWorkbook
'   ThisWorkbook.Path
'   Any root directory
'   C:\Windows\System32
'   C:\Windows
'   C:\Program Files
'   My Documents
'   Desktop
'   Application.Path
'   Any path with wildcard characters ( * or ? )
' The function returns True if successful or False if an error occurs. If
' False, the reason is put in the ErrText variable.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Dim ThisWorkbookFullName As String
Dim ThisWorkbookPath As String
Dim WindowsFolder As String
Dim SystemFolder As String
Dim ProgramFiles As String
Dim MyDocuments As String
Dim Desktop As String
Dim ApplicationPath As String
Dim Pos As Long
Dim ShellObj As Object
Dim sFileSpec As String
Dim SHFileOp As SHFILEOPSTRUCT
Dim Res As Long
Dim FileNum As Integer

sFileSpec = FileSpec
If InStr(1, FileSpec, ":", vbBinaryCompare) = 0 Then
    RecycleSafe = False
    ErrText = "'" & FileSpec & "' is not a fully qualified name on the local machine"
    Exit Function
End If

If Dir(FileSpec, vbDirectory) = vbNullString Then
    RecycleSafe = False
    ErrText = "'" & FileSpec & "' does not exist"
    Exit Function
End If

''''''''''''''''''''''''''''''''''''''''''
' Strip trailing '\' if required.
''''''''''''''''''''''''''''''''''''''''''
If Right(sFileSpec, 1) = "\" Then
    sFileSpec = Left(sFileSpec, Len(sFileSpec) - 1)
End If
    

''''''''''''''''''''''''''''''''''''''''''
' ThisWorkbook name and path.
''''''''''''''''''''''''''''''''''''''''''
ThisWorkbookFullName = ThisWorkbook.FullName
ThisWorkbookPath = ThisWorkbook.Path

''''''''''''''''''''''''''''''''''''''''''
' SystemFolder and Windows folder. Windows
' folder is parent of SystemFolder.
''''''''''''''''''''''''''''''''''''''''''
SystemFolder = String$(MAX_PATH, vbNullChar)
GetSystemDirectory SystemFolder, Len(SystemFolder)
SystemFolder = Left(SystemFolder, InStr(1, SystemFolder, vbNullChar, vbBinaryCompare) - 1)

Pos = InStrRev(SystemFolder, "\")
If Pos > 0 Then
    WindowsFolder = Left(SystemFolder, Pos - 1)
End If

'''''''''''''''''''''''''''''''''''''''''''''''
' Program Files. Top parent of Application.Path
'''''''''''''''''''''''''''''''''''''''''''''''
Pos = InStr(1, Application.Path, "\", vbBinaryCompare)
Pos = InStr(Pos + 1, Application.Path, "\", vbBinaryCompare)
ProgramFiles = Left(Application.Path, Pos - 1)

'''''''''''''''''''''''''''''''''''''''''''''''
' Application Path
'''''''''''''''''''''''''''''''''''''''''''''''
ApplicationPath = Application.Path


'''''''''''''''''''''''''''''''''''''''''''''''
' UserFolders
'''''''''''''''''''''''''''''''''''''''''''''''
On Error Resume Next
Err.Clear
Set ShellObj = CreateObject("WScript.Shell")
If ShellObj Is Nothing Then
    RecycleSafe = False
    ErrText = "Error Creating WScript.Shell. " & CStr(Err.Number) & ": " & Err.Description
    Exit Function
End If
MyDocuments = ShellObj.specialfolders("MyDocuments")
Desktop = ShellObj.specialfolders("Desktop")
Set ShellObj = Nothing

''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Test FileSpec to see if it is a root folder.
''''''''''''''''''''''''''''''''''''''''''''''''''''''
If (sFileSpec Like "?*:") Or (sFileSpec Like "?*:\") Then
    RecycleSafe = False
    ErrText = "File Specification is a root directory."
    Exit Function
End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Test file paths for prohibited paths.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''
If (InStr(1, sFileSpec, "*", vbBinaryCompare) > 0) Or (InStr(1, sFileSpec, "?", vbBinaryCompare) > 0) Then
    RecycleSafe = False
    ErrText = "File specification contains wildcard characters"
    Exit Function
End If

If StrComp(sFileSpec, ThisWorkbookFullName, vbTextCompare) = 0 Then
    RecycleSafe = False
    ErrText = "File specification is the same as this workbook."
    Exit Function
End If

If StrComp(sFileSpec, ThisWorkbookPath, vbTextCompare) = 0 Then
    RecycleSafe = False
    ErrText = "File specification is this workbook's path"
    Exit Function
End If

If StrComp(ThisWorkbook.FullName, sFileSpec, vbTextCompare) = 0 Then
    RecycleSafe = False
    ErrText = "File specification is this workbook."
    Exit Function
End If

If StrComp(sFileSpec, SystemFolder, vbTextCompare) = 0 Then
    RecycleSafe = False
    ErrText = "File specification is the System Folder"
    Exit Function
End If

If StrComp(sFileSpec, WindowsFolder, vbTextCompare) = 0 Then
    RecycleSafe = False
    ErrText = "File specification is the Windows folder"
    Exit Function
End If

If StrComp(sFileSpec, Application.Path, vbTextCompare) = 0 Then
    RecycleSafe = False
    ErrText = "File specification is Application Path"
    Exit Function
End If

If StrComp(sFileSpec, MyDocuments, vbTextCompare) = 0 Then
    RecycleSafe = False
    ErrText = "File specification is MyDocuments"
    Exit Function
End If

If StrComp(sFileSpec, Desktop, vbTextCompare) = 0 Then
    RecycleSafe = False
    ErrText = "File specification is Desktop"
    Exit Function
End If

If (GetAttr(sFileSpec) And vbSystem) <> 0 Then
    RecycleSafe = False
    ErrText = "File specification is a System entity"
    Exit Function
End If

''''''''''''''''''''''''''''''''''''''''
' Test if File is open. Do not test
' if FileSpec is a directory.
''''''''''''''''''''''''''''''''''''''''

If PathIsDirectory(sFileSpec) = 0 Then
    FileNum = FreeFile()
    On Error Resume Next
    Err.Clear
    Open sFileSpec For Input Lock Read As #FileNum
    If Err.Number <> 0 Then
        Close #FileNum
        RecycleSafe = False
        ErrText = "File in use: " & CStr(Err.Number) & "  " & Err.Description
        Exit Function
    End If
    Close #FileNum
End If
        

With SHFileOp
    .wFunc = FO_DELETE
    .pFrom = sFileSpec
    .fFlags = FOF_ALLOWUNDO
    '''''''''''''''''''''''''''''''''
    ' If you want to supress the
    ' "Are you sure?" message, use
    ' the following:
    '''''''''''''''''''''''''''''''
    .fFlags = FOF_ALLOWUNDO + FOF_NOCONFIRMATION
End With

Res = SHFileOperation(SHFileOp)
If Res = 0 Then
    RecycleSafe = True
Else
    RecycleSafe = False
End If

End Function

Select allOpen in new window

Then instead of using:

Kill FileName

Select allOpen in new window

use

Recycle FileName

Select allOpen in new window

or

RecycleSafe FileName

Select allOpen in new window

MacroShadow,

thanks so very much.  

i tried this by myself first, but some parts of the code show red in my excel. i googled and it says not compatible with excel 64bit. any idea how to fix that?

the link took me somewhere else shopping site.

i googled downloaded the win32API file from msft and then could not find this PathIsNetworkPath  one in it.

Does this work? It's very old VB6 code.

Option Explicit

Private Type SHFILEOPSTRUCT
    hWnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Boolean
    hNameMappings As Long
    lpszProgressTitle As String
End Type

Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long

Private Const FO_DELETE = &H3
Private Const FOF_ALLOWUNDO = &H40
Private Const FOF_CREATEPROGRESSDLG As Long = &H0

Private Enum WhatDoIDoWithIt
    RemoveToRecycle = 1
    Remove = 2
End Enum

Private Function RemoveFile(FileName As String, How As WhatDoIDoWithIt) As Boolean
    
    Dim FileOperation As SHFILEOPSTRUCT
    Dim RetCode As Long
    
    On Error GoTo RemoveError
    
    With FileOperation
        .wFunc = FO_DELETE
        .pFrom = FileName
        ' The FOF_CREATEPROGRESSDLG is optional. It pops up the message
        ' box asking if you want to send the file to the recycle bin,
        ' or if you are sure you want to delete it.
        If How = RemoveToRecycle Then
            .fFlags = FOF_ALLOWUNDO + FOF_CREATEPROGRESSDLG
        Else
            .fFlags = FO_DELETE + FOF_CREATEPROGRESSDLG
        End If
    End With
    
    RetCode = SHFileOperation(FileOperation)
    If RetCode <> 0 Then
        RemoveFile = False
    Else
        RemoveFile = True
    End If
    
    Exit Function
    
RemoveError:
    RemoveFile = False
    MsgBox Err & " " & Error
End Function

Private Sub cmdRecycle_Click()

' Send it to the recycle bin
RemoveFile "c:\test.txt", RemoveToRecycle

End Sub

Private Sub cmdRemove_Click()

' Delete it entirely, as with Kill
RemoveFile "c:\test.txt", Remove

End Sub

Select allOpen in new window

You can use WMI to get the SID.
Examples in this article:
https://blogs.technet.microsoft.com/heyscriptingguy/2004/12/03/how-can-i-determine-the-sid-for-a-user-account/

Where did you get that code, Martin?

Where did you get that code, Martin?

Too long ago for me to remember.

thanks aikimark and Martin.  i could not make this work in Excel 64Bit. now, i hate 64 bit any code i find, is not compatible with 64bit.

can't you instantiate FileSystemObject and WMI objects in your environment?

can't you instantiate FileSystemObject and WMI objects in your environment?

why every EE link i am clicking takes me to http://www.viglink.com/shop

what is going on?

aikimark,  excuse my ignorance, but how can instantiate it?  where do i get the code?

why every EE link i am clicking takes me to http://www.viglink.com/shop

Maybe a virus?

it is only happening with any link inside EE. maybe EE is infected with virus?

set oFS = CreateObject("scripting.filesystemobject")

Select allOpen in new window

aikimark,

i tried with this, but it states invalid onject path. on  Set objAccount

Sub test()

strComputer = "."

Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\cimv2")

Set objAccount = objWMIService.Get("Win32_UserAccount.Name='kenmyer',Domain='FLORA-JJDNF541")

MsgBox objAccount.SID

End Sub

Select allOpen in new window

i can use this set oFS = CreateObject("scripting.filesystemobject")

it is only happening with any link inside EE. maybe EE is infected with virus?

I clicked the link in aikimar's post ID 421305134 and it worked as expected.

Martin,
you right click on the link then

you paste it on notepad then you get the
https://redirect.viglink.com/?format=go&jsonp=vglnk_149450726387615&key=c7e3cc67cf9c9844a05ec4b1326edddd&libId=j2kf05f401011sl2000DLiuot0ncs&loc=https%3A%2F%2Fwww.experts-exchange.com%2Fquestions%2F29021967%2FVBA-Kill-file-but-send-it-to-recycle-bin-Not-permanently-delete-it.html%3Fanchor%3Da42130595%26notificationFollowed%3D188933050%23a42130595&v=1&out=https%3A%2F%2Fblogs.technet.microsoft.com%2Fheyscriptingguy%2F2004%2F12%2F03%2Fhow-can-i-determine-the-sid-for-a-user-account%2F&ref=https%3A%2F%2Fwww.experts-exchange.com%2Fquestions%2F29022018%2Fcan-this-macro-be-converted-to-sub-procedure.html&title=VBA%20Kill%20file%20but%20send%20it%20to%20recycle%20bin%2C%20Not%20permanently%20delete%20it.&txt=https%3A%2F%2Fblogs.technet.microsoft.com%2Fheyscriptingguy%2F2004%2F12%2F03%2Fhow-can-i-determine-the-sid-for-a-user-account%2F

not sure why the redirect goes via redirect.viglink.com

aikimark,

i trying using this below code, and it runs but it does not send the file to recycle

Sub test()
FileToToss ("C:\Users\flora\Downloads\22.xlsx")
End Sub

Sub FileToToss(strFileToToss As String)
 
Const HKEY_CURRENT_USER = &H80000001
strComputer = "."
 
Set fso = CreateObject("Scripting.FileSystemObject")
 
If Not fso.FileExists(strFileToToss) Then
   WScript.Quit
End If
 
If fso.GetExtensionName(strFileToToss) = "exe" Then
   WScript.Quit
End If
 
strFolderParent = fso.GetParentFolderName(strFileToToss)
strFileName = fso.GetFileName(strFileToToss)
 
 
'   Make sure recycle bin properties are set to NOT display request for delete confirmation
 
Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\default:StdRegProv")
  
strKeyPath = "Software\Microsoft\Windows\CurrentVersion\Explorer"
strValueName = "ShellState"
 
oReg.GetBinaryValue HKEY_CURRENT_USER, strKeyPath, _
    strValueName, strValue
 
strOrigBinSet = strValue(4)
strValue(4) = 39
 
errReturnA = oReg.SetBinaryValue _
   (HKEY_CURRENT_USER, strKeyPath, strValueName, strValue)
 
 
'  Use the Shell to send the file to the recycle bin
 
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(strFolderParent)
Set objFolderItem = objFolder.ParseName(strFileName)
 
objFolderItem.InvokeVerb ("&Delete")
 
 
'  Restore the User's Property settings for the Recycle Bin
 
strValue(4) = strOrigBinSet
errReturnB = oReg.SetBinaryValue(HKEY_CURRENT_USER, strKeyPath, strValueName, strValue)

End Sub

Select allOpen in new window

On Win10 I believe:


needs to be:

---

»bp

I don't see that.  It looks like you have an 'enhanced' browser.

thanks everyone.  the link shared by aikimark worked for me.
https://gallery.technet.microsoft.com/scriptcenter/191eb207-3a7e-4dbc-884d-5f4498440574

related to redirect of links.

i did some research and then i was taken to the link VigLink. then i disabled it as shown in the screenshot below, then it got fixed.

perhaps EE is using viglink for redirection, to find the statistics of how many links in EE clicked, still not sure if i should report this to EE site administrator.

"Why am I seeing this?
At VigLink, we empower content creators to connect enthusiastic consumers with products written about in the publisher's content. The publisher whose site you left gives VigLink the ability to identify the same product across various merchants and bring you to this destination. VigLink shopping allows you to choose where you want to shop, and ensures you're getting the best possible price.

To learn more about VigLink please visit our site at www.viglink.com."

To opt out, click here.