MsdnVB6.0 For VB 注,迷你Msdn足矣，你会问比如CreateWindow这样的Api去哪里查呢，Api是C的范围，在VB中只是调用，可以通过

API32.CHM 陈国强整理的,通过里面的中文学习别人是如何翻译英文的方法
Msdn2005是查询根源，多数的Api都可以查到方法。

下载页面  http://www.gougou.com/search?search=Msdn2005&id=0
当然找评论最多的那个下载了。

注意：Msdn2005中有些函数和Msdn2001不同，比如CallBack，主要影响VC++6.0.下面是Msdn2001

http://58.61.39.221/down?cid=C8294297BB1ABF9D2DBBB50AD54567013C9F8F48&t=2&fmt=-

首先要成为VB中级程序员，你必须熟悉消息机制，具体可以看

http://www.sunxin.org/video/vc.asp

Lesson1：Windows程序运行原理及程序编写流程，窗口产生过程，句柄原理，消息队列，回调函数，窗口关闭与应用程序退出的工作关系，使用VC++的若干小技巧，stdcall与cdecl调用规范的比较，初学者常犯错误及注意事项。

仔细看Lesson1动画几次可以熟悉消息机制和子类化的来源，你说：我不懂Vc++怎么办，记住，没人生下来什么都懂，比尔开发微软时候也是自学的，具备亮剑精神就可以了。

当然你编程必须还需

中文spy++

.net提取的

有了这个，各位的问题应该少些了，自己spy............

http://www.vbgood.com/viewthread.php?tid=57926&extra=page%3D1


VB程序必备压缩工具

http://www.vbgood.com/viewthread ... =page%3D1#pid248191

VB源码之友

http://www.vbgood.com/viewthread.php?tid=58124&extra=page%3D1

Visual Basic实用编程标准(PDF)

http://www.codepub.com/Software/View-Software-1528.html

各位如果没规范编程方法的是时候纠正自己错误的习惯了，改的越早，对自己越好，切记，好的习惯终身享用。

1024个Windows消息

http://www.vbgood.com/viewthread.php?tid=64084

自编ERRLOOK

http://www.vbgood.com/viewthread.php?tid=64023

API声明常量补充之源->>API.net

http://www.vbgood.com/viewthread.php?tid=63919

MSVB6.0中文企业版，不要装迷你版本，因为你会遇到许多麻烦。

点这里尽快下载

金山词霸2007专业版本，这个去百度找破解版本吧。

当你调试程序你必然要和指针到交道,这两兄弟都需要

WinHex v14.1 SR-6 简体中文版,文件修改和内存编辑

http://fixdown.com/china/Application/5845.htm      

UltraEdit

http://www.fixdown.com/china/Application/3704.htm

Winxp自带计算器，切换到16进制方式，有些人喜欢用幻数。

API中文范例

本来是绿色版本，由于文件太大我过滤了MSCOMCTL.Ocx，因为我当年打包的时候里面ocx有些是系统没有的，所以加在一起做了绿色版本。这个例子程序的数量应该是当前网上最多的

本地下载

VB有许多和Api比拼的函数，用好它们吧

Visual Basic 语言参考-函数速查

本地下载

系统中安装瑞星和360卫士后，启动速度大降

有什么办法提高一点速度，开机时有许多启动程序，杀软先驻留后会扫描这些文件会降低启动速度，如果把杀软放入最后启动感觉应该快些，我们一般都写了些小工具使用，可以嵌入代码在系统闲置时候加载杀软。

首先看杀软的组成

注册表开机运行项目

[HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run]
"RfwMain"="\"d:\\Program Files\\Rising\\Rfw\\rfwmain.exe\" -Startup"
"RavTask"="\"d:\\Program Files\\Rising\\Rav\\RavTask.exe\" -system"
"360Safetray"="D:\\Program Files\\360SAFE\\safemon\\360Tray.exe /start"

系统服务4兄弟

1.Rising Personal Firewall Service
2.Rising Process Communication Center '驱动保护,无法停止
3.Rising Proxy  Service
4.Rising RealTime Monitor             '驱动保护

原理清楚了，当然开工了，你应该理解了Windows scrīpt Host Object Model的相关属性。

'frm

CODE:

Option Explicit

Private Sub cmdRemoveItem_Click()

    Dim lngResult As Long

    Call RemoveStart

    lngResult = MsgBox("是否重启电脑?", vbQuestion + vbYesNo, "询问")

    If lngResult = vbYes Then

      Call Shell("shutdown -r -f -t 2", vbHide)

    End If

End Sub

Private Sub cmdStartProc_Click()

    Call StartProc
    MsgBox "全部项目启动完毕！", vbInformation, "完成"

End Sub'mod_DisposeProc

CODE:

Option Explicit

Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Const MAX_PATH = 260

Public Sub RemoveStart()

    Dim objWscrīpt As Object              '动态引用Windows scrīpt Host Object Model
    Set ōbjWscrīpt = CreateObject("wscrīpt.shell")

    On Error Resume Next

    Call objWscrīpt.RegDelete("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\360Safetray")
    Call objWscrīpt.RegDelete("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\RavTask")   '瑞星杀毒软件相关程序。
    Call objWscrīpt.RegDelete("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\RfwMain")   '瑞星防火墙主程序。

    'demand设置服务为手动启动
    Call objWscrīpt.Run("sc config RfwService start= demand", vbHide)    '瑞星防火墙服务
    Call objWscrīpt.Run("sc config RsCCenter start= demand", vbHide)     '瑞星杀毒软件信息中心程序，驱动保护，无法停止
    Call objWscrīpt.Run("sc config RfwProxySrv start= demand", vbHide)   '瑞星个人防火墙家长保护程序。
    Call objWscrīpt.Run("sc config RsravMon start= demand", vbHide)      '瑞星杀毒软件实时监控程序,驱动保护，无法停止

    Set ōbjWscrīpt = Nothing

End Sub

Public Sub StartProc()

    Dim strRunPath As String
    Dim strRavPath As String
    Dim strRfwPath As String
    Dim objWscrīpt As Object              '动态引用Windows scrīpt Host Object Model

    On Error Resume Next

    Set ōbjWscrīpt = CreateObject("wscrīpt.shell")
   
    '排队启动服务
    Call objWscrīpt.Run("net start RfwService", vbHide, True)  '瑞星防火墙服务
    Call objWscrīpt.Run("net start RsCCenter", vbHide, True)   '瑞星杀毒软件信息中心程序，驱动保护，无法停止
    Call objWscrīpt.Run("net start RfwProxySrv", vbHide, True) '瑞星个人防火墙家长保护程序。
    Call objWscrīpt.Run("net start RsravMon", vbHide, True)    '瑞星杀毒软件实时监控程序,驱动保护，无法停止

    strRunPath = objWscrīpt.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\rising\Rfw\installpath")
    strRunPath = ShortName(strRunPath) & "rfwmain.exe /Startup"
    Call objWscrīpt.Run(strRunPath, vbHide)    '注意瑞星防火墙程序是一直运行的，你不能等它退出，参数选择False

    strRunPath = objWscrīpt.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\rising\Rav\installpath")
    strRunPath = ShortName(strRunPath) & "\RavTask.exe -System"
    Call objWscrīpt.Run(strRunPath, vbHide)

    strRunPath = "D:\Program Files\360SAFE\safemon\"           '这里无法获取360卫士路径，我用的是绿色版，就不深究了，办法当然有。
    strRunPath = ShortName(strRunPath) & "360Tray.exe /start"
    Call objWscrīpt.Run(strRunPath, vbHide)    '注意360程序是一直运行的，你不能等它退出

    Set ōbjWscrīpt = Nothing

End Sub

Public Function ShortName(lpszLongPath As String) As String

    Dim lRet As Long
    Dim lpszShortPath As String
    Dim lchr0pos As Long

    lpszShortPath = Space$(MAX_PATH)
    lRet = GetShortPathName(lpszLongPath, lpszShortPath, MAX_PATH)
    lchr0pos = InStr(lpszShortPath, Chr$(0))
    ShortName = Left$(lpszShortPath, lchr0pos - 1)

End Function可以看到，Windows scrīpt Host Object Model就是VB中的MFC,其是VC++库，根本无须担心代码速度。


没启动杀软内存剩余113,运行后82M，环境xpsp2+256 SDRAM+c3 1433M CPU

分离后看到杀软很费加载时间的。

[ 本帖最后由 weiyi75 于 2008-1-17 14:47 编辑 ]

分离杀软.rar
(2008-01-17 14:42:03, Size: 2.42 kB, Downloads: 17)

code1

CODE:

Option Explicit

Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function RegisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Public Declare Function UnregisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long) As Long

Public Const WM_HOTKEY = &H312
Public Const MOD_ALT = &H1
Public Const MOD_CONTROL = &H2
Public Const MOD_SHIFT = &H4
Public Const GWL_WNDPROC = (-4)

Public preWinProc As Long
Public Modifiers As Long, uVirtKey As Long, idHotKey As Long

Private Type taLong
    ll As Long
End Type

Private Type t2Int       'Vb是没高低位类型的，用了这个办法
    lWord As Integer
    hWord As Integer
End Type

Public Function Wndproc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    Dim lp As taLong, i2 As t2Int

    If Msg = WM_HOTKEY Then

        If wParam = idHotKey Then   '一般热键判断到这里就可以了，因为你没命中热键是不会产生WM_HOTKEY，产生了WM_HOTKEY那wParam必然是原子符

            lp.ll = lParam

            Debug.Print Hex$(lParam)

            LSet i2 = lp '或是将一用户定义类型变量复制到另一用户自定义类型变量,也就是VB的CooyMem,小型场所是你必然选择

            If (i2.lWord = Modifiers) And i2.hWord = uVirtKey Then       '比较消息高低位

                Debug.Print Hex$(i2.lWord)
                Debug.Print Hex$(i2.hWord)

                Shell "Notepad", vbNormalFocus

            End If

        End If

    End If

    Wndproc = CallWindowProc(preWinProc, hWnd, Msg, wParam, lParam)      '如果不是热键信息则调用原来的程序

End Functioncode2

CODE:

Option Explicit

Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function RegisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Public Declare Function UnregisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Const WM_HOTKEY = &H312
Public Const MOD_ALT = &H1
Public Const MOD_CONTROL = &H2
Public Const MOD_SHIFT = &H4
Public Const GWL_WNDPROC = (-4)

Public preWinProc As Long
Public Modifiers As Long, uVirtKey As Long, idHotKey As Long

Private Type taLong
    ll As Long
End Type

Private Type t2Int
    lWord As Integer
    hWord As Integer
End Type

Public Function Wndproc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    Dim lp As taLong, i2 As t2Int

    If Msg = WM_HOTKEY Then

        If wParam = idHotKey Then      '一般热键判断到这里就可以了，因为你没命中热键是不会产生WM_HOTKEY，产生了WM_HOTKEY那wParam必然是原子符

            lp.ll = lParam

            Debug.Print Hex$(lParam)

            Call CopyMemory(i2, lParam, 4) '经典的CopyMem,这个老王已经教我们不少了。

            If (i2.lWord = Modifiers) And i2.hWord = uVirtKey Then      '比较消息高低位

                Debug.Print Hex$(i2.lWord)           
                Debug.Print Hex$(i2.hWord)

                Shell "Notepad", vbNormalFocus

            End If

        End If

    End If

    Wndproc = CallWindowProc(preWinProc, hWnd, Msg, wParam, lParam)      '如果不是热键信息则调用原来的程序

End Function'code3

CODE:

Option Explicit

Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function RegisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long, ByVal fsModifiers As Long, ByVal vk As Long) As Long
Public Declare Function UnregisterHotKey Lib "user32" (ByVal hWnd As Long, ByVal id As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Const WM_HOTKEY = &H312
Public Const MOD_ALT = &H1
Public Const MOD_CONTROL = &H2
Public Const MOD_SHIFT = &H4
Public Const GWL_WNDPROC = (-4)

Public preWinProc As Long
Public Modifiers As Long, uVirtKey As Long, idHotKey As Long

Public Function Wndproc(ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    If Msg = WM_HOTKEY Then

        If wParam = idHotKey Then      '一般热键判断到这里就可以了，因为你没命中热键是不会产生WM_HOTKEY，产生了WM_HOTKEY那wParam必然是原子符

            Debug.Print Hex$(lParam)

            If (LOWORD(lParam) = Modifiers) And HIWORD(lParam) = uVirtKey Then                 '比较消息高低位

                Debug.Print Hex$(LOWORD(lParam))
                Debug.Print Hex$(HIWORD(lParam))
                Shell "Notepad", vbNormalFocus

            End If

        End If

    End If

    Wndproc = CallWindowProc(preWinProc, hWnd, Msg, wParam, lParam)      '如果不是热键信息则调用原来的程序

End Function

Public Function HIWORD(LongIn As Long) As Integer    '通过函数取HI_LOW

    '取出32位值的高16位
    'HIWORD = (LongIn And &HFFFF0000) \ &H10000
    CopyMemory ByVal VarPtr(HIWORD), ByVal VarPtr(LongIn) + 2, 2         'LongIn地址偏移2个字节就可以了

End Function

Public Function LOWORD(LongIn As Long) As Integer

    '取出32位值的低16位
    'LOWORD = LongIn And &HFFFF&
    CopyMemory ByVal VarPtr(LOWORD), ByVal VarPtr(LongIn), 2

End Function前人栽树，后人乘凉。

[ 本帖最后由 weiyi75 于 2007-12-21 09:22 编辑 ]

RegisterHotKey_UnregisterHotKey热键激活程序.rar
(2007-12-21 09:22:12, Size: 7.13 kB, Downloads: 27)

$NtUninstall$（每给系统打一个补丁，系统就会自动创建这样的一个目录，可删除）

AppPatch（应用程序修补备份文件夹，用来存放应用程序的修补文件）

Config（系统配置文件夹，用来存放系统的一些临时配置的文件）

CSC

Cursors（鼠标指针文件夹）

Debug（系统调试文件夹，用来存放系统运行过程中调试模块的日志文件）

Downloaded Installations（存放一些使用Windows Installer技术的安装程序，主要用来对程序进行修复等操作）

Downloaded Program Files（下载程序文件夹，用来存放扩展IE功能的ActiveX等插件）

Driver Cache（驱动缓存文件夹，用来存放系统已知硬件的驱动文件）

ehome

Fonts（字体文件夹。要安装某种字体只需将字体文件复制到该目录下即可）

Help（Windows帮助文件）

ime（输入法信息）

inf（一种具有特定格式的纯文本文件，最常见的应用是为硬件设备提供驱动程序服务。建议不删除这些文件。）

Installer（用来存放MSI文件或者程序安装所需要的临时文件）

java（存放Java运行的组件及其程序文件。不建议删除其中文件）

Media（声音文件夹，开关机等wav文件存放于此）

Minidump（小存储器转储文件，记录可帮助确定计算机为什么意外停止的最小的有用信息集。）

msagent（微软助手文件夹，存放动态的卡通形象，协助你更好地使用系统。若觉的没有必要，可直接删除）

msapps（微软应用程序文件夹。）

mui（多语言包文件夹，用来存放多国语言文件。）

Offline Web Pages（脱机浏览文件存放于此）

PCHealth（用来存放协调、配置和管理计算机正常运行的文件）

PeerNet

Prefetch（预读取文件夹，用来存放系统已访问过的文件的预读信息(此信息是系统在访问时自动生成的新信息)，以加快文件的访问速度，其扩展名为“PF”。可以删除。）

Provisioning

pss（用来备份系统启动配置文件的，一般对“Boot.ini”、“System.ini” 和“Win.ini”三个文件进行备份，扩展名为“backup”。如果系统原有的这三个文件损坏的话，可以从这里进行恢复。不建议删除）

RegisteredPackages

Registration（注册文件夹，用来存放用于系统COM＋或者其他组件注册的相关文件。不建议删除这里的文件）

repair（系统修复文件夹，用来存放修复系统时所需的配置文件）

Resources（系统资源文件夹，用来存放系统SHELL资源文件，就是我们在桌面上所看到的主题）

security（系统安全文件夹，用来存放系统重要的数据文件）

ShellNew

SoftwareDistribution

srchasst（搜索助手文件夹，用来存放系统搜索助手文件，与msagent文件夹类似）

Sun

SxsCaPendDel

system（系统文件夹，用来存放系统虚拟设备文件）

system32（存放Windows的系统文件和硬件驱动程序）

Tasks(任务计划）

TEMP（系统临时文件夹，其中内容可以全部删除）

twain_32（扫描仪相关）

wbem（存放WMI测试程序，用于查看和更改公共信息模型类、实例和方法等。请勿删除）

Web （类似于某些网站所提供的「网络硬盘」）

WinSxS（存储各个版本的Windows XP组件，减少因为DLL文件而引起的配置问题）

谈如何释放C盘空间 27招具体优化技巧　 天极网最近刊登了《Windows系统中如何释放C盘空间》。笔者觉得还没细化下来，所以写了下面这篇文章，主要讲讲Windows操作系统在C盘空间不足的情况下，我们可以通过那些具体手段来增加C盘空间。

　　1.打开“我的电脑”-“工具”-“文件夹选项”-“查看”-在“显示所有文件和文件夹”选项前打勾-“确定”

　　2.删除以下文件夹中的内容：

　　x:\Documents and Settings\用户名\Cookies\下的所有文件(保留index文件)

　　x:\Documents and Settings\用户名\Local Settings\Temp\下的所有文件(用户临时文件)

　　x:\Documents and Settings\用户名\LocalSettings\TemporaryInternet Files\下的所有文件(页面文件)

　　x:\Documents and Settings\用户名\Local Settings\History\下的所有文件(历史纪录)

　　x:\Documents and Settings\用户名\Recent\下的所有文件(最近浏览文件的快捷方式)

　　x:\WINDOWS\Temp\下的所有文件(临时文件)

　　x:\WINDOWS\ServicePackFiles(升级sp1或sp2后的备份文件)

　　x:\WINDOWS\Driver Cache\i386下的压缩文件(驱动程序的备份文件)

　　x:\WINDOWS\SoftwareDistribution\download下的所有文件

　　3.如果对系统进行过windoes updade升级，则删除以下文件：

　　x:\windows\下以 $u... 开头的隐藏文件

　　4.然后对磁盘进行碎片整理，整理过程中请退出一切正在运行的程序

　　5.碎片整理后打开“开始”-“程序”-“附件”-“系统工具”-“系统还原”-“创建一个还原点”(最好以当时的日期作为还原点的名字)

　　6.打开“我的电脑”-右键点系统盘-“属性”-“磁盘清理”-“其他选项”-单击系统还原一栏里的“清理”-选择“是”-ok了

　　7、在各种软硬件安装妥当之后，其实XP需要更新文件的时候就很少了。删除系统备份文件吧：开始→运行→sfc.exe /purgecache近3xxM。(该命令的作用是立即清除"Windows 文件保护"文件高速缓存，释放出其所占据的空间)

　　8、删掉\windows\system32\dllcache下dll档(减去200——300mb),这是备用的dll档， 只要你已拷贝了安装文件，完全可以这样做。

　　9、XP会自动备份硬件的驱动程序，但在硬件的驱动安装正确后，一般变动硬件的可能性不大，所以也可以考虑将这个备份删除，文件位于\windows\driver cache\i386目录下，名称为driver.cab，你直接将它删除就可以了，通常这个文件是74M。

　　10、删除不用的输入法：对很多网友来说，Windows XPt系统自带的输入法并不全部都合适自己的使用，比如IMJP8_1 日文输入法、IMKR6_1 韩文输入法这些输入法，如果用不着，我们可以将其删除。输入法位于\windows\ime\文件夹中，全部占用了88M的空间。

　　11、升级完成发现windows\多了许多类似$NtUninstallQ311889$这些目录，都干掉吧，1x-3xM

　　12、另外，保留着\windows\help目录下的东西对我来说是一种伤害，呵呵。。。都干掉！

　　13、关闭系统还原：系统还原功能使用的时间一长，就会占用大量的硬盘空间。因此有必要对其进行手工设置，以减少硬盘占用量。打开"系统属性"对话框，选择"系统还原"选项，选择"在所有驱动器上关闭系统还原"复选框以关闭系统还原。也可仅对系统所在的磁盘或分区设置还原。先选择系统所在的分区，单击"配置"按钮，在弹出的对话框中取消"关闭这个驱动器的系统还原"选项，并可设置用于系统还原的磁盘空间大小。

　　14、休眠功能会占用不少的硬盘空间，如果使用得少不妨将共关闭，关闭的方法是的：打开"控制面板"，双击"电源选项"，在弹出的"电源选项属性"对话框中选择"休眠"选项卡，取消"启用休眠"复选框。

　　15、卸载不常用组件：XP默认给操作系统安装了一些系统组件，而这些组件有很大一部分是你根本不可能用到的，可以在"添加/删除Windows组件"中将它们卸载。但其中有一些组件XP默认是隐藏的，在"添加/删除Windows 组件"中找不到它们，这时可以这样操作：用记事本打开\windows\inf\sysoc.inf这个文件，用查找/替换功能把文件中的"hide"字符全部替换为空。这样，就把所有组件的隐藏属性都去掉了，存盘退出后再运行"添加-删除程序"，就会看见多出不少你原来看不见的选项，把其中那些你用不到的组件删掉（记住存盘的时候要保存为sysoc.inf，而不是默认的sysoc.txt），如Internat信使服务、传真服务、Windows messenger，码表等，大约可腾出近50MB的空间。

　　16、清除系统临时文件：系统的临时文件一般存放在两个位置中：一个Windows安装目录下的Temp文件夹；另一个是x:\Documents and Settings"用户名"\Local Settings\Temp文件夹(Y:是系统所在的分区)。这两个位置的文件均可以直接删除。

　　17、清除Internet临时文件：定期删除上网时产生的大量Internet临时文件，将节省大量的硬盘空间。打开IE浏览器，从"工具"菜单中选择"Internet选项"，在弹出的对话框中选择"常规"选项卡，在"Internet临时文件"栏中单击"删除文件"按钮，并在弹出"删除文件"对话框，选中"删除所有脱机内容"复选框，单击"确定"按钮。

　　18、清除预读文件：Windows XP的预读设置虽然可以提高系统速度，但是使用一段时间后，预读文件夹里的文件数量会变得相当庞大，导致系统搜索花费的时间变长。而且有些应用程序会产生死链接文件，更加重了系统搜索的负担。所以，应该定期删除这些预读文件。预计文件存放在Windows XP系统文件夹的Prefetch文件夹中，该文件夹下的所有文件均可删除。

　　19、压缩NTFS驱动器、文件或文件夹：如果你的硬盘采用的是NTFS文件系统，空间实在紧张，还可以考虑启用NTFS的压缩功能。右击要压缩的驱动器－"属性"－"常规"－"压缩磁盘以节省磁盘空间"，然后单击"确定"， 在"确认属性更改"中选择需要的选项。这样可以节省约20% 的硬盘空间。在压缩C盘的时候，最好在安全模式下压缩，这样效果要好一些。

　　20、关闭华医生Dr.Watson：要关闭Dr.Watson可打开注册表编辑器，找到"HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\WindowsNT\CurrentVersion\AeDebug"分支，双击其下的Auto键值名称，将其"数值数据"改为0，最后按F5刷新使设置生效，这样就取消它的运行了。也在"开始"->"运行"中输入"drwtsn32"命令，或者"开始"->"程序"->"附件"->"系统工具"->"系统信息"->"工具"->"Dr Watson"，调出系统里的华医生Dr.Watson ，只保留"转储全部线程上下文"选项，否则一旦程序出错，硬盘会读很久，并占用大量空间。如以前有此情况，请查找user.dmp文件，删除后可节省几十MB空间。

　　21、关闭远程桌面："我的电脑"->"属性"->"远程"，"远程桌面"里的"允许用户远程连接到这台计算机"勾去掉。

　　22、取消XP对ZIP支持：Windows XP在默认情况下打开了对zip文件支持，这要占用一定的系统资源，可选择"开始→运行"，在"运行"对话框中键入"regsvr32 /u zipfldr.dll"，回车确认即可取消XP对ZIP解压缩的支持，从而节省系统资源。

　　23、关闭错误报告：当应用程序出错时，会弹出发送错误报告的窗口，其实这样的错误报告对普通用户而言几乎没有任何意义，关闭它是明智的选择。在"系统属性"对话框中选择"高级"选项卡，单击"错误报告"按钮，在弹出的"错误汇报"对话框中，选择"禁用错误汇报"单选项，最后单击"确定"即可。另外我们也可以从组策略中关闭错误报告：从"运行"中键入"gpedit.msc"，运行"组策略编辑器"，展开"计算机配置→管理模板→系统→错误报告功能"，双击右边设置栏中的"报告错误"，在弹出的"属性"对话框中选择"已禁用"单选框即可将"报告错误"禁用。

　　24、关掉不用的设备：Windows XP总是尽可能为电脑的所有设备安装驱动程序并进行管理，这不仅会减慢系统启动的速度，同时也造成了系统资源的大量占用。针对这一情况，你可在 设备管理器中，将PCMCIA卡、调制解调器、红外线设备、打印机端口(LPT1)或者串口(COM1)等不常用的设备停用，方法是双击要停用的设备，在其属性对话框中 的"常规"选项卡中选择"不要使用这个设备(停用)"。在重新启动设置即可生效，当需要使用这些设备时再从设备管理器中启用它们。

　　25、定期清理系统还原点：打开磁盘清理，选择其他选项－>清理系统还原点，点击清理。

　　26、卸载不需要的程序，这个就不用我多说了

　　27、其它优化：

　　a 将应用软件装在其它硬盘（不要安装在系统盘下，这对重装系统也有好处）;

　　b 将"我的文档"文件夹都转到其他分区：在桌面的"我的文档"图标上是右击鼠标，选择"属性"->"移动" ；

　　c 将IE临时文件夹都转到其他分区：打开IE浏览器，选择"工具"->"internet选项"->"常规"->"设置"->"移动文件夹"；

　　d 把虚拟内存也转到其它硬盘；

　　e 把pagefile.sys文件都指向一个地方：控制面板→系统→性能—高级→虚拟内存→更改，注意要点"设置"才会生效；

　　f 在桌面的"我的电脑"图标上是右击鼠标，选择"属性"->"高级－性能设置"－>"高级－虚拟内存"，调至330－720。而且定时清理。转自易猫论坛！～

作者：张侃发表于：微型计算机 2008-14期

关闭内置触摸板
        在玩游戏时，手指快速敲击键盘的同时难免误触到触摸板，在某些游戏中可能会带来十分尴尬的后果，例如窗口突然被切换。那么此时可关闭内置触摸板，它位于“Advanced”（高级）菜单中，可将“Internal Pointing Device”（内置指针设备）选项，设置为“Disabled”（关闭）即可。



        开启液晶显示屏节能模式
        当你在室外使用笔记本电脑，且无法充电时，如果屏幕亮度能适当降低，就可以达到延长笔记本电脑使用时间的目的。你只需要在“Power”（电源）菜单中，将“LCD Power Saving”（液晶显示屏省电）选项置为“Enabled”（开启）即可。




        屏蔽不常用的内置硬件
        一些笔记本电脑内置硬件，我们平时并不常用，可以在BIOS中屏蔽它们。此选项位于“Security”（安全）菜单中的“I/O Interface Security”（I/O界面安全性）二级菜单中。“MODEM Interface”、“LAN Network Interface”、“Wireless Network Interface”、“ODD Interface”、“Cardbus/1394 Interface”和“USB Interface”分别对应Modem、有线网卡、无线网卡、光驱、PCMCIA(Express)插槽/1394卡和USB接口，默认为“Unlocked”（解锁）状态。如果你需要关闭其中某一项，只需将其设置为“Locked”（锁定）即可。



        加快开机速度
        默认状态下，笔记本电脑启动时，会运行一些自检程序，如果取消自检程序，可加快开机速度。进入“Boot”（启动）菜单并选择“Boot Settings Configuration”（开机设定配置），将“Quick Boot”（快速开机）选项置为“Enabled”即可。



        另外笔记本电脑启动时，会在开机画面上显示品牌LOGO，你可以将“Boot”菜单中的“Boot Settings Configuration”选项下的“Quiet Boot”（安静开机）置为“Disabled”，即可关闭开机品牌LOGO显示，提高开机速度。

[ 本帖最后由 weiyi75 于 2008-12-17 18:48 编辑 ]

inno setup教程，强烈推荐用inno setup打包VB软件，免费！压缩率高、使用简单

作者：lfshf  来源：lfshf 的 Blog  发布时间：2007-1-16 10:19:20

这是我的一款VB6软件《爱乐影音光盘管理大师》的inno setup安装脚本
;这个脚本生成的安装程序请到“软行天下”下载，网址：http://www.sharebank.com.cn/soft/soft_view.php?id=12239
; Inno Setup 下载请搜索“Inno Setup”关键字，国人已将这个软件汉化了，感谢汉化作者汉化新世纪 莫名

; 请安装Inno Setup 后继续下一步

;将这个脚本复制到inno setup内置的编辑器内，稍加修改，即可成为你的VB6软件的安装脚本了
;杏软工作室版权所有 刘付凤，转载时请保持文件完整

;Inno Setup 是一个免费的 Windows 安装程序制作软件。
;第一次发表是在 1997 年，Inno Setup 今天在功能设置和稳定性上的竞争力可能已经超过一些商业的安装程序制作软件
;它是真正免费的软件，即使作为商业应用
;还有一个特点，压缩率特别高，特别适合VB软件，我这个安装打包后只有3.7M，其他打包工具5M多
;安装程序用编译脚本的方式创建，脚本其实就是一个类似 .INI 文件格式的 ASCII 码文本文件。 (它不象你想象的那么复杂!)
;脚本文件一般可以用安装程序编译器程序内置的编辑器进行编辑。在你编写完脚本后，下一个最终步骤就是选择安装程序编译器
;中的“编译”。创建完成后，就可以运行根据你脚本编译的安装程序了。
;按默认，这个安装程序创建在包含脚本文件目录下的名为“输出”目录中



[Setup]
;这个段包含用于安装程序和卸载程序的全局设置。某些提示对于你创建的任何安装程序都是必需的
;一个必需的指示，用以指定你正在安装的应用程序的标题。不包含版本号，与 AppVerName 指示用于同样的目的。AppName 始终在安装过程中显示在安装屏幕的左上角以及安装向导中
AppName=爱乐影音光盘管理大师
;这个必需的指示值应该与 AppName 的值相同 (或类似)，但它还应该包含程序的版本号
AppVerName=爱乐影音光盘管理大师 V3.31
;这是所有用于在  Windows 2000/XP 中添加/删除程序控件面板对话框中的“支持”信息中显示的内容。这些设置是可选的，在早期的 Windows 版本中无效
AppPublisher=sinyosoft
;这是所有用于在  Windows 2000/XP 中添加/删除程序控件面板对话框中的“支持”信息中显示的内容。这些设置是可选的，在早期的 Windows 版本中无效
AppPublisherURL=http://www.sinyosoft.com
AppSupportURL=http://www.sinyosoft.com
AppUpdatesURL=http://www.sinyosoft.com
;这个必需的指示值是用于选择目标位置向导面中的默认目录名，通常它用一个目录常量作为前缀，{pf}\SinyoCDManager将显示:C:\Program Files\SinyoCDManager
DefaultDirName={pf}\SinyoCDManager
;这个指示的值用是在向导的选择开始菜单文件夹页中使用的默认开始菜单文件夹名。如果这个指示是空白或未指定，它将用“默认”作为名字
DefaultGroupName=爱乐影音光盘管理大师
;指定许可协议文件名 (可选)，用 .txt 或 .rtf (富文本) 格式，在用户选择程序目标目录前显示
LicenseFile=F:\资料保存\杏软工作室安装包\爱乐影音光盘管理大师\Support\Application\License.txt
;指定“自述”文件名 (可选)，用 .txt 或 .rtf (富文本) 格式，用于在安装完成后显示
InfoAfterFile=F:\资料保存\杏软工作室安装包\爱乐影音光盘管理大师\Support\Application\请先读我.txt
;这是指定要在文件中使用的压缩方法，以及压缩标准
Compression=lzma
;如果设为 yes，固实压缩将启用。这会使所有文件一次性压缩
SolidCompression=yes

[Tasks]
;这个段是只选的。它定义安装程序在执行安装期间所有由用户定制的任务。这些任务以选项框和单选项形式在附加任务向导页中出现
; 注意: 下面的条目包含一个中文用语 (“创建桌面快捷方式”和“添加快捷方式”)。如果需要你可以翻译为其它语言。
Name: "desktopicon"; Descrīption: "创建桌面快捷方式"; GroupDescrīption: "添加快捷方式:"; Flags: checkedonce
; 注意: 下面的条目包含一个中文用语 (“创建快速运行栏快捷方式”和“添加快捷方式”)。如果需要你可以翻译为其它语言。
Name: "quicklaunchicon"; Descrīption: "创建快速运行栏快捷方式"; GroupDescrīption: "添加快捷方式:"; Flags: checkedonce

[Files]
;这是定义安装程序安装文件到用户系统中的可选文件段
;因这是VB软件，除软件本身包含的文件外，还必须包含相关的链接库
;以下即软件本身的文件，注：安装目录下有一个 "\Data" 的子目录
Source: "F:\资料保存\杏软工作室安装包\爱乐影音光盘管理大师\Support\Application\CDManager.EXE"; DestDir: "{app}"; Flags: ignoreversion
Source: "F:\资料保存\杏软工作室安装包\爱乐影音光盘管理大师\Support\Application\Data\*"; DestDir: "{app}\Data"; Flags: ignoreversion
Source: "F:\资料保存\杏软工作室安装包\爱乐影音光盘管理大师\Support\Application\请先读我.txt"; DestDir: "{app}"; Flags: ignoreversion
Source: "F:\资料保存\杏软工作室安装包\爱乐影音光盘管理大师\Support\Application\CDManager.exe.manifest"; DestDir: "{app}"; Flags: ignoreversion
Source: "F:\资料保存\杏软工作室安装包\爱乐影音光盘管理大师\Support\Application\License.txt"; DestDir: "{app}"; Flags: ignoreversion
Source: "F:\资料保存\杏软工作室安装包\爱乐影音光盘管理大师\Support\Application\爱乐影音光盘管理大师帮助.chm"; DestDir: "{app}"; Flags: ignoreversion
Source: "F:\资料保存\杏软工作室安装包\爱乐影音光盘管理大师\Support\Application\Data\*"; DestDir: "{app}"; Flags: ignoreversion recursesubdirs
; 注意: 不要在任何共享系统文件中使用“Flags: ignoreversion”

;以下是VB6 RunTime，本工作室严格测试过，可保证在Windows98第一版下正常运行VB6软件
Source: "F:\资料保存\杏软工作室安装包\Support\vb6RunTime\ASYCFILT.DLL"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile
;注意COMCAT.DLL版本号必须是4.71的，不能用5.0版本
Source: "F:\资料保存\杏软工作室安装包\Support\vb6RunTime\COMCAT.DLL"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile regserver
Source: "F:\资料保存\杏软工作室安装包\Support\vb6RunTime\EXPSRV.DLL"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile
Source: "F:\资料保存\杏软工作室安装包\Support\vb6RunTime\MsRepl35.dll"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile
Source: "F:\资料保存\杏软工作室安装包\Support\vb6RunTime\MSVBVM60.DLL"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile regserver
Source: "F:\资料保存\杏软工作室安装包\Support\vb6RunTime\MSVCRT40.DLL"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile
Source: "F:\资料保存\杏软工作室安装包\Support\vb6RunTime\OLEAUT32.DLL"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile regserver
Source: "F:\资料保存\杏软工作室安装包\Support\vb6RunTime\OLEPRO32.DLL"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile regserver
Source: "F:\资料保存\杏软工作室安装包\Support\vb6RunTime\STDOLE2.TLB"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile
Source: "F:\资料保存\杏软工作室安装包\Support\vb6RunTime\VB6CHS.DLL"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile
;以下是OCX控件及DAO组件
;这个软件用的是DAO3.5、MSFLXGRD、MSCOMCT2
Source: "F:\资料保存\杏软工作室安装包\Support\SYSTEM\DAO350.DLL"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile regserver
Source: "F:\资料保存\杏软工作室安装包\Support\SYSTEM\DiskID32.dll"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile
Source: "F:\资料保存\杏软工作室安装包\Support\SYSTEM\FLXGDCHS.DLL"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile
Source: "F:\资料保存\杏软工作室安装包\Support\SYSTEM\MSCC2CHS.DLL"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile
Source: "F:\资料保存\杏软工作室安装包\Support\SYSTEM\MSCMCCHS.DLL"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile
Source: "F:\资料保存\杏软工作室安装包\Support\SYSTEM\MSCOMCT2.OCX"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile regserver
Source: "F:\资料保存\杏软工作室安装包\Support\SYSTEM\MSCOMCTL.OCX"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile regserver
Source: "F:\资料保存\杏软工作室安装包\Support\SYSTEM\MSFLXGRD.OCX"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile regserver
Source: "F:\资料保存\杏软工作室安装包\Support\SYSTEM\MSJet35.dll"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile
Source: "F:\资料保存\杏软工作室安装包\Support\SYSTEM\MSJInt35.dll"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile
Source: "F:\资料保存\杏软工作室安装包\Support\SYSTEM\MSJtER35.dll"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile
Source: "F:\资料保存\杏软工作室安装包\Support\SYSTEM\MSRD2x35.dll"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile regserver
Source: "F:\资料保存\杏软工作室安装包\Support\SYSTEM\VB5DB.dll"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile
Source: "F:\资料保存\杏软工作室安装包\Support\SYSTEM\VBAJET32.DLL"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile

;以下是本安装特别需要的
;还用了个免费的“魔鬼XP按钮控件”，在此一并感谢作者，在98、2K、XP-sp2下测试通过，占用资源一般
;发现了几个BUG（不太影响使用），准备提交给作者
Source: "F:\资料保存\杏软工作室安装包\爱乐影音光盘管理大师\Support\UserControl\MageanButtonV1_2_0.ocx"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile regserver
;这是上一个控件需要的，必须打包上
Source: "F:\资料保存\杏软工作室安装包\爱乐影音光盘管理大师\Support\UserControl\Picclp32.ocx"; DestDir: "{sys}"; CopyMode: alwaysskipifsameorolder; Flags: restartreplace sharedfile regserver

[INI]
;这是你希望安装程序在用户系统中设置 .INI 文件条目的可选段。
;写一个文件“访问我们.url”用于访问作者网站
Filename: "{app}\访问我们.url"; Section: "InternetShortcut"; Key: "URL"; String: "http://www.sinyosoft.com"

[Icons]
;这个可选段定义所有创建在开始菜单和/或其它位置 (比如桌面) 的快捷方式
Name: "{group}\爱乐影音光盘管理大师"; Filename: "{app}\CDManager.EXE"
Name: "{group}\爱乐影音光盘管理大师帮助"; Filename: "{app}\爱乐影音光盘管理大师帮助.chm"
Name: "{group}\请先读我"; Filename: "{app}\请先读我.txt"

; 注意: 下列条目包含一个中文用语 (“网站”)。如果需要你可以翻译为其它语言。
Name: "{group}\访问主页"; Filename: "{app}\访问我们.url"
Name: "{userdesktop}\爱乐影音光盘管理大师"; Filename: "{app}\CDManager.EXE"; Tasks: desktopicon
Name: "{userappdata}\Microsoft\Internet Explorer\Quick Launch\爱乐影音光盘管理大师"; Filename: "{app}\CDManager.EXE"; Tasks: quicklaunchicon

[Run]
; 注意: 下列条目包含一个中文用语 (“运行”)。如果需要你可以翻译为其它语言。
;[Run] 段是可选的，用来指定程序完成安装后、在安装程序显示最终对话框之前要执行的程序
Filename: "{app}\CDManager.EXE"; Descrīption: "运行 爱乐影音光盘管理大师"; Flags: nowait postinstall skipifsilent

[UninstallDelete]
;这个可选段定义你想让卸载程序删除除用 [Files] 或 [Dirs] 条目安装/创建外的其它文件或目录，或由你应用程序创建的一些公共使用的 .INI 文件。卸载程序在卸载时最后一步处理这些条目
Type: files; Name: "{app}\访问我们.url"

Inno Setup使用进阶

http://hi.baidu.com/lwbjing/blog ... 1e752b10df9b68.html

[ 本帖最后由 weiyi75 于 2008-12-17 16:03 编辑 ]

如果修改组策略后暂时不想重启就在运行处输入gpUpdate命令回车即可

暂无

RegScanner是小巧而免费的注册表实用工具，可以说是一个Windows注册表的强力辅助工具。

它的最大特点就是能快速的搜索注册键值，并把它们汇总成列表供你分析。这对于查找某些不需要的无用注册项目非常的有用，用来查找一些恶意软件留下的痕迹也是相当的好用。

RegScanner的右键菜单不提供删除功能，但它的菜单上有一个“创建删除注册表备份”的选项，使你不必担心误删。

对编程人员来说，你一定会觉得它很有用，因为Regedit工作太慢，效率低。



支持简体中文界面,截图是英文版

[ 本帖最后由 weiyi75 于 2008-11-15 09:22 编辑 ]

ha_regscanner.rar
(2008-11-15 09:20:24, Size: 41.7 kB, Downloads: 0)

可能是装了ACD的原因，文件夹的图片不能预览了，在网上看到一个解决的方法

原因：一般情况下，当我们安装了某些看图或者图像处理类软件（如ACDsee或者Photoshop）之后，这些软件会更改文件关联，让自己这成为开启某种图像文件格式的主程序。如果用户没用卸载程序而是强行删除这些软件，那么这些程序在Windows注册表中的文件关联还会保留，但由于该程序已被删除，所以Windows将无法打开原先可以支持的图片格式。

解决方法：在“开始→运行”中输入“regsvr32 shimgvw.dll ”（启用图像预览）；然后运行“regsvr32 shmedia.dll” （启用影像预览），注册DLL后应该会弹出窗口提示“……中的……成功”，按确定即可。如果要取消预览，比如取消视频预览，运行“regsvr32 /u shmedia.dll”即可。

苦搜索百度2个小时，想出一法。

'frm

CODE:

Option Explicit

Private Declare Function SHDeleteKey Lib "shlwapi.dll" Alias "SHDeleteKeyA" (ByVal hkey As Long, ByVal pszSubKey As String) As Long
Private Const HKEY_CURRENT_USER = &H80000001

Private Sub cmdClearRunHistory_Click()
    Dim objShell As Object
    Call SHDeleteKey(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\RunMRU")
    Set ōbjShell = CreateObject("Shell.Application")
    objShell.ShutdownWindows               '调用关闭对话框，只是利用它，和计时器配合好关闭时间及时关闭
    Set ōbjShell = Nothing
    Do While GetForegroundWindow = Me.hwnd
        DoEvents
        Sleep (1)
    Loop
    '建立API时间,保存计时器标识符供KillTimer使用
    g_lngTimerId = SetTimer(Me.hwnd, 0, 1, AddressOf TimerProc)
End Sub'modDeclare

CODE:

Option Explicit

Public Declare Function GetForegroundWindow Lib "user32" () As Long

'hwnd 标识与定时器相关的窗口
'nIDEvent 指定一个非零定时器事件标识符
'uElapse 指定定时器事件之间的时间间隔
'lpTimerFunc 表示定时器事件发生后接收详细的函数的过程实例地址
Public Declare Function SetTimer Lib "user32" _
                        (ByVal hwnd As Long, _
                        ByVal nIDEvent As Long, _
                        ByVal uElapse As Long, _
                        ByVal lpTimerFunc As Long) _
                        As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

Public g_lngTimerId As Long
Private Const WM_KEYDOWN = &H100
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const VK_ESCAPE = &H1B
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Public Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long)
    If GetForegroundWindow <> hwnd Then
        Call PostMessage(GetForegroundWindow, WM_KEYDOWN, VK_ESCAPE, 0&) '眼前一花，什么也没看见
        Call KillTimer(0, g_lngTimerId)                                  '关闭计时器
    End If
End Sub实际中发现代码运行有时会没效果，于是改良。

改良后

'frm

CODE:

Option Explicit

Private Declare Function SHDeleteKey Lib "shlwapi.dll" Alias "SHDeleteKeyA" (ByVal hkey As Long, ByVal pszSubKey As String) As Long
Private Const HKEY_CURRENT_USER = &H80000001
Private m_blnShowShutDown As Boolean             '关机画面已加载

Private Sub cmdClearRunHistory_Click()
    Dim objShell As Object
    Call SHDeleteKey(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer\RunMRU")
    Set ōbjShell = CreateObject("Shell.Application")
    objShell.ShutdownWindows               '调用关闭对话框，只是利用它。
    Set ōbjShell = Nothing
    m_blnShowShutDown = True
    '建立API时间,保存计时器标识符供KillTimer使用
    g_lngTimerId = SetTimer(Me.hwnd, 0, 1, AddressOf TimerProc)
End Sub

Private Sub Form_Paint()
    If m_blnShowShutDown = True Then
        Call KillTimer(hwnd, 0)
        m_blnShowShutDown = False
    End If
End Sub'modDeclare

CODE:

Option Explicit

Public Declare Function GetForegroundWindow Lib "user32" () As Long
'hwnd 标识与定时器相关的窗口
'nIDEvent 指定一个非零定时器事件标识符
'uElapse 指定定时器事件之间的时间间隔
'lpTimerFunc 表示定时器事件发生后接收详细的函数的过程实例地址
Public Declare Function SetTimer Lib "user32" _
                        (ByVal hwnd As Long, _
                        ByVal nIDEvent As Long, _
                        ByVal uElapse As Long, _
                        ByVal lpTimerFunc As Long) _
                        As Long
Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Public g_lngTimerId As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long

Public Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long)
    Do While GetForegroundWindow <> hwnd
        SetForegroundWindow hwnd              '强行修改前台窗口，关机窗口立即退让
    Loop
End Sub工程虽小，却体现了对完美效果的执着追求。

清除运行记录.rar

再次改良清除运行记录.rar

有两个组件

'Office2003Button

CODE:

Option Explicit
Private Declare Function GetCursorPos Lib "user32" (lpPoint As PointAPI) As Long
Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As PointAPI) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Const VK_RBUTTON = &H2
Private Const VK_LBUTTON = &H1

'外观
Public Enum Appearance
    ōbBlue = 0
    ōbSilver = 1
    ōbOlive = 2
End Enum

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type PointAPI
    X As Long
    Y As Long
End Type

Public Enum eButtonState
    ButtonDown = 2
    ButtonUp = 1
End Enum

Private hDeviceScene As Long
Private shObject As Long
Private m_blnMouseOver As Boolean
Private m_ButtonState As eButtonState
Private m_intPicHeight As Integer
Private m_intPicWidth As Integer

Private m_Appearance As Appearance
Private m_blnIsCloseButton As Boolean
Private Const m_DefaultAppearance = ObBlue

Event Click()
Event DblClick()
Event KeyDown(KeyCode As Integer, Shift As Integer)
Event KeyPress(KeyAscii As Integer)
Event KeyUp(KeyCode As Integer, Shift As Integer)
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseExit()

Private Sub UserControl_InitProperties()
    Call SetPicture
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    m_blnIsCloseButton = PropBag.ReadProperty("CloseButton", False)          '读取按钮是展开还是关闭
    Appearance = PropBag.ReadProperty("Appearance", m_DefaultAppearance)
    UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
    Set Picture = PropBag.ReadProperty("Picture", Nothing)

    If UserControl.Ambient.UserMode Then
       '这里代码修改过
    End If
End Sub

Public Property Get Picture() As Picture
    Set Picture = UserControl.Picture
End Property

Public Property Set Picture(ByVal New_Picture As Picture)
    Set UserControl.Picture = New_Picture
    PropertyChanged "Picture"
    If UserControl.Picture <> 0 Then
        m_intPicHeight = ScaleY(New_Picture.Height, vbHimetric, vbPixels)  '转换度量单位为像素
        m_intPicWidth = ScaleX(New_Picture.Width, vbHimetric, vbPixels)
    End If
End Property

'根据属性设置相应位图
Private Sub SetPicture()
    Select Case m_Appearance
        Case ObBlue
        If CloseButton = True Then
            UserControl.Picture = UserControl.imgBlueClose.Picture
        Else
            UserControl.Picture = UserControl.imgBlueExpand.Picture
        End If

        Case ObOlive
        If CloseButton = True Then
            UserControl.Picture = UserControl.imgOliveClose.Picture
        Else
            UserControl.Picture = UserControl.imgOliveExpand.Picture
        End If

        Case ObSilver
        If CloseButton = True Then
            UserControl.Picture = UserControl.imgSilverClose.Picture
        Else
            UserControl.Picture = UserControl.imgSilverExpand.Picture
        End If
    End Select
End Sub

'限制控件大小
Private Sub UserControl_Resize()
    UserControl.Height = 270
    UserControl.Width = 270
End Sub

Public Property Get Enabled() As Boolean
    Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal newEnabled As Boolean)
    UserControl.Enabled() = newEnabled
    PropertyChanged "Enabled"
End Property

Public Property Get CloseButton() As Boolean
    CloseButton = m_blnIsCloseButton
End Property

Public Property Let CloseButton(ByVal newCaption1 As Boolean)  '修改按钮外观为叉
    m_blnIsCloseButton = newCaption1
    Call SetPicture
    PropertyChanged "CloseButton"
End Property

Public Property Get Appearance() As Appearance
    Appearance = m_Appearance
End Property

Public Property Let Appearance(ByVal vData As Appearance)
    m_Appearance = vData
    Call SetPicture
    PropertyChanged "Appearance"
End Property

'根据位图输出合适外观图块
Private Sub DrawMouseOut()
    Dim hDeviceScene As Long
    Dim shObject As Long
    hDeviceScene = CreateCompatibleDC(UserControl.hdc)               '建立一个内存设备场景供bitblt将一幅位图从一个设备场景复制到另一个
    shObject = SelectObject(hDeviceScene, UserControl.Picture)
    BitBlt UserControl.hdc, 0, 0, m_intPicWidth, (m_intPicHeight / 4), hDeviceScene, 0, 0, vbSrcCopy
    DeleteObject shObject                                            '卸磨杀驴
    DeleteDC hDeviceScene
    Refresh
End Sub

Private Sub DrawUp()
    Dim hDeviceScene As Long
    Dim shObject As Long
    hDeviceScene = CreateCompatibleDC(UserControl.hdc)               '建立一个内存设备场景供bitblt将一幅位图从一个设备场景复制到另一个
    shObject = SelectObject(hDeviceScene, UserControl.Picture)
    BitBlt UserControl.hdc, 0, 0, m_intPicWidth, (m_intPicHeight / 4), hDeviceScene, 0, (m_intPicHeight / 4), vbSrcCopy
    DeleteObject shObject
    DeleteDC hDeviceScene
    Refresh
End Sub

Private Sub DrawDown()
    Dim hDeviceScene As Long
    Dim shObject As Long
    hDeviceScene = CreateCompatibleDC(UserControl.hdc)               '建立一个内存设备场景供bitblt将一幅位图从一个设备场景复制到另一个
    shObject = SelectObject(hDeviceScene, UserControl.Picture)
    BitBlt UserControl.hdc, 0, 0, m_intPicWidth, (m_intPicHeight / 4), hDeviceScene, 0, (m_intPicHeight / 2), vbSrcCopy
    DeleteObject shObject
    DeleteDC hDeviceScene
    Refresh
End Sub

Private Function IsActiveWindow() As Boolean
    '不加错误处理则当窗体控件卸载时出错
    On Error Resume Next
    If GetActiveWindow() <> UserControl.Parent.hwnd Then
        IsActiveWindow = False
    Else
        IsActiveWindow = True
    End If
End Function

Private Sub tmrGetMousePosition_Timer()
    Dim PT As PointAPI
    If Not IsActiveWindow Then
        tmrGetMousePosition.Enabled = False
        Exit Sub   '不是活动窗体则不执行后面的代码
    End If
    GetCursorPos PT                       '获取鼠标指针的当前位置
    ScreenToClient hwnd, PT               '判断屏幕上一个指定点的客户区坐标
    '鼠标是否在控件中
    m_blnMouseOver = Not ((PT.X < 0) Or (PT.X > ScaleWidth) Or (PT.Y < 0) Or (PT.Y > ScaleHeight))
    tmrGetMousePosition.Enabled = m_blnMouseOver

    '如果鼠标在控件中
    If m_blnMouseOver Then
        '如果鼠标松开
        Select Case GetButtonState
            Case ButtonDown
            DrawDown
            Case ButtonUp
            DrawUp
        End Select
    Else
        DrawMouseOut
    End If
End Sub

Public Function GetButtonState() As eButtonState
    Dim lRet As Long
    lRet = GetAsyncKeyState(VK_LBUTTON) Or GetAsyncKeyState(VK_RBUTTON)  '判断鼠标是否按下
    If lRet = -32768 Then
        GetButtonState = ButtonDown
    Else
        GetButtonState = ButtonUp
    End If
End Function

Private Sub UserControl_AccessKeyPress(KeyAscii As Integer)
    RaiseEvent Click
End Sub

'移动鼠标和为活动窗口则检查鼠标位置
Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Not IsActiveWindow Then
        tmrGetMousePosition.Enabled = False
    Else
        tmrGetMousePosition.Enabled = True
        RaiseEvent MouseMove(Button, Shift, X, Y)
    End If
End Sub

'支持事件
Private Sub UserControl_Paint()
    DoEvents
End Sub

Private Sub UserControl_Click()
    RaiseEvent Click
End Sub

Private Sub UserControl_DblClick()
    RaiseEvent DblClick
End Sub

Private Sub UserControl_KeyDown(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyDown(KeyCode, Shift)
End Sub

Private Sub UserControl_KeyPress(KeyAscii As Integer)
    RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub UserControl_KeyUp(KeyCode As Integer, Shift As Integer)
    RaiseEvent KeyUp(KeyCode, Shift)
End Sub

Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

Private Sub UserControl_Terminate()
    tmrGetMousePosition.Enabled = False
    DoEvents
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("CloseButton", m_blnIsCloseButton)
    Call PropBag.WriteProperty("Appearance", m_Appearance, m_DefaultAppearance)
    Call PropBag.WriteProperty("Enabled", UserControl.Enabled, True)
    Call PropBag.WriteProperty("Picture", Picture, Nothing)
End Sub'Office2003PopupMessage

CODE:

Option Explicit

Public Enum AppearanceConst   '支持3种风格
    ōpmBlue = 0
    ōpmSilver = 1
    ōpmOlive = 2
End Enum

Private m_Caption As String
Private m_Font As Font
Private m_ForeColor As OLE_COLOR
Private m_eAppearance As AppearanceConst
Private Const m_DefaultAppearance = OpmBlue

Private m_lngBorderColor As Long                             '边线颜色
Private m_TransparencyLevel As Integer                       '透明度
Private m_TransparencyDirection As Integer                   '递增透明度

Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

'透明窗体
'参数说明
'hwnd --透明窗体的句柄
'crKey --为颜色值
'bAlpha  -- 透明度，取值范围是[0,255]
'dwFlags -- 透明方式，可以取两个值：当取值为LWA_ALPHA时，crKey参数无效，bAlpha参数有效；
'当取值为LWA_COLORKEY时，bAlpha参数有效而窗体中的所有颜色为crKey的地方将变为透明
Private Declare Function SetLayeredWindowAttributes Lib "user32" _
                          (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Private Const GWL_EXSTYLE = (-20)
Private Const LWA_ALPHA = &H2
Private Const WS_EX_LAYERED = &H80000

'定义控制支持事件
Event Click()
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseOut(Button As Integer, Shift As Integer, X As Single, Y As Single)
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

Private Sub UserControl_Initialize()
    picBackGround.Left = 0
    picBackGround.Top = imgTopPic.Height
End Sub

'创建对象的新实例时，发生该事件。
Private Sub UserControl_InitProperties()
    UserControl.Height = picBackGround.Height
    UserControl.Width = picBackGround.Width
    UserControl.lblCaption.Caption = "默认文本信息"
    If Ambient.UserMode Then tmrTransparent.Enabled = True
End Sub

'当加载具有保存状态的对象的旧实例时，发生该事件。
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    Appearance = PropBag.ReadProperty("Appearance", m_DefaultAppearance)
    Set UserControl.imgIcon.Picture = PropBag.ReadProperty("Picture", Nothing)
    UserControl.lblCaption.Caption = PropBag.ReadProperty("Caption", "默认文本信息")
    m_TransparencyLevel = PropBag.ReadProperty("TransparencyLevel", 0)
    m_TransparencyDirection = PropBag.ReadProperty("TransparencyDirection", 0)
    MakeTransparent UserControl.Parent.hwnd, m_TransparencyLevel
    If Ambient.UserMode Then tmrTransparent.Enabled = True
End Sub

'除了退出和加载，计时器都不用工作。
Private Sub tmrTransparent_Timer()
    '如果定义透明度值不为零
    If m_TransparencyDirection <> 0 Then
        If MakeTransparent(UserControl.Parent.hwnd, m_TransparencyLevel) = 1 Then
            If m_TransparencyDirection < 0 Then UserControl.Parent.Visible = False  '如果m_TransparencyDirection小于0则隐藏控件容器
        End If
        m_TransparencyLevel = m_TransparencyLevel + m_TransparencyDirection         '调整透明度(退出递减，加载递增)
        'Debug.Print m_TransparencyLevel
        If m_TransparencyLevel < Abs(m_TransparencyDirection) Then
            m_TransparencyDirection = 0
            m_TransparencyLevel = 0
            MakeTransparent UserControl.Parent.hwnd, m_TransparencyLevel            '完全透明
            Unload UserControl.Parent                                               '卸载控件容器
            tmrTransparent.Enabled = False
        End If
        If m_TransparencyLevel > (255 - Abs(m_TransparencyDirection)) Then
            m_TransparencyDirection = 0
            m_TransparencyLevel = 255                                               '限制透明度根限值为255
            tmrTransparent.Enabled = False
        End If
    End If
End Sub

'使窗体透明
Public Function MakeTransparent(ByVal hwnd As Long, bytAlpha As Integer) As Long
    Dim lStyle As Long
    On Error Resume Next
    If bytAlpha < 0 Or bytAlpha > 255 Then
        MakeTransparent = 1
    Else
        lStyle = GetWindowLong(hwnd, GWL_EXSTYLE)
        lStyle = lStyle Or WS_EX_LAYERED
        SetWindowLong hwnd, GWL_EXSTYLE, lStyle
        SetLayeredWindowAttributes hwnd, 0, bytAlpha, LWA_ALPHA
        MakeTransparent = 0
    End If
    If Err Then MakeTransparent = 2
End Function

Private Sub UserControl_Resize()
    If UserControl.Width <> 0 Then

        picBackGround.Height = UserControl.Height - imgTopPic.Height
        imgTopPic.Top = 0
        imgTopPic.Left = 0

        UserControl.Width = imgTopPic.Width
        picBackGround.Width = UserControl.Width - 30

        imgIcon.Top = 75
        imgIcon.Left = 100
        lblCaption.Top = 220
        lblCaption.Left = 720

        Call SetGradient
    End If
End Sub

Function MouseOut(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseOut(Button, Shift, X, Y)
End Function

Private Sub lblCaption_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub lblCaption_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub lblCaption_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

Private Sub imgTopPic_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub imgTopPic_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub imgTopPic_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

Private Sub picBackGround_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

Private Sub picBackGround_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

Private Sub picBackGround_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

Private Sub UserControl_Click()
    RaiseEvent Click
End Sub

'**********************************支持属性*********************************************
Public Property Get Caption() As String
    Caption = UserControl.lblCaption.Caption
End Property

Public Property Let Caption(ByVal newCaption As String)
    UserControl.lblCaption.Caption = newCaption
    PropertyChanged "Caption"
End Property

Public Property Get Picture() As Picture
    Set Picture = imgIcon.Picture
End Property

Public Property Set Picture(ByVal picNew As Picture)
    Set UserControl.imgIcon.Picture = picNew
    PropertyChanged "Picture"
End Property

Public Property Get Appearance() As AppearanceConst
    Appearance = m_eAppearance
End Property

Public Property Let Appearance(ByVal vData As AppearanceConst)
    m_eAppearance = vData
    Call SetGradient
    ForeColor = m_ForeColor
    PropertyChanged "ForeColor"
    PropertyChanged "Appearance"
End Property

Public Property Get TransparencyDirection() As Long     '透明增量
    TransparencyDirection = m_TransparencyDirection
End Property

Public Property Let TransparencyDirection(ByVal New_TransparencyDirection As Long)
    m_TransparencyDirection = New_TransparencyDirection
    PropertyChanged "TransparencyDirection"
    If Ambient.UserMode Then tmrTransparent.Enabled = True
End Property

Public Property Get TransparencyLevel() As Long        '透明度
    TransparencyLevel = m_TransparencyLevel
End Property

Public Property Let TransparencyLevel(ByVal New_TransparencyLevel As Long)
    m_TransparencyLevel = New_TransparencyLevel
    PropertyChanged "TransparencyLevel"
End Property

Function Povecaj(Height1 As Single)
    UserControl.lblCaption.Height = Height1 - 495
    UserControl.picBackGround.Height = Height1
    UserControl.Height = UserControl.imgTopPic.Height + picBackGround.Height - 120
End Function
'**********************************支持属性*********************************************

Private Sub SetGradient()

    Dim i As Long
    Dim R1 As Single          '渐变下限值
    Dim R2 As Single          '渐变上限值
    Dim Rs As Single          '渐变增量值
    Dim Rx As Single          '渐变当前值

    Dim G1 As Single
    Dim G2 As Single
    Dim Gs As Single
    Dim Gx As Single

    Dim B1 As Single
    Dim B2 As Single
    Dim Bs As Single
    Dim Bx As Single

    '根据控件风格画背景色
    Select Case m_eAppearance
        '银色
        Case OpmSilver
        R1 = &HE8
        R2 = &HB4
        G1 = &HEA
        G2 = &HB3
        B1 = &HF2
        B2 = &HCD
        imgTopPic.Picture = imgTopSilver.Picture
        m_lngBorderColor = RGB(75, 75, 111)

        '橄榄色
        Case OpmOlive
        R1 = &HE8
        R2 = &HC0
        G1 = &HEE
        G2 = &HCE
        B1 = &HCD
        B2 = &H9A
        imgTopPic.Picture = imgTopOlive.Picture
        m_lngBorderColor = RGB(63, 93, 56)

        '蓝色
        Case OpmBlue
        R1 = &HD6
        R2 = &HA8
        G1 = &HE7
        G2 = &HC4
        B1 = &HFC
        B2 = &HEE
        imgTopPic.Picture = imgTopBlue.Picture
        m_lngBorderColor = RGB(0, 0, 128)
    End Select

    Rx = R1                                                  '首先从上限值开始赋值
    Gx = G1
    Bx = B1

    Rs = (R1 - R2) / (picBackGround.ScaleHeight - 1)         '根据背景宽度计算渐变增量值
    Gs = (G1 - G2) / (picBackGround.ScaleHeight - 1)
    Bs = (B1 - B2) / (picBackGround.ScaleHeight - 1)

    For i = 0 To picBackGround.Height - 1
        picBackGround.Line (0, i)-(picBackGround.Width, i), RGB(Rx, Gx, Bx)  '生成渐变色
        Rx = Rx - Rs
        Gx = Gx - Gs
        Bx = Bx - Bs
    Next i

    picBackGround.Line (7, 7)-(picBackGround.Width - 1, picBackGround.Height - 1), m_lngBorderColor, B
    picBackGround.Line (0, picBackGround.Height - 10)-(picBackGround.Width, picBackGround.Height - 10), m_lngBorderColor '后面两句是前一句的补丁，注释后运行一下
    picBackGround.Line (picBackGround.Width - 10, 0)-(picBackGround.Width - 10, picBackGround.Height - 10), m_lngBorderColor

End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("Appearance", m_eAppearance, m_DefaultAppearance)
    Call PropBag.WriteProperty("Picture", UserControl.imgIcon.Picture, Nothing)
    Call PropBag.WriteProperty("Caption", UserControl.lblCaption.Caption)
    Call PropBag.WriteProperty("TransparencyLevel", m_TransparencyLevel, 0)
    Call PropBag.WriteProperty("TransparencyDirection", m_TransparencyDirection, 0)
End Sub'Office2003PopupMessage的边框感觉作者没写好，调了半天只能如图，希望哪位完善一下。




'部分代码看不明白，在不影响原效果的情况下重写和少量优化，比如鼠标按键状态和生成设备场景。
'OfficeButton控件看起来支持Caption属性，实际发现没效果，故原设计代码全部移除。

210_Office2003信息弹出窗口.rar

Office2003PopupMessageBox.rar

一个很专业的开源VB卸载软件，作者注释很多，从中收益不少。

其中有界面设计，注册表结构，全API Xp风格按钮-》效果很美，代码比较难

'frmMain

CODE:

Option Explicit

Private Declare Function PathFileExists Lib "shlwapi" Alias "PathFileExistsA" (ByVal pszPath As String) As Long

'OleCreatePictureIndirect建立一个图像对象,并返回对象句柄
'PicDesc                 图象结构
'RefIID                  接口的标识符
'fPictureOwnsHandle      是否清除图像对象,如设置为真,则图片对象将摧毁它的图片当对象被摧毁时。如果假, 则由用户负责摧毁图片对象。
'IPic                    输出变量地址接口类型
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
                          (PicDesc As PicBmp, _
                          RefIID As GUID, ByVal _
                          fPictureOwnsHandle As Long, _
                          IPic As IPicture) As Long

Private Declare Function ExtractIconEx Lib "shell32.dll" Alias "ExtractIconExA" (ByVal lpszFile As String, ByVal nIconIndex As Long, phiconLarge As Long, phiconSmall As Long, ByVal nIcons As Long) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long

Private Type PicBmp
    Size As Long
    tType As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Const OFFSET_4 = 4294967296#
Private Const MAXINT_4 = 2147483647#  '长整型(Long)的最大值

Private Type FILETIME
    dwLowDateTime As Long         '低32位的时间值
    dwHighDateTime As Long        '高32位的时间值
End Type

Private Type SYSTEMTIME
    wYear As Integer              '指定当前年份
    wMonth As Integer             '指定当前月份，一月份等于1
    wDayOfWeek As Integer         '指定星期几，0等于星期天，1等于星期一，以此类推
    wDay As Integer               '指定当前月的当前日期
    wHour As Integer              '指定当前小时值
    wMinute As Integer            '指定当前分钟值
    wSecond As Integer            '指定当前秒值
    wMilliseconds As Integer      '指定当前毫秒值
End Type

Private Declare Function FileTimeToSystemTime Lib "kernel32" (lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long

'存储在最后一个搜索关键字
Private mLastSearch As String
'检查搜索结束时是否已经达到底部
Private Exhausted As Boolean

Private Sub Form_Load()
    gstrLogFile = App.Path & "\UnLog.log"
    App.HelpFile = App.Path & "\Add Remove Platinum 2004.chm"
    ShowUnInstallList
End Sub

' 这是主要例程采用读取注册表，它将在列表视图中显示
' 注册表路径是主要读取UninstallPath
' UnInstallPath - 从这里我们采取的所有已安装的应用程序
' ARPCache - 从这里我们读取SlowInfoCache的值，读取软件大小，上次使用的频率这里附图两张

CODE:

Private Sub ShowUnInstallList()
    Dim strDisplayName As String, strUninstallCommand As String, lngCount As Long
    Dim lstvItem As ListItem, asBuffer() As Byte, strEXEName As String, i As Integer
    Dim lngCounterLarge As Long, lngCounterSmall As Long, strSize As String, strFrequency As String
    Dim strDisplayIcon As String, strIconIndex As String, strLastUsedOn As String
    Dim blnARPFound As Boolean, lngPrevView As Long, gcolKeys As Collection

    On Error Resume Next
    '因为Win98系统我们不能获取程序大小,使用的最后和使用频率频率,因此要隐藏这些列
    If InStr(GetOSVersion, "98") <> 0 Then
        lstview.ColumnHeaders(2).Width = 0
        lstview.ColumnHeaders(3).Width = 0
        lstview.ColumnHeaders(4).Width = 0
    End If

    'A-B间代码不过是为刷新时先临时修改一下显示方式，然后修改为实际显示方式
    '列表隐藏显示过程可以加快载入速度,行A至行B调整的图标显示位置, 否则当您刷新时，将创建一个空格
    lstview.Visible = False
    lngPrevView = lstview.View
    If lngPrevView = lvwIcon Then                   'A
        lstview.View = lvwReport
    ElseIf lngPrevView = lvwSmallIcon Then
        lstview.View = lvwIcon
    End If                                          'B

    '清除 Listview 和图像列表中的所有数据
    lstview.ListItems.Clear
    Set lstview.Icons = Nothing
    Set lstview.SmallIcons = Nothing
    ImgSmall.ListImages.Clear
    ImgLarge.ListImages.Clear

    '默认图标，添加应用程序不具有图标所显示的默认图标
    ImgSmall.ListImages.Add , , imgSoftSmall.Picture
    ImgLarge.ListImages.Add , , imgSoftLarge.Picture

    '设置ListView的ImgList控件
    Set lstview.Icons = ImgLarge
    Set lstview.SmallIcons = ImgSmall

    Set gcolKeys = New Collection
    '获取uninstall键下所有应用软件键名集合
    ModRegistry.GetKeyNames HKEY_LOCAL_MACHINE, cUnInstallPath, gcolKeys

    '读取所有具有键名的软件信息
    For lngCount = 1 To gcolKeys.Count
        '如果不删除该项值为真则不显示此应用程序在删除列表中, 主要用于 Windows 组件,你可以设置此值为1保护应用软件不被卸载。
        If GetRegValue(HKEY_LOCAL_MACHINE, cUnInstallPath & gcolKeys(lngCount), "NoRemove", eRegvalueType.REG_DWORD) <> 1 Then
            '获取命令行
            strUninstallCommand = GetRegValue(HKEY_LOCAL_MACHINE, cUnInstallPath & gcolKeys(lngCount), "UninstallString", eRegvalueType.REG_SZ)
            '获取显示名称
            strDisplayName = GetRegValue(HKEY_LOCAL_MACHINE, cUnInstallPath & gcolKeys(lngCount), "DisplayName", eRegvalueType.REG_SZ)
            '如果两个参数均读取则在列表中显示
            If (LenB(strDisplayName) <> 0) And (LenB(strUninstallCommand) <> 0) Then
                '初始化变量
                strSize = vbNullString
                strFrequency = vbNullString
                lngCounterLarge = 1
                lngCounterSmall = 1
                strLastUsedOn = vbNullString
                blnARPFound = False

                strDisplayIcon = GetRegValue(HKEY_LOCAL_MACHINE, cUnInstallPath & gcolKeys(lngCount), "DisplayIcon", eRegvalueType.REG_SZ)
                '如果是98系统则不需要显示程序大小,使用的最后和使用频率频率等
                If InStr(GetOSVersion, "98") = 0 Then
                    '如果成功读取BinaryValue则函数返回Ture,asBuffer数组大小为552个字节
                    If GetBinaryValue(HKEY_LOCAL_MACHINE, cARPCache & gcolKeys(lngCount), "SlowInfoCache", asBuffer) = True Then
                        blnARPFound = True
                    End If
                End If

                '首先检测这些键名的DisplayIcon是否有内容
                If LenB(strDisplayIcon) = 0 Then
                    ' 如果没有则尝试从slowinfocache中检索应用程序的图标
                    If blnARPFound = True Then
                        '检查数组数据中是否有应用程序名称
                        If asBuffer(4) <> 0 Then
                            strEXEName = vbNullString          '不是递归调用没必要初始化变量吧
                            '获取应用程序名称,从偏移28读取到尾部，包含VbNullChar
                            For i = 28 To UBound(asBuffer)
                                strEXEName = strEXEName & Chr$(asBuffer(i))
                            Next
                            '它们是双字节格式需要转换
                            strEXEName = FilterNullChar(StrConv(strEXEName, vbFromUnicode))
                            '检查应用程序路径是否存在
                            If PathFileExists(strEXEName) <> 0 Then
                                '检索应用程序默认图标
                                GetIcon strEXEName, lngCounterLarge, lngCounterSmall, 0
                            End If
                        End If
                    End If
                Else
                    '比如"d:\Program Files\ACDSee\ACDSee.exe"中的"就应该去掉，结果为d:\Program Files\ACDSee\ACDSee.exe
                    strDisplayIcon = Replace$(strDisplayIcon, Chr$(34), vbNullString)           'chr(34)-> "
                    '如果应用程序路径具有一个图标索引则根据此索引检索图标
                    If InStr(strDisplayIcon, ",") <> 0 Then
                        strIconIndex = Mid$(strDisplayIcon, InStrRev(strDisplayIcon, ",") + 1)
                        If IsNumeric(strIconIndex) Then
                            GetIcon Mid$(strDisplayIcon, 1, InStrRev(strDisplayIcon, ",") - 1), lngCounterLarge, lngCounterSmall, CLng(strIconIndex)
                        End If
                    Else
                        '如果没有索引图标的则检索应用程序的默认图标
                        strIconIndex = "0"
                        GetIcon strDisplayIcon, lngCounterLarge, lngCounterSmall, CLng(strIconIndex)
                    End If
                End If

                If blnARPFound = True Then

                    '检查值是否有效, 无效的值包含所有FF(255)
                    If asBuffer(11) <> 255 Then
                        '获取文件大小
                        strSize = GetFileSize(asBuffer(8), asBuffer(9), asBuffer(10), asBuffer(11))
                    End If

                    '获取使用频率
                    If asBuffer(24) <> 255 Then
                        strFrequency = GetFrequency(asBuffer(24))
                    End If

                    If (asBuffer(23) <> 0) And (asBuffer(23) <> 255) Then
                        '获取程序最后使用日期
                        strLastUsedOn = GetLastUsedOn(asBuffer(20), asBuffer(21), asBuffer(22), asBuffer(23))
                    End If
                End If

                '在 Listview 中设置数据
                Set lstvItem = lstview.ListItems.Add(, gcolKeys(lngCount), strDisplayName, lngCounterLarge, lngCounterSmall)
                lstvItem.SubItems(1) = strSize
                lstvItem.SubItems(2) = strLastUsedOn
                lstvItem.SubItems(3) = strFrequency
                lstvItem.SubItems(4) = strUninstallCommand
            End If
        End If
    Next
    '从内存清除集合
    Set gcolKeys = Nothing
    '重新设置当前视图
    lstview.View = lngPrevView
    '显示Listview
    lstview.Visible = True
    '选择列表中第一项
    If lstview.ListItems.Count > 0 Then
        If lstview.Visible = True Then
            lstview.SetFocus
        End If
        lstview.ListItems(1).Selected = True
        lstview_Click
    End If

    '根据视图情况同步菜单显示
    UncheckAll
    If lngPrevView = 0 Then
        mnu_LargeIcons.Checked = True
    ElseIf lngPrevView = 1 Then
        mnu_SmllIcons.Checked = True
    ElseIf lngPrevView = 2 Then
        mnu_list.Checked = True
    ElseIf lngPrevView = 3 Then
        mnu_details.Checked = True
    End If

    '状态栏显示应用程序数目
    StatusBar.Panels(1).Text = lstview.ListItems.Count & " 个程序可供卸载."
End Sub

' 参数:
' strEXEName -文件类型:包含图标的EXE或DLL文件
' lngLCounter -文件中大图标的数目
' lngSCounter -文件中小图标的数目
' lngIndex - 文件中图标索引号
Private Sub GetIcon(strEXEName As String, lngLCounter As Long, lngSCounter As Long, lngIndex As Long)
    Dim hLargeicon As Long, hSmallicon As Long

    On Error GoTo errHandle
    'IPicture 需要引用"标准 OLE 类型
    Dim pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID

    If ExtractIconEx(strEXEName, lngIndex, hLargeicon, hSmallicon, 1) > 0 Then
        '填充 IDispatch 接口 ID
        With IID_IDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With

        With pic
            .Size = Len(pic)          '结构大小
            .tType = vbPicTypeIcon    '图片（位图）类型
            .hBmp = hLargeicon        '位图的句柄
        End With

        '创建图片对象
        Call OleCreatePictureIndirect(pic, IID_IDispatch, 1, IPic)
        '在图像列表中添加大图标
        ImgLarge.ListImages.Add , , IPic
        '填充 IDispatch 接口 ID
        With IID_IDispatch
            .Data1 = &H20400
            .Data4(0) = &HC0
            .Data4(7) = &H46
        End With

        With pic
            .Size = Len(pic)
            .tType = vbPicTypeIcon
            .hBmp = hSmallicon        '这次获取小图标句柄
        End With

        Call OleCreatePictureIndirect(pic, IID_IDispatch, 1, IPic)

        '在图像列表中添加小图标
        ImgSmall.ListImages.Add , , IPic
        DestroyIcon hSmallicon       '清除大小图标句柄
        DestroyIcon hLargeicon

        '对大小图标计数
        lngLCounter = ImgLarge.ListImages.Count
        lngSCounter = ImgSmall.ListImages.Count
    Else
        '只有默认图标
        lngLCounter = 1
        lngSCounter = 1
    End If
    Exit Sub
errHandle:
    lngLCounter = 1
    lngSCounter = 1
E