بعض الدوال المفيدة في الاكسس

[SEMO.Pa3x]

السلام عليكم ورحمة الله وبركاته..

كما في العنوان هذه بعض من دوال الاكسس VBA عسى ولعل تفيدكم.

  

Public Function createFolder(path As String, Optional failIfAlreadyExists As Boolean = False) As Boolean

On Error GoTo handleError
    
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If path <> "" Then
        FSO.createFolder path
    End If
    
    If folderExists(path) Then
        createFolder = True
    Else
        createFolder = False
    End If
    
    GoTo handleSuccess
    Exit Function

handleSuccess:
    GoTo cleanUp
    Exit Function

handleError:
    If Err.Number = 58 And Not failIfAlreadyExists Then
        createFolder = True
    Else
        Call fileSystem.handleError(Err.Number, Err.Description, "createFolder()", path)
    End If
    GoTo cleanUp
    
cleanUp:
    Set FSO = Nothing
    Exit Function
    
End Function

 

Public Function deleteFile(path As String) As Boolean

    On Error GoTo handleError
    
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If path <> "" And fileExists(path) Then
        FSO.deleteFile path
    Else
        Exit Function
    End If
    
    If fileExists(path) Then
        deleteFile = False
    Else
        deleteFile = True
    End If
    
    GoTo handleSuccess
    Exit Function
    
handleSuccess:
    Call fileSystem.handleSuccess
    GoTo cleanUp
    Exit Function
    
handleError:
    Call fileSystem.handleError(Err.Number, Err.Description, "deleteFolder()", path)
    GoTo cleanUp
    Exit Function
    
cleanUp:
    Set FSO = Nothing
    Exit Function
    
End Function

 

Public Function deleteFolder(path As String) As Boolean

On Error GoTo handleError
    
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If path <> "" And folderExists(path) Then
        path = IIf(Right(path, 1) = "\", Left(path, Len((path)) - 1), path)
        FSO.deleteFolder path
    Else
        Exit Function
    End If
    
    If folderExists(path) Then
        deleteFolder = False
    Else
        deleteFolder = True
    End If
    
    GoTo handleSuccess
    Exit Function

handleSuccess:
    Call fileSystem.handleSuccess
    GoTo cleanUp
    Exit Function
    
handleError:
    Call fileSystem.handleError(Err.Number, Err.Description, "deleteFolder()", path)
    GoTo cleanUp

cleanUp:
    Set FSO = Nothing
    Exit Function

End Function

 

Public Function driveExists(path As String) As Boolean

On Error GoTo handleError
    
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If path <> "" Then
        driveExists = FSO.driveExists(path)
    End If

    GoTo handleSuccess
    Exit Function

handleSuccess:
    Call fileSystem.handleSuccess
    GoTo cleanUp
    Exit Function

handleError:
    Call fileSystem.handleError(Err.Number, Err.Description, "driveExists()", path)
    GoTo cleanUp

cleanUp:
    Set FSO = Nothing
    Exit Function

End Function

 

Public Function fileExists(path As String) As Boolean

On Error GoTo handleError
    
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If path <> "" Then
        fileExists = FSO.fileExists(path)
    End If

    GoTo handleSuccess
    Exit Function

handleSuccess:
    Call fileSystem.handleSuccess
    GoTo cleanUp
    Exit Function
    
handleError:
    Call fileSystem.handleError(Err.Number, Err.Description, "fileExists()", path)
    GoTo cleanUp
    
cleanUp:
    Set FSO = Nothing
    Exit Function

End Function

 

Public Function folderExists(path As String) As Boolean

On Error GoTo handleError
    
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If path <> "" Then
        folderExists = FSO.folderExists(path)
    End If

    GoTo handleSuccess
    Exit Function

handleSuccess:
    Call fileSystem.handleSuccess
    GoTo cleanUp
    Exit Function
    
handleError:
    Call fileSystem.handleError(Err.Number, Err.Description, "folderExists()", path)
    GoTo cleanUp

cleanUp:
    Set FSO = Nothing
    Exit Function

End Function

 

Public Function getComputerName()
    getComputerName = Environ("COMPUTERNAME")
End Function

 

Public Function getUserDesktopPath(Optional endWithSlash As Boolean = True)
    getUserDesktopPath = getUserProfilePath & "Desktop" & IIf(endWithSlash, "\", "")
End Function

 

Public Function getCurrentUsername()
    getCurrentUsername = Environ("USERNAME")
End Function

 

Public Function getUserProfilePath(Optional endWithSlash As Boolean = True)
    getUserProfilePath = Environ("USERPROFILE") & IIf(endWithSlash, "\", "")
End Function

 

Public Function getHomeDrive()
    getHomeDrive = Environ("HOMEDRIVE")
End Function

 

Public Function getHomePath(Optional includeDrive As Boolean = True, Optional endWithSlash As Boolean = True)
    getHomePath = IIf(includeDrive, getHomeDrive, "") & Environ("HOMEPATH") & IIf(endWithSlash, "\", "")
End Function

 

''''''''''''''''''''''''''''
'
' Name:         contains()
' Library:      Strings.accda
' Author:       Wyatt Castaneda
' Last Update:  23-Mar-19
' Description:  Searchs an arbitary number of strings for a substring
'
' Example(s):   contains("wyatt", "wyatt", "james", "amber") --> true
'               contains("scott", "wyatt", "james", "amber") --> false
'
''''''''''''''''''''''''''''

Public Function contains(toCheck As String, ParamArray searchTerms()) As Boolean
        
    Dim term As Variant
    
    contains = False
    
    For Each term In searchTerms
        If InStr(toCheck, term) <> 0 Then
            GoTo doesContainString
        End If
    Next
    
    Exit Function
       
doesContainString:
    contains = True
    Exit Function
    
End Function

 

Public Function lowerCase(toFix As String) As String
    On Error GoTo failGracefully
        lowerCase = StrConv(toFix, vbLowerCase)
        Exit Function
failGracefully:
    lowerCase = toFix
    Exit Function
End Function

 

Public Function upperCase(toFix As String) As String
    On Error GoTo failGracefully
        upperCase = StrConv(toFix, vbUpperCase)
        Exit Function
failGracefully:
    upperCase = toFix
    Exit Function
End Function

 

لا تنسوني ووالدي من صالح دعائكم.

[Moosak]

شكرا جزيلا لك أستاذي العزيز وبارك الله فيك ..😊🌹

[abouelhassan]

بارك الله فيك وفى والديك اخى الكريم

وزادك من فضله وكرمه