• بازیافت یک فایل یا پوشه در اکسل

    در این پست کد VBA برای ارسال یک فایل یا پوشه به سطل بازیافت ویندوز و تخلیه سطل بازیافت توضیح داده شده است.

    VB/VBA هیچ روشی برای ارسال فایل به سطل بازیافت ویندوز ارائه نمی دهد. VB دستور Kill را ارائه می دهد، اما این دستور به طور دائم و غیر قابل برگشت یک فایل را حذف می کند. با این حال، با استفاده از برخی از توابع API ویندوز، می توانید یک فایل یا پوشه را به سطل بازیافت ارسال کنید. هنگام تعیین یک فایل یا پوشه برای بازیافت، باید نام فایل کاملاً واجد شرایط، از جمله اطلاعات درایو و پوشه را ارائه دهید. مثلا،

    C:\Some\Folder\File.xls

    معتبر است، اما

    Some\Folder\File.xls

    معتبر نیست زیرا فاقد درایو و احتمالاً مشخصات پوشه است. نمی‌توانید فایل‌ها را روی یک ماشین راه دور بازیافت کنید.

    این صفحه دو روش برای بازیافت یک فایل را شرح می دهد: Recycle و RecycleSafe. عملکرد Recycle به شما امکان می دهد تا هر فایل یا پوشه ای را تا زمانی که سیستم عامل اجازه می دهد بازیافت کنید. عملکرد RecycleSafe شما را از بازیافت فایل ها و پوشه های خاص منع می کند. این فایل ها و پوشه های ممنوعه عبارتند از:

    این کتاب کار
    This Workbook.Path
    برنامه. مسیر
    هر دایرکتوری ریشه
    فهرست راهنمای سیستم (معمولاً C:\Windows\System32)
    دایرکتوری ویندوز (معمولاً C:\Windows)
    فایل های برنامه (معمولا C:\Program Files)
    اسناد من (معمولاً C:\Documents And Settings\username\My Documents
    دسکتاپ (معمولاً C:\Documents And Settings\Username\Desktop)
    هر گونه مشخصات فایل با کاراکترهای عام (* یا ?)
    هر فایل یا پوشه ای با مجموعه ویژگی System
    فایلی که در حال حاضر باز است

    محدودیت‌های پوشه RecycleSafe از حذف کامل آن پوشه‌ها جلوگیری می‌کند، اما می‌توانید هر فایل یا پوشه‌ای را در آن پوشه‌ها حذف کنید، تا زمانی که این عملیات توسط سیستم عامل مجاز باشد.

    این صفحه همچنین شامل روشی برای تخلیه سطل بازیافت است.

    اعلامیه های رویه برای Recycle و RecycleSafe در زیر نشان داده شده است:

    Public Function Recycle(FileSpec As String, Optional ErrText As String) As Boolean
    Public Function RecycleSafe(FileSpec As String, Optional ByRef ErrText As String) As Boolean

    در هر دو روش، FileSpec نام کاملاً واجد شرایط پرونده یا پوشه ای است که باید بازیافت شود. اینها باید کاملاً با مشخصات درایو و پوشه مطابقت داشته باشند. اگر عملیات بازیافت موفقیت آمیز بود یا خطا رخ داده باشد، توابع درست است. اگر خطایی رخ دهد، متغیر ErrText حاوی توضیحات متنی خطا خواهد بود.

     

    بازیافت یک فایل یا پوشه در اکسل

     

    کد مشترک برای بازیافت و بازیافت ایمن

    کد زیر توسط Recycle و RecycleSafe استفاده می شود و باید در بخش اعلامیه های یک ماژول (خارج و قبل از هر روشی) قرار گیرد.

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' 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

    بازیافت یک فایل یا پوشه در اکسل

    کد برای عملکرد بازیافت

    کد زیر برای رویه Recycle است.

    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
    
     

     

    بازیافت یک فایل یا پوشه در اکسل

     

    کد برای روش RecycleSafe

    کد زیر برای رویه RecycleSafe است.

    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

    بازیافت یک فایل یا پوشه در اکسل

     

    خالی کردن سطل بازیافت

    روش زیر سطل بازیافت ویندوز را خالی می کند. اگر ویندوز به گونه‌ای پیکربندی شده است که سطل‌های بازیافت جداگانه را نگه دارد، یکی برای هر درایو، می‌توانید درایوی را که می‌خواهید با تعیین حرف درایو در پارامتر DriveRoot خالی کنید، مشخص کنید. به طور معمول، شما این پارامتر را حذف خواهید کرد.

    Public Function EmptyRecycleBin(Optional DriveRoot As String = vbNullString) As Boolean
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' EmptyRecycleBin
    ' This procedure empties the Recycle Bin. If you have Windows configured
    ' to keep separate Recycle Bins for each drive, you may specify the
    ' drive in the DriveRoot parameter. Typically, this should be omitted.
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Const SHERB_NOCONFIRMATION = &H1
    Const SHERB_NOPROGRESSUI = &H2
    Const SHERB_NOSOUND = &H4
    
    Dim Res As Long
    If DriveRoot <> vbNullString Then
        If PathIsNetworkPath(DriveRoot) <> 0 Then
            MsgBox "You can't empty the Recycle Bin of a network drive."
            Exit Function
        End If
    End If
    
    Res = SHEmptyRecycleBin(hwnd:=0&, _
                            pszRootPath:=DriveRoot, _
                            dwFlags:=SHERB_NOCONFIRMATION + _
                                     SHERB_NOPROGRESSUI + _
                                     SHERB_NOSOUND)
    If Res = 0 Then
        EmptyRecycleBin = True
    Else
        EmptyRecycleBin = False
    End If
    
    End Function

     

    نظرات ارسال شده ارسال نظر جدید
    برای تبادل نظر، می بایست در سایت وارد شوید

    ورود به سایت
تماس سبد خرید بالا