• Home
 · 
• Windows System Services
 · 
• Converts a normal folder in to a system folder. Replaces the standard icon for a folder by the icon

Converts a normal folder in to a system folder. Replaces the standard icon for a folder by the icon

Converts a normal folder in to a system folder. Replaces the standard icon for a folder by the icon of your choice. Replaces the white

API Declarations


Private Declare Function PathMakeSystemFolder Lib "shlwapi.dll" Alias "PathMakeSystemFolderA" (ByVal pszPath As String) As Long
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Private Const BIF_RETURNONLYFSDIRS = &H1
Private Type SHITEMID 'mkid
cb As Long
abID() As Byte
End Type
Private Type ITEMIDLIST 'idl
mkid As SHITEMID
End Type

Private Type BROWSEINFO 'bi
hOwner 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 Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type



Rate Converts a normal folder in to a system folder. Replaces the standard icon for a folder by the icon

• 1
• 2
• 3
• 4
• 5

(1(1 Vote))

Private Sub Command1_Click()
    Dim test As Long
    Dim icoFile As String
    Dim BMPFile As String
    Dim mydir As String
    
    icoFile = Select_File("Select ICO File...", Me, "ico")
    BMPFile = Select_File("Select BMP File...", Me, "bmp")
    mydir = Select_Directory("Select Folder to make as System Folder...", Me)
    
    FileCopy icoFile, mydir & "\" & FileNameFromPath(icoFile)
    FileCopy BMPFile, mydir & "\" & FileNameFromPath(BMPFile)
    test = PathMakeSystemFolder(mydir)
    WriteTXTFile mydir, icoFile, BMPFile
    If test <> 0 Then
        MsgBox ("Folder is now a system Folder")
    Else
        MsgBox ("Folder conversion failed")
    End If
End Sub

Private Sub Command2_Click()
    Dim mydir As String
    mydir = Select_Directory("Select Dir in which the Desktop.ini file exists", Me)
    If mydir <> "\" Then
        Call Shell("notepad " & mydir & "\desktop.ini", vbNormalFocus)
    End If
End Sub

Private Sub Command3_Click()
    WriteTXTFile
End Sub

Private Sub Drive1_Change()
    Dir1.path = Drive1.Drive
End Sub
Function Select_Directory(Desc As String, frm As Form) As String
    Dim bi As BROWSEINFO
    Dim IDL As ITEMIDLIST
    Dim pidl As Long
    Dim r As Long
    Dim pos As Integer
    Dim spath As String
    Dim lblSelected As String

    bi.hOwner = frm.hwnd
    bi.pidlRoot = 0&
    bi.lpszTitle = Desc
    bi.ulFlags = BIF_RETURNONLYFSDIRS
    pidl& = SHBrowseForFolder(bi)
    spath$ = Space$(512)
    r = SHGetPathFromIDList(ByVal pidl&, ByVal spath$)
    If r Then
        pos = InStr(spath$, Chr$(0))
        lblSelected = Left(spath$, pos - 1)
    Else: lblSelected = ""
    End If
    If Right(Left(lblSelected, 4), 1) = "\" Then
        Select_Directory = lblSelected
    Else
        Select_Directory = lblSelected & "\"
    End If
End Function

Function Select_File(Desc As String, MyForm As Form, flType As String)
'Place the following code in under a command button or in a menu, etc...

    Dim ofn As OPENFILENAME
    ofn.lStructSize = Len(ofn)
    ofn.hwndOwner = MyForm.hwnd
    ofn.hInstance = App.hInstance
    ofn.lpstrFilter = "File Type (*." & flType & ")" + Chr$(0) + "*." & flType + Chr$(0)
        ofn.lpstrFile = Space$(254)
        ofn.nMaxFile = 255
        ofn.lpstrFileTitle = Space$(254)
        ofn.nMaxFileTitle = 255
        ofn.lpstrInitialDir = CurDir
        ofn.lpstrTitle = Desc
        ofn.flags = 0
        Dim a
        a = GetOpenFileName(ofn)

        If (a) Then
            Select_File = Trim(ofn.lpstrFile)
        End If
End Function
Function FileNameFromPath(MyPath As String) As String
    Dim lngIndex As Long
    Dim strRemnant As Variant
    Dim strPath As Variant
    Dim FileNameOnly As String
    
   ' strFilePath = Space$(MAX_PATH)
   ' lngFileHandle = GetModuleHandle(App.EXEName)
   ' lngReturn = GetModuleFileName(lngFileHandle, strFilePath, MAX_PATH)

   ' MsgBox strFilePath <--- gets the fill path
    
    strRemnant = MyPath
    
    Do
        lngIndex = InStr(strRemnant, "\")
        If lngIndex = 0 Then Exit Do    ' There are no more backslash characters: we have the name.
        strPath = strPath & Left(strRemnant, lngIndex)                  '<----Gets the Directory
        strRemnant = Right$(strRemnant, Len(strRemnant) - lngIndex)     '<----Gets the EXE file name
    Loop
    
    FileNameOnly = strRemnant           ' Sock it to me!
    
    FileNameFromPath = strRemnant
    
End Function

Sub WriteTXTFile(mydir As String, icoFile As String, BMPFile As String)
    Open mydir & "\desktop.ini" For Output As #1
    Print #1, "[.ShellClassInfo]"
    Print #1, "IconFile=.\" & FileNameFromPath(icoFile)
    Print #1, "IconIndex=0"
    Print #1, "InfoTip=Special Folder"
    Print #1, "[ExtShellFolderViews]"
    Print #1, "{BE098140-A513-11D0-A3A4-00C04FD706EC}={BE098140-A513-11D0-A3A4-00C04FD706EC}"
    Print #1, "[{BE098140-A513-11D0-A3A4-00C04FD706EC}]"
    Print #1, "Attributes=1"
    Print #1, "IconArea_Image=.\" & FileNameFromPath(BMPFile)
    Close #1
End Sub