代码如下：

－－－－－－－－－－－开始－－－－－－－－－－－－

Option Explicit
Dim sPath As String '文件夹变量
Private Sub Command2_Click()
Dim fs
Shell "attrib -s " & sPath, vbHide
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.FileExists(sPath & "\" & "desktop.ini") Then
    fs.DeleteFile sPath & "\" & "desktop.ini", True
End If
End Sub
Private Sub Dir1_Click()
Dim i As Integer
Command1.Enabled = True
Command2.Enabled = True
i = Dir1.ListIndex
sPath = Dir1.List(i)
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub
Private Sub Form_Load()
'Command1.Caption = "定义文件夹图标"
Command1.Enabled = False
Command2.Enabled = False
End Sub
Private Sub Command1_Click()
ChangeFolderInfo sPath '更改目录为系统文件
Dim s As String '图标文件路径、名称变量
If Chk1.Value = 1 Then
    With CommonDialog1
    .Filter = "(*.ico)|*.ico"
    .DialogTitle = "查找图标"
    .ShowOpen
    s = .FileName
    End With
End If
On Error Resume Next
Open sPath & "\" & "desktop.ini" For Output As #1
If Err.Number <> 0 Then
    MsgBox "该文件已经加密！"
    Err.Number = 0
    Exit Sub
End If
If Chk1.Value = 1 Then
    Print #1, "[.ShellClassInfo]"; vbCrLf; "ConfirmFileOp=0"; vbCrLf; "IconIndex=0"; vbCrLf; "iconfile="; s
Else
    Print #1, "[.ShellClassInfo]"; vbCrLf; "CLSID={871C5380-42A0-1069-A2EA-08002B30309D}"; vbCrLf; "ConfirmFileOp=0"; vbCrLf;
End If
Close #1
ChangeFileInfo (sPath & "\" & "desktop.ini")
End Sub
'赋予文件夹系统属性子程序
Private Sub ChangeFolderInfo(folderspec)
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
f.Attributes = 4 '用Attributes函数设置文件夹属性
End Sub
'赋予Desktop.ini文件隐藏属性
Private Sub ChangeFileInfo(filespec)
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFile(filespec)
f.Attributes = 2 '用Attributes属性设置文件属性
End Sub

－－－－－－－－－－－结束－－－－－－－－－－－－

　　代码网上弄滴，不知原作者为何人，在此引用，谢谢！