by Mat (1 Submission)
Category: Windows System Services
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Wed 17th December 2003
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
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
VBcoders
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
No comments have been posted about Converts a normal folder in to a system folder. Replaces the standard icon for a folder by the icon. Why not be the first to post a comment about Converts a normal folder in to a system folder. Replaces the standard icon for a folder by the icon.
