• Home
 · 
• Custom Controls/Forms/Menus
 · 
• Folder Customizer

Folder Customizer

Folder Customizer

Rate Folder Customizer

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

Public nam As String
Public start1 As String
Public start2 As String
Public back As Integer
Public finish As Integer
Public en As Integer
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, lpKeyName As Any, ByVal lpDefault As String, ByVal lpRetunedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lplFileName As String) As Long
Global r%
Global INIpath$
Global entry$

Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Const MAX_PATH = 260
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_STATUSTEXT = 4
Private Const WM_USER = &H400
Private Const BFFM_INITIALIZED = 1
Private Const BFFM_SELCHANGED = 2
Private Const BFFM_SETSTATUSTEXTA = (WM_USER + 100)
Private Const BFFM_SETSELECTIONA = (WM_USER + 102)
Private Type BrowseInfo
    hwndOwner As Long
    pIDLRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
Private m_sDefaultFolder As String
Private Declare Function SetFileAttributes Lib "kernel32" Alias "SetFileAttributesA" _
        (ByVal lpFileName As String, ByVal dwFileAttributes As Long) As Long
Private Const FileAttributeArchive = &H20, FileAttributeReadonly = &H1
Private Const FileAttributeSystem = &H4, FileAttributeHidden = &H2
Private Const FileAttributeDirectory = &H10

Sub main()
back = 0
en = 0
frmain.Show
'Form1.Show
End Sub

Function GetFromINI(AppName$, KeyName$, FileName$) As String
Dim RetStr As String
RetStr = String(255, Chr(0))
GetFromINI = Left(RetStr, GetPrivateProfileString(AppName$, ByVal KeyName$, "", RetStr, Len(RetStr), FileName$))
End Function



Public Function BrowseForFolder(DefaultFolder As String, Optional Parent As Long = 0, Optional Caption As String = "") As String
    Dim bi As BrowseInfo
    Dim sResult As String, nResult As Long
    bi.hwndOwner = Parent
    bi.pIDLRoot = 0
    bi.pszDisplayName = String$(MAX_PATH, Chr$(0))
    If Len(Caption) > 0 Then
        bi.lpszTitle = Caption
    End If
    bi.ulFlags = BIF_RETURNONLYFSDIRS
    bi.lpfn = GetAddress(AddressOf BrowseCallbackProc)
    bi.lParam = 0
    bi.iImage = 0
    
    m_sDefaultFolder = DefaultFolder
    nResult = SHBrowseForFolder(bi)
    If nResult <> 0 Then
        sResult = String(MAX_PATH, 0)
        If SHGetPathFromIDList(nResult, sResult) Then
            BrowseForFolder = Left$(sResult, InStr(sResult, Chr$(0)) - 1)
        End If
        CoTaskMemFree nResult
    End If
End Function


Private Function BrowseCallbackProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
    Select Case uMsg
        Case BFFM_INITIALIZED
            If Len(m_sDefaultFolder) > 0 Then
                SendMessage hwnd, BFFM_SETSELECTIONA, True, ByVal m_sDefaultFolder
            End If
    End Select
End Function

Private Function GetAddress(nAddress As Long) As Long
    GetAddress = nAddress
End Function

Public Function WriteINI(sSection As String, sKeyName As String, sValueData _
As String, sINIFileName As String) As Boolean
On Local Error Resume Next
Call WritePrivateProfileString(sSection, sKeyName, sValueData, _
sINIFileName)
WriteINI = (Err.Number = 0)
End Function
Public Sub setFolderRead(folderspec)
Dim f, fs
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(folderspec)
f.Attributes = FileAttributeDirectory + FileAttributeReadonly
End Sub
Public Sub FileAttribHide(ByVal FileName As String)
Dim vResult As Long: On Local Error Resume Next
vResult = SetFileAttributes(FileName, FileAttributeHidden + FileAttributeSystem)
End Sub