VB更改盘符图标

在这里插入图片描述

利用VB6实现更改磁盘盘符的图标，过程通过修改系统注册表来实现这个小小的功能，感兴趣的小伙伴可以下载研究研究，当中用到一些API来进行对注册表读写，图标格式一定是*.ico，部分代码：
Private Const ZCBURL As String = “SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\DriveIcons”
Dim ListText As String, Ltext As String, i As Integer

Private Function PFSize(ByVal CDE As String, ByVal Index As Integer)
On Error GoTo NX
Set fso = CreateObject(“Scripting.FileSystemObject”)
Set drv = fso.getdrive(CDE)
Select Case Index
Case 0
PFSize = VBA.Mid(CDE, 1, 1)
Case 1
PFSize = IIf(drv.volumename <> “”, drv.volumename, “-”)
Case 2
PFSize = FileSize(drv.freespace, 1)
Case 3
PFSize = FileSize(drv.totalsize, 1)
End Select
Exit Function
NX: PFSize = “可用空间:” & vbTab & “” & Space$(5) & “总容量:” & vbTab & “”
End Function

Private Sub Command1_Click()
Dim BBS As Boolean
Dim URLtxt As String
If Ltext = “” Then Exit Sub
URLtxt = OpenImaget(True)
If URLtxt <> “” Then
If MsgBox(“真的要更改” & Ltext & “盘的图标吗？”, vbQuestion + vbYesNo, “提示”) = vbYes Then
BBS = Registry(HKEY_LOCAL_MACHINE, ZCBURL & Chr(92) & ListText, “”, URLtxt, REG_SZ, 1)
ListView1_Click
MsgBox “更改成功！”, vbOKOnly, “提示”
End If
End If
End Sub

Private Sub Command2_Click()
Dim BBS As Boolean
If Ltext <> “” Then
If MsgBox(“真的要恢复” & Ltext & “盘的图标吗？”, vbQuestion + vbYesNo, “提示”) = vbYes Then
BBS = Registry(HKEY_LOCAL_MACHINE, ZCBURL & Chr(92) & Ltext, “”, “”, 0, 4)
If BBS = True Then '删除项
MsgBox “恢复成功！”
Else
MsgBox “恢复失败！”
End If
ListView1_Click
End If
End If
End Sub

Private Sub Form_Load()
Dim strSave As String, drvName As String, Ret As Long, keer As Integer
Me.Caption = “更改盘符图标”
'初始化列表
ListView1.ColumnHeaders.Clear
ListView1.ColumnHeaders.Add , “”, “盘符”, 1200
ListView1.ColumnHeaders.Add , “”, “卷名”, 1200
ListView1.ColumnHeaders.Add , “”, “可用空间”, 1200
ListView1.ColumnHeaders.Add , “”, “总容量”, 1200
Dim Text As ListItem
'创建一个缓冲区来存储所有驱动器
strSave = String(255, Chr $(0))^{'} 获取所有驱动器 R e t = G e t L o g i c a l D r i v e S t r i n g s (255, s t r S a v e)^{'} 从缓冲区提取驱动器并将其打印到表单上 F o r k e e r = 0 T o 100 I f L e f t$ (strSave, InStr(1, strSave, Chr $(0))) = C h r$ (0) Then Exit For
drvName = Left $(s t r S a v e, I n S t r (1, s t r S a v e, C h r$ (0)) - 1)
Set Text = ListView1.ListItems.Add(, , PFSize(drvName, 0))
Text.SubItems(1) = PFSize(drvName, 1)
Text.SubItems(2) = PFSize(drvName, 2)
Text.SubItems(3) = PFSize(drvName, 3)
strSave = Right $(s t r S a v e, L e n (s t r S a v e) - I n S t r (1, s t r S a v e, C h r$ (0)))
Next keer
Set Text = Nothing
End Sub

Private Sub ListView1_Click()
Dim IconPath As String, mIcon As Long
i = ListView1.SelectedItem.Index
Ltext = ListView1.ListItems(i).Text
ListText = Chr(92) & Ltext & Chr(92) & “DefaultIcon”
If Registry(HKEY_LOCAL_MACHINE, ZCBURL & ListText, “”, “”, 0, 8) <> False Then '判断指定的项是否存在
IconPath = Registry(HKEY_LOCAL_MACHINE, ZCBURL & ListText, “”, “”, 0, 6) '获取开机所有启动程序名称
'通过子健值的图标路径显示图标
DestroyIcon mIcon
Picture1.Cls
mIcon = ExtractIcon(App.hInstance, IconPath, 0)
DrawIconEx Picture1.hdc, (Picture1.ScaleWidth - 32) / 2, (Picture1.ScaleHeight - 32) / 2, mIcon, 32, 32, 2, 0&, DI_NORMAL
Picture1.Refresh
DestroyIcon mIcon
Else
Picture1.Cls
End If
End Sub
【工程包下载地址:https://download.csdn.net/download/ty5858/85728218】

猜你喜欢