• 再次改良不重启动清除运行记录 *

    2008-10-31 16:20:28

    苦搜索百度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

    查看(472) 评论(14) 收藏 推荐

  • Office2003信息弹出窗口 *

    2008-10-29 19:06:53



    有两个组件

    '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

    查看(136) 评论(2) 收藏 推荐

  • 优秀的卸载工具白金版 *

    2008-10-25 21:52:38

    一个很专业的开源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
    End Sub

    '调用卸载程序窗口
    Public Sub Show_FormUninstall()
        If lstview.SelectedItem Is Nothing Then
            Exit Sub
        End If
        FrmUninstaller.Show vbModal, FrmMain
        Set FrmUninstaller = Nothing
    End Sub

    Public Sub Get_Uninstall()
        If lstview.SelectedItem Is Nothing Then
            Exit Sub
        End If
        '调用应用软件卸载程序
        WinExec lstview.SelectedItem.SubItems(4), SW_SHOWNORMAL
    End Sub

    '根据屏蔽调整控件大小
    Private Sub Form_Resize()
        On Error Resume Next
        lstview.Move lstview.Left, lstview.Top, Me.Width - (picSideMenu.Width + 50), Me.Height - 1960
        picSideMenu.Height = Me.Height - 1960
        StatusBar.Top = Me.Height - 1960
    End Sub

    '删除条目(记录)
    Private Sub Delete_Entry_Click()
        If lstview.SelectedItem Is Nothing Then
            Exit Sub
        End If
         FrmDeleteEntry.Show vbModal, FrmMain
    End Sub

    '在左侧窗格中显示信息
    Public Sub lstview_Click()
        If lstview.SelectedItem Is Nothing Then
            Exit Sub
        End If
        lblExclaim.Caption = "您选择的程序是:(" & lstview.SelectedItem.Text & "), 程序可以从您的计算机中卸载.单击卸载按钮或者双击图标."
    End Sub

    '用户单击列头对Listview排序
    Private Sub lstview_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
        With lstview
            Static iLast As Long, iCur As Long
            .Sorted = True
            iCur = ColumnHeader.index - 1
            If iCur = iLast Then .SortOrder = IIf(.SortOrder = 1, 0, 1)
            .SortKey = iCur
            iLast = iCur
        End With
    End Sub

    '双击调用卸载窗口
    Private Sub lstview_DblClick()
        If lstview.SelectedItem Is Nothing Then
            Exit Sub
        End If
        Call Show_FormUninstall
    End Sub

    '弹出选项菜单
    Private Sub lstview_MouseUP(Button As Integer, Shift As Integer, x As Single, Y As Single)
        If lstview.SelectedItem Is Nothing Then
            Exit Sub
        End If
        If Button = vbRightButton Then
            PopupMenu mnu_Uninstall
        End If
    End Sub

    '当用户更改当前视图的Listview时清除菜单选择
    Private Sub UncheckAll()
        mnu_LargeIcons.Checked = False
        mnu_SmllIcons.Checked = False
        mnu_list.Checked = False
        mnu_details.Checked = False
    End Sub

    '修改应用程序图标
    Private Sub Mnu_ChangeIcon_Click()
        On Error Resume Next
        If lstview.SelectedItem Is Nothing Then
            Exit Sub
        End If
        With cmdlgIcon
            .DialogTitle = "请选择一个可执行文件或图标..."
            .filename = vbNullString
            .CancelError = True
            .Filter = "程序, 图标 (*.exe, *.ico)|*.exe;*.ico"
            .Flags = cdlOFNOverwritePrompt
            .ShowOpen
        End With

        If Err Then
            Exit Sub
        End If
        If LCase$(Right$(cmdlgIcon.filename, 3)) = "ico" Then
            SaveString HKEY_LOCAL_MACHINE, cUnInstallPath & lstview.SelectedItem.Key, "DisplayIcon", cmdlgIcon.filename
        Else
            SaveString HKEY_LOCAL_MACHINE, cUnInstallPath & lstview.SelectedItem.Key, "DisplayIcon", cmdlgIcon.filename & ",0" '如果是.exe文件则写注册表取第一个图标
        End If
        mnu_refresh_Click
    End Sub

    Private Sub mnu_hlptopics_Click()
        '显示帮助
        SendKeys "{F1}", False
    End Sub

    '工具栏命令建立Key名并调用
    Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
        Select Case Button.Key
            Case "tbUninstall"
            Show_FormUninstall

            Case "tbUninstallList"
            Delete_Entry_Click

            Case "tbSupportInfo"
            FrmInfo.Show vbModal, FrmMain

            Case "tbChangeIcon"
            Mnu_ChangeIcon_Click

            Case "tbReport"
            FrmReport.Show vbModal, FrmMain

            Case "tbNew"
            mnu_NewPrg_Click

            Case "tbUninstallLog"
            FrmUninstallLog.Show vbModal, Me

            Case "tbHelp"
            SendKeys "{F1}"

            Case "tbExit"
            mnu_Exit_Click
        End Select
    End Sub

    '获取软件使用频率
    Private Function GetFrequency(lngFrequency As Byte) As String
        On Error GoTo errHandle
        If lngFrequency < 3 Then
            GetFrequency = "很少"
        ElseIf (lngFrequency >= 3) And (lngFrequency <= 10) Then
            GetFrequency = "偶尔"
        ElseIf lngFrequency > 10 Then
            GetFrequency = "经常"
        End If
    errHandle:
    End Function

    '采用四字节DWord并以MB为单位返回一个文件的大小
    Private Function GetFileSize(ByVal byte1 As Byte, ByVal byte2 As Byte, ByVal byte3 As Byte, ByVal byte4 As Byte) As String
        Dim lngSize As Long
        On Error GoTo errHandle
        '转换到DWord为Long
        lngSize = byte1 + (byte2 * 256#) + (byte3 * 65536#) + (byte4 * 16777216#)
        '以MB为单位返回字符串
        GetFileSize = Format$(lngSize / 1024 / 1024, "0.0") & " MB"
        Exit Function
    errHandle:
        GetFileSize = vbNullString
    End Function

    '显示最后使用日期
    '采用四字节DWord并返回格式化的日期字符串
    Private Function GetLastUsedOn(ByVal byte1 As Byte, ByVal byte2 As Byte, ByVal byte3 As Byte, ByVal byte4 As Byte) As String
        On Error GoTo errHandle

        Dim stExpire As SYSTEMTIME, tYear As Long, dExpire As Date, lngLastusedOn As Long
        Dim strDate As String
        '转换到DWord为Long
        lngLastusedOn = byte1 + (byte2 * 256#) + (byte3 * 65536#) + (byte4 * 16777216#)
        strDate = CStr(lngLastusedOn)
        stExpire = MSIEDate(strDate, strDate)
        If stExpire.wYear > 9999 Then
            tYear = stExpire.wYear - 7999
        Else
            tYear = 0
        End If
        dExpire = DateSerial(stExpire.wYear - tYear, stExpire.wMonth, stExpire.wDay)

        '在 Windows 2000 中，日期转换后还要添加1天
        If InStr(GetOSVersion, "2000") <> 0 Then
            dExpire = DateAdd("d", 1, dExpire)
        End If

        '返回格式化的日期
        GetLastUsedOn = Format$(dExpire, "YYYY-MM-DD")
        Exit Function
    errHandle:
        GetLastUsedOn = vbNullString
    End Function

    '将日期转换为适当的格式
    Private Function MSIEDate(ByVal hiDateTime As String, ByVal loDateTime As String) As SYSTEMTIME
        Dim ST As SYSTEMTIME
        Dim FT As FILETIME

        FT.dwHighDateTime = UnsignedToLong(CDbl(hiDateTime))
        FT.dwLowDateTime = UnsignedToLong(CDbl(loDateTime))
        FileTimeToSystemTime FT, ST
        MSIEDate = ST
    End Function

    '将从无符号转换一个 Long值
    Function UnsignedToLong(ByVal Value As Double) As Long
        If Value < 0 Or Value >= OFFSET_4 Then
            Exit Function
        End If
        If Value <= MAXINT_4 Then
            UnsignedToLong = Value
        Else
            UnsignedToLong = Value - OFFSET_4
        End If
    End Function

    '例程来选择／突出显示与搜索关键字匹配的程序名
    Private Sub cmdFind_Click()
        Dim iKey As String, i As Integer, start As Integer
        '获取搜索字符串
        iKey = Trim$(txtFind)
        '从选择的最后一项开始搜索
        start = lstview.SelectedItem.index
        '搜索完毕时然后重新开始
        If (mLastSearch = iKey And Exhausted) Or (start = lstview.ListItems.Count) Then
            start = 1
        End If

        '如果是新关键字搜索则重头开始搜索
        If iKey <> mLastSearch Then
            start = 1
        End If

        '从下一项继续搜索
        If start >= 1 And Not Exhausted Then
            start = start + 1
        End If

        '执行搜索
        For i = start To lstview.ListItems.Count
            If InStr(1, UCase$(lstview.ListItems(i).Text), UCase$(iKey)) Then
                lstview.SetFocus
                lstview.ListItems(i).Selected = True
                lstview.ListItems(i).EnsureVisible
                lstview_Click
                Exhausted = False
                Exit For
            Else
                Exhausted = True
            End If
        Next

        '存储在最后一个搜索关键字
        mLastSearch = iKey

        If Exhausted Then
            MsgBox "你所查找的软件(" & iKey & ")不存在！", vbInformation, App.Title
        End If
    End Sub

    Private Sub txtFind_KeyUp(KeyCode As Integer, Shift As Integer)
        If KeyCode = vbKeyReturn Then
            cmdFind_Click
        End If
    End Sub

    '建立新卸载程序
    Private Sub mnu_NewPrg_Click()
        FrmNewEntry.Show vbModal, FrmMain
    End Sub

    '查看应用程序明细信息
    Private Sub mnu_prgdtls_Click()
        If lstview.SelectedItem Is Nothing Then
            Exit Sub
        End If
        FrmInfo.Show vbModal, FrmMain
    End Sub

    '打印和保存报表
    Private Sub mnu_PrntNSaveAudit_Click()
        FrmReport.Show vbModal, FrmMain
    End Sub

    '刷新应用程序列表
    Public Sub mnu_refresh_Click()
        ShowUnInstallList
    End Sub

    '调用卸载窗口
    Private Sub mnu_uninstallProg_Click()
        Show_FormUninstall
    End Sub

    '查看卸载日志
    Private Sub mnu_UninstLog_Click()
        FrmUninstallLog.Show vbModal, Me
    End Sub

    '删除条目(记录)
    Private Sub mnu_DelFrmLst_Click()
        Delete_Entry_Click
    End Sub

    '编辑支持信息
    Private Sub mnu_EditPrgDtls_Click()
        If lstview.SelectedItem Is Nothing Then
            Exit Sub
        End If
        FrmEditEntry.Show vbModal, FrmMain
    End Sub
    '退出
    Private Sub mnu_Exit_Click()
        Unload Me
    End Sub

    '显示小图标
    Private Sub mnu_SmllIcons_Click()
        lstview.View = lvwSmallIcon
        UncheckAll
        mnu_SmllIcons.Checked = True
    End Sub

    '显示详细资料
    Private Sub mnu_Details_Click()
        lstview.View = lvwReport
        UncheckAll
        mnu_details.Checked = True
    End Sub

    '显示大图标
    Private Sub mnu_LargeIcons_Click()
        lstview.View = lvwIcon
        UncheckAll
        mnu_LargeIcons.Checked = True
    End Sub

    '列表显示
    Private Sub mnu_List_Click()
        lstview.View = lvwList
        UncheckAll
        mnu_list.Checked = True
    End Sub
    '关于
    Private Sub mnu_About_Click()
        '显示关于
        FrmAbout.Show vbModal, Me
    End Sub

    '卸载所有窗体，不过本程序是调用模式窗体
    Private Sub Form_Unload(Cancel As Integer)
        Dim objForm As Form
        For Each objForm In Forms
            If objForm.name <> Me.name Then
                Unload objForm
                Set ōbjForm = Nothing
            End If
        Next objForm
    End Sub    'modRegistry

    CODE:

    Option Explicit

    '返回值
    Private Const ERROR_SUCCESS = 0&

    '注册表数据类型
    Public Enum eRegvalueType
        REG_SZ = 1                             ' Unicode空终结字符串
        REG_EXPAND_SZ = 2                      ' Unicode空终结字符串
        REG_BINARY = 3                         ' 二进制数值
        REG_DWORD = 4                          ' 32-bit 数字
        REG_DWORD_BIG_ENDIAN = 5
        REG_LINK = 6
        REG_MULTI_SZ = 7                       ' 二进制数值串
    End Enum

    '注册表安全属性
    Private Const KEY_QUERY_VALUE = &H1
    Private Const KEY_ENUMERATE_SUB_KEYS = &H8
    Private Const KEY_NOTIFY = &H10&
    Private Const READ_CONTROL = &H20000
    Private Const STANDARD_RIGHTS_READ = READ_CONTROL
    Private Const KEY_READ = STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY

    Public Enum HKeyTypes
        HKEY_LOCAL_MACHINE = &H80000002
    End Enum

    Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hkey As Long) As Long
    Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
    Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hkey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long

    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, source As Any, ByVal numBytes As Long)

    Private Declare Function SHEnumKeyEx Lib "shlwapi.dll" Alias "SHEnumKeyExA" (ByVal hkey As Long, ByVal dwIndex As Long, ByVal pszName As String, ByRef pcchName As Long) As Long
    Private Declare Function SHGetValue Lib "shlwapi.dll" Alias "SHGetValueA" _
                              (ByVal hkey As Long, ByVal pszSubKey As String, _
                              ByVal pszValue As String, ByRef pdwType As Long, _
                              ByVal pvData As Any, _
                              ByRef pcbData As Long) As Long  'pvData要ByVal，否则VB崩溃，原声明为ByRef
    Private Declare Function SHDeleteKey Lib "shlwapi.dll" Alias "SHDeleteKeyA" (ByVal hkey As Long, ByVal pszSubKey As String) As Long
    Private Declare Function SHEnumValue Lib "shlwapi.dll" Alias "SHEnumValueA" _
                              (ByVal hkey As Long, ByVal dwIndex As Long, ByVal pszValueName As String, _
                              ByRef pcchValueName As Long, ByRef pdwType As Long, _
                              pvData As Any, ByRef pcbData As Long) As Long
    Private Declare Function SHSetValue Lib "shlwapi.dll" Alias "SHSetValueA" (ByVal hkey As Long, ByVal pszSubKey As String, ByVal pszValue As String, ByVal dwType As Long, pvData As Any, ByVal cbData As Long) As Long

    Public Sub SaveString(ByVal hkey As HKeyTypes, ByVal strPath As String, ByVal strValue As String, ByVal strData As String)
        Dim R As Long
        R = SHSetValue(hkey, strPath, strValue, REG_SZ, ByVal strData, LenB(strData))
    End Sub

    Public Sub DeleteKey(ByVal hkey As HKeyTypes, ByVal strPath As String)
        Dim R As Long
        R = SHDeleteKey(hkey, strPath)      '连根拔出一个子键
    End Sub

    '将一个键下所有子键名装入全局集合
    Public Sub GetKeyNames(ByVal hkey As Long, ByVal strPath As String, ByVal gcolKeys As Collection)
        Dim lIndex As Long, StrBuff As String, strKey As String, TKey As Long

        RegOpenKeyEx hkey, strPath, 0, KEY_READ, TKey  '将项名打开供SHEnumKeyEx使用
        Do
            StrBuff = String$(255, vbNullChar)
            If SHEnumKeyEx(TKey, lIndex, StrBuff, 255) <> 0 Then Exit Do
            lIndex = lIndex + 1
            strKey = Left$(StrBuff, InStr(StrBuff, vbNullChar) - 1)
            gcolKeys.Add strKey
        Loop
        RegCloseKey TKey
    End Sub

    '枚举项中的所有值
    '集合返回每个键的名称、数据类型到一个大小为3的一维数组中
    Public Function EnumRegistryValuesEx(ByVal hkey As Long, Optional ByVal KeyName As String) As Collection
        On Error Resume Next
        Dim lHandle As Long, lIndex As Long, lValueType As Long, sName As String, lNameLen As Long
        Dim resLong As Long, strData As String, lDataLen As Long, avalueInfo(0 To 2) As Variant
        Dim lRet As Long

        '初始化集合
        Set EnumRegistryValuesEx = New Collection

        '打开键，如果不需要则退出。
        If Len(KeyName) Then
            If RegOpenKeyEx(hkey, KeyName, 0, KEY_READ, lHandle) Then Exit Function
            '如果存在子键，则得到子键句柄，否则直接取主键句柄供SHEnumValue的hkey参数。
            hkey = lHandle
        End If

        Do
            '定义主要名称的最大长度
            lNameLen = 260
            sName = Space$(lNameLen)
            '接收缓冲区赋值
            lDataLen = 4096
            ReDim resBinary(0 To lDataLen - 1) As Byte
            lRet = SHEnumValue(hkey, lIndex, sName, lNameLen, lValueType, resBinary(0), lDataLen) '会得到键名sName和数据和相关大小

            '如果有错误则退出循环。
            If lRet Then Exit Do

            '获取值的名称
            avalueInfo(0) = Left$(sName, lNameLen)    '数组索引0存键名，索引1存数据内容，索引3存数据类型。
            avalueInfo(1) = vbNullString
            avalueInfo(2) = vbNullString

            '根据对应值类型返回值
            Select Case lValueType

                Case REG_SZ, REG_EXPAND_SZ
                '将所有内容除尾部添加的一个VbNullChar复制到strData中
                strData = Space$(lDataLen - 1)
                CopyMemory ByVal strData, resBinary(0), lDataLen - 1
                avalueInfo(1) = strData
                avalueInfo(2) = vbString

                '            Case REG_DWORD
                '            CopyMemory resLong, resBinary(0), 4
                '            avalueInfo(1) = resLong
                '            avalueInfo(2) = vbLong

                '            Case REG_BINARY
                '            '如有必要收缩缓冲区
                '            If lDataLen < UBound(resBinary) + 1 Then
                '                ReDim Preserve resBinary(0 To lDataLen - 1) As Byte
                '            End If
                '            avalueInfo(1) = resBinary()
                '            avalueInfo(2) = vbArray + vbByte
                '            Case REG_MULTI_SZ
                '            '复制所有内容但尾随空 chars 2
                '            strData = Space$(lDataLen - 2)
                '            CopyMemory ByVal strData, resBinary(0), lDataLen - 2
                '            avalueInfo(1) = strData
                '            avalueInfo(2) = vbString
                '            Case Else              '不支持值类型
            End Select

            '将数组添加到结果集合，该元素的键是值的名称
            EnumRegistryValuesEx.Add avalueInfo, avalueInfo(0)
            lIndex = lIndex + 1  '将索引指向下一个键值
        Loop

        '如果有打开的主子键句柄则关闭
        If lHandle Then RegCloseKey lHandle
    End Function

    '*************************************************************************
    '**函 数 名： GetBinaryValue
    '**输    入： lngKeyRoot(Long) -根键
    '**     ：    subKey(String)   -子项
    '**     ：    Entry(String)    -键名
    '**     ：    sBuffer()(Byte)  -读取的Binary值->ByRef
    '**输    出： (Boolean)        -是否成功
    '**功能描述： 获取Binary值。
    '**全局变量：
    '**调用模块： 本来用SHGetValue也可以读取，但使代码变复杂，故分出此函数专门读取Binary
    '**作    者： Mr.David
    '**日    期： 2008-10-22 21:17:20
    '**修 改 人：
    '**日    期：
    '**版    本： V1.0.0
    '*************************************************************************
    Public Function GetBinaryValue(ByVal lngKeyRoot As Long, ByVal subKey As String, ByVal Entry As String, ByRef sBuffer() As Byte) As Boolean
        Dim hkey As Long, lBufferSize As Long, lRet As Long

        On Error GoTo errHandle
        lRet = RegOpenKeyEx(lngKeyRoot, subKey, 0, KEY_READ, hkey) '打开键
        If lRet = ERROR_SUCCESS Then
            lBufferSize = 1             '首先给定义缓冲区大小为1，如果不够RegQueryValueEx会返回实际需要的缓冲区大小
            lRet = RegQueryValueEx(hkey, Entry, 0, REG_BINARY, 0, lBufferSize)
            ReDim sBuffer(lBufferSize - 1)
            lRet = RegQueryValueEx(hkey, Entry, 0, REG_BINARY, sBuffer(0), lBufferSize) '读取BINARY值
            If lRet = ERROR_SUCCESS Then
                lRet = RegCloseKey(hkey)
                '检查数组的大小是否正确,这里的数组长度的确是551
                If UBound(sBuffer) = 551 Then
                    GetBinaryValue = True
                End If
            End If
        End If
        Exit Function
    errHandle:
        GetBinaryValue = False
    End Function

    '*************************************************************************
    '**函 数 名：GetRegValue
    '**输    入：ByVal hkey(Long)       -主键
    '**        ：ByVal strPath(String)  -键的路径
    '**        ：ByVal strValue(String) -健值
    '**        ：ByVal lngType(Long)    -键值类型
    '**输    出：(Variant) -            -要获取的数据,可返回字符和数值。
    '**功能描述：读取注册表键REG_DWORD和REG_SZ值
    '**全局变量：
    '**调用模块：
    '**作    者：Mr.David
    '**日    期：2008-10-21 21:31:42
    '**修 改 人：Mr.David  将REG_SZ和REG_DWORD合并为一个函数读取
    '**日    期：
    '**版    本：V1.0.0
    '*************************************************************************
    Public Function GetRegValue(ByVal hkey As Long, ByVal strPath As String, ByVal strValue As String, ByVal lngType As Long) As Variant
        Dim lResult As Long
        Dim strBuf As String
        Dim lngPos As Long
        Dim lngBuf As Long
        Select Case lngType
            Case REG_SZ
            strBuf = String$(255, vbNullChar)
            lResult = SHGetValue(hkey, strPath, strValue, lngType, strBuf, 255)
            If lResult = ERROR_SUCCESS Then
                lngPos = InStr(strBuf, vbNullChar)
                If lngPos > 0 Then
                    GetRegValue = Left$(strBuf, lngPos - 1)
                Else
                    GetRegValue = strBuf
                End If
            End If
            Case REG_DWORD
            lResult = SHGetValue(hkey, strPath, strValue, lngType, VarPtr(lngBuf), 4)
            GetRegValue = CLng(Hex$(lngBuf))
        End Select
    End Function    'frmEditEntry

    CODE:

    Option Explicit

    '调整列宽度
    Dim mlngColWidth As Long

    Private Sub Form_Load()
        Dim i As Long
        Dim strTemp As String, colTemp As Collection, varArr As Variant

        On Error Resume Next
        Me.Icon = FrmMain.Icon                              '设置应用程序的默认图标
        MSFEntries.TextMatrix(0, 0) = "注册表项"            '为该MsFlexGrid设置标题
        MSFEntries.TextMatrix(0, 1) = "注册表值"

        '从主窗体的列表视图下可以找到选择的程序的注册表中的显示名称
        TxtDName.Text = FrmMain.lstview.SelectedItem.Text
        imgSoftLarge.Picture = FrmMain.ImgLarge.ListImages(FrmMain.lstview.SelectedItem.Icon).Picture

        'EnumRegistryValuesEx 将枚举注册表项的值添加到临时集合，集合中对象为长度为3的1维数组。
        Set colTemp = EnumRegistryValuesEx(HKEY_LOCAL_MACHINE, cUnInstallPath & FrmMain.lstview.SelectedItem.Key)

        If colTemp.Count > 0 Then
            For i = 1 To colTemp.Count
                '检索存储在数组中的数据
                varArr = colTemp.Item(i)
                '添加项目说明到网格中
                AddItem Trim$(varArr(0)), Trim$(varArr(1))
            Next
        End If

        '因为我们要保持固定的行数<总行数。
        '因此在开始中引入了一个空行,这应该删除。
        MSFEntries.RemoveItem 1
        If MSFEntries.ColWidth(1) < mlngColWidth Then    '对第二列宽按实际字符显示长度调整。
            MSFEntries.ColWidth(1) = mlngColWidth
        End If
    End Sub

    ' AddItem:-     把一新的项目加入 MsFlexGrid
    ' Heading:      这是第一项名称
    ' Descrīption:  实际数据内容
    Private Sub AddItem(ByVal Heading As String, ByVal Desc As String)
        On Error GoTo errHandle
        If MSFEntries.Rows >= 2 Then
            MSFEntries.Rows = MSFEntries.Rows + 1  '增加一项目则增加一行当行数大于2时
        End If

        ' 头部部分及放到第一及第二列的说明网格分别
        MSFEntries.Row = MSFEntries.Rows - 1            '指定MSHFlexGrid 中的输出单元坐标
        MSFEntries.Col = 0
        MSFEntries.CellAlignment = flexAlignLeftCenter  '字符串的缺省对齐方式。单元格的内容左、居中对齐。
        MSFEntries.TextMatrix(MSFEntries.Rows - 1, 0) = Trim$(Heading)
        MSFEntries.Col = 1
        MSFEntries.CellAlignment = flexAlignLeftCenter
        MSFEntries.TextMatrix(MSFEntries.Rows - 1, 1) = Trim$(Desc)
        If TextWidth(Trim$(Desc)) > mlngColWidth Then
            mlngColWidth = TextWidth(Trim$(Desc))       '保存实际列宽
        End If
        Exit Sub
    errHandle:
        MsgBox "编辑条目出错:" & vbCrLf & Err.Descrīption, vbCritical, App.Title
    End Sub

    '在网格中添加新行
    Private Sub cmdAdd_Click()
        MSFEntries.Rows = MSFEntries.Rows + 1
        MSFEntries.SetFocus
    End Sub

    Private Sub cmdCancel_Click()
        Unload Me
    End Sub

    '删除选定的行。
    Private Sub cmdDelete_Click()
        On Error Resume Next
        Dim intMsg As Integer

        intMsg = MsgBox("你确实要删除该值吗?", vbQuestion + vbYesNo, App.Title)
        If intMsg = vbNo Then
            Exit Sub
        End If
        MSFEntries.RemoveItem MSFEntries.RowSel
        MSFEntries.SetFocus
    End Sub

    Private Sub cmdOk_Click()
        On Error GoTo errHandle

        Dim i As Long

        '删除Uinstall项
        DeleteKey HKEY_LOCAL_MACHINE, cUnInstallPath & FrmMain.lstview.SelectedItem.Key

        '只需再重新创建所有项
        With MSFEntries
            For i = 1 To .Rows - 1
                If Len(Trim$(.TextMatrix(i, 0))) > 0 Then
                    SaveString HKEY_LOCAL_MACHINE, cUnInstallPath & FrmMain.lstview.SelectedItem.Key, Trim$(.TextMatrix(i, 0)), Trim$(.TextMatrix(i, 1) & vbNullChar)
                End If
            Next
        End With

        Unload Me
        FrmMain.mnu_refresh_Click
        Exit Sub
    errHandle:
        MsgBox "编辑项目出错！" & vbCrLf & Err.Descrīption, vbCritical, App.Title
    End Sub

    'MSFEntries获取焦点，接收Txt中文本内容
    Private Sub MSFEntries_GotFocus()
        If txtEdit.Visible = False Then Exit Sub
        MSFEntries = txtEdit.Text
        txtEdit.Visible = False
    End Sub

    'MSFEntries失去焦点，离开单元格
    Private Sub MSFEntries_LeaveCell()
        If txtEdit.Visible = False Then Exit Sub
        MSFEntries = txtEdit
        txtEdit.Visible = False
    End Sub

    Private Sub EditKeyCode(MSHFlexGrid As Control, Edt As Control, KeyCode As Integer, Shift As Integer)
        '标准的编辑控件处理。
        Select Case KeyCode
            Case vbKeyEscape      '按下ESC:隐藏，返回焦点给MSHFlexGrid.
            Edt.Visible = False
            MSHFlexGrid.SetFocus
            Case vbKeyReturn      '按下ENTER键设置焦点给MSHFlexGrid.
            MSHFlexGrid.SetFocus
            Case vbKeyUp          '按下Up键.
            MSHFlexGrid.SetFocus
            DoEvents
            If MSHFlexGrid.Row > MSHFlexGrid.FixedRows Then
                MSHFlexGrid.Row = MSHFlexGrid.Row - 1        '上移一行
            End If
            Case vbKeyDown       '按下Down键.
            MSHFlexGrid.SetFocus
            DoEvents
            If MSHFlexGrid.Row < MSHFlexGrid.Rows - 1 Then
                MSHFlexGrid.Row = MSHFlexGrid.Row + 1        '下移一行
            End If
        End Select
    End Sub

    Private Sub MSFEntries_KeyPress(KeyAscii As Integer)      '处理MSHFlexGrid的键盘事件，转入编辑Txt控件处理
        MSHFlexGridEdit MSFEntries, txtEdit, KeyAscii
    End Sub

    Private Sub MSFEntries_Click()
        MSHFlexGridEdit MSFEntries, txtEdit, vbKeySpace       '模拟空格键
    End Sub

    Private Sub MSHFlexGridEdit(MSHFlexGrid As MSFlexGrid, txtEdit As TextBox, KeyAscii As Integer)
        '文本控件在MSHFlexGrid中显示的宽度
        Dim lngWidth As Long
        '分析键入的字符。
        Select Case KeyAscii
            '按下空格和一些能接收的特别键则等于编辑当前的文本。
            Case 0 To 32
            txtEdit = MSHFlexGrid.Text
            txtEdit.SelStart = 0
            '其余按键则直接输入文本框.
            Case Else
            txtEdit = Chr$(KeyAscii)
            txtEdit.SelStart = 1
        End Select
        '
        '    '如果MSHFlexGrid的单元宽度大于MSHFlexGrid的宽度                    'A
        '    If MSHFlexGrid.CellWidth > MSHFlexGrid.Width Then
        '        '且行数大于5行
        '        If MSFEntries.Rows > 5 Then
        '            lngWidth = MSHFlexGrid.Width - 275
        '        Else
        '            '行数小于5行
        '            lngWidth = MSHFlexGrid.Width - 50
        '        End If
        '    Else
        '        lngWidth = MSHFlexGrid.CellWidth
        '    End If
        '
        '    '在正确的位置显示txtEdit。
        '    txtEdit.Move MSHFlexGrid.Left + MSHFlexGrid.CellLeft + 50, _
            '                 MSHFlexGrid.Top + MSHFlexGrid.CellTop + 10, _
            '                 lngWidth - 42, MSHFlexGrid.CellHeight - 8         'B
        '
        '从A-B间代码我看不懂为什么要那样写，如是是我则这样
        txtEdit.Move MSHFlexGrid.Left + MSHFlexGrid.CellLeft, _
                     MSHFlexGrid.Top + MSHFlexGrid.CellTop, _
                     MSHFlexGrid.CellWidth, MSHFlexGrid.CellHeight

        txtEdit.Visible = True
        txtEdit.SetFocus
    End Sub

    'MSHFlexGrid滚动时隐藏Txt编辑控件
    Private Sub MSFEntries_Scroll()
        If txtEdit.Visible = True Then
            txtEdit.Text = vbNullString
            txtEdit.Visible = False
        End If
    End Sub

    Private Sub txtEdit_KeyPress(KeyAscii As Integer)
        '按回车键不发声
        If KeyAscii = Asc(vbCr) Then
            KeyAscii = 0
        End If
    End Sub

    Private Sub txtEdit_KeyDown(KeyCode As Integer, Shift As Integer)
        EditKeyCode MSFEntries, txtEdit, KeyCode, Shift
    End Sub

    Private Sub txtEdit_LostFocus()
        MSFEntries_LeaveCell
    End Sub    'frmReport

    CODE:

    查看(177) 评论(3) 收藏 推荐

  • 化力气为糨糊的精简代码->>控制面板中添加应用程序 *

    2008-10-19 21:25:27

    实现同样功能

    'frm

    CODE:

    Option Explicit

    Private Sub Command1_Click()
        CreateEntryToSystemPanel "{9d6D8ED6-116D-4D4E-B1C2-87098DB509BA}", "枕善居控制面板", "欢迎访问 http://www.mndsoft.com", App.Path & "\" & App.EXEName & ".exe,0", App.Path & "\" & App.EXEName & ".exe -options"
        Shell ("rundll32.exe shell32.dll,Control_RunDLL"), vbNormalFocus
    End Sub

    Private Sub Command2_Click()
        RemoveEntryToSystemPanel "{9d6D8ED6-116D-4D4E-B1C2-87098DB509BA}"
    End Sub    'mod

    CODE:

    Option Explicit
    Private Const REG_SZ = 1
    Private Const REG_BINARY = 3&
    Private Const HKEY_CLASSES_ROOT = &H80000000
    Private Const HKEY_LOCAL_MACHINE = &H80000002
    Private Declare Function SHSetValue Lib "shlwapi.dll" Alias "SHSetValueA" (ByVal hkey As Long, ByVal pszSubKey As String, ByVal pszValue As String, ByVal dwType As Long, pvData As Any, ByVal cbData As Long) As Long
    Private Declare Function SHDeleteKey Lib "shlwapi.dll" Alias "SHDeleteKeyA" (ByVal hkey As Long, ByVal pszSubKey As String) As Long

    Public Function CreateEntryToSystemPanel(GUID As String, Titel As String, ToolTipText As String, IconDatei As String, FileToOpen As String)
        Dim lngRet As Long
        lngRet = SHSetValue(HKEY_CLASSES_ROOT, "CLSID\" & GUID, vbNullString, REG_SZ, ByVal Titel, LenB(Titel) + 1)
        lngRet = SHSetValue(HKEY_CLASSES_ROOT, "CLSID\" & GUID, "InfoTip", REG_SZ, ByVal ToolTipText, LenB(ToolTipText) + 1)
        lngRet = SHSetValue(HKEY_CLASSES_ROOT, "CLSID\" & GUID & "\DefaultIcon", vbNullString, REG_SZ, ByVal IconDatei, LenB(IconDatei) + 1)
        lngRet = SHSetValue(HKEY_CLASSES_ROOT, "CLSID\" & GUID & "\InProcServer32", vbNullString, REG_SZ, ByVal "shell32.dll", LenB("shell32.dll") + 1)
        lngRet = SHSetValue(HKEY_CLASSES_ROOT, "CLSID\" & GUID & "\InProcServer32", "ThreadingModel", REG_SZ, ByVal "Apartment", LenB("Apartment") + 1)
        lngRet = SHSetValue(HKEY_CLASSES_ROOT, "CLSID\" & GUID & "\Shell", vbNullString, REG_SZ, vbNullString, 0)
        lngRet = SHSetValue(HKEY_CLASSES_ROOT, "CLSID\" & GUID & "\Shell\Open", vbNullString, REG_SZ, vbNullString, 0)
        lngRet = SHSetValue(HKEY_CLASSES_ROOT, "CLSID\" & GUID & "\Shell\Open\Command", vbNullString, REG_SZ, ByVal FileToOpen, LenB(FileToOpen) + 1)
        lngRet = SHSetValue(HKEY_CLASSES_ROOT, "CLSID\" & GUID & "\ShellFolder", "Attributes", REG_BINARY, 0, 4)

        lngRet = SHSetValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Desktop\NameSpace\{9d6D8ED6-116D-4D4E-B1C2-87098DB509BA}", vbNullString, REG_SZ, vbNullString, 0)
        lngRet = SHSetValue(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\ControlPanel\NameSpace\{9d6D8ED6-116D-4D4E-B1C2-87098DB509BA}", vbNullString, REG_SZ, vbNullString, 0)
    End Function

    Public Sub RemoveEntryToSystemPanel(GUID As String)
        Dim lngRet As Long
        lngRet = SHDeleteKey(HKEY_CLASSES_ROOT, "CLSID\" & GUID)
        lngRet = SHDeleteKey(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\Desktop\NameSpace\ " & GUID)
        lngRet = SHDeleteKey(HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\ControlPanel\NameSpace\" & GUID)
    End Sub    '原代码mod

    CODE:

    '****************************************************************************
    '人人为我，我为人人
    '枕善居汉化收藏整理
    '发布日期：05/05/29
    '描  述：在系统控制面板建立自己的程序
    '网  站：http://www.mndsoft.com/
    'e-mail：mnd@mndsoft.com
    'OICQ  : 88382850
    '****************************************************************************
    ' This Modul read and write Registrykeys.
    '---------------------------------------------------------------
    '- API-Declarationen for Registrysettings
    '---------------------------------------------------------------
    Private Declare Function RegCloseKey Lib "advapi32" (ByVal hKey As Long) As Long
    Private Declare Function RegCreateKeyEx Lib "advapi32" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByRef lpSecurityAttributes As SECURITY_ATTRIBUTES, ByRef phkResult As Long, ByRef lpdwDisposition As Long) As Long
    Private Declare Function RegOpenKeyEx Lib "advapi32" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, ByRef phkResult As Long) As Long
    Private Declare Function RegQueryValueEx Lib "advapi32" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, ByRef lpType As Long, ByVal lpData As String, ByRef lpcbData As Long) As Long
    Private Declare Function RegSetValueEx Lib "advapi32" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
    Private Declare Function RegSetValueExB Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByRef lpData As Byte, ByVal cbData As Long) As Long
    Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
    Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long

    '---------------------------------------------------------------
    '- API-Constant for Registry...
    '---------------------------------------------------------------
    ' Registrytype...
    Const REG_SZ = 1 ' Null-terminate Unicode-Zeichenfolge
    Const REG_EXPAND_SZ = 2 ' Null-terminate Unicode-Zeichenfolge
    Const REG_BINARY = 3&
    Const REG_DWORD = 4 ' 32-Bit-Number

    ' Create Registrykeys-Typs...
    Const REG_OPTION_NON_VOLATILE = 0 ' Key is exists on Systemstart

    ' Registrykeys Securityoptions...
    Const READ_CONTROL = &H20000
    Const KEY_QUERY_VALUE = &H1
    Const KEY_SET_VALUE = &H2
    Const KEY_CREATE_SUB_KEY = &H4
    Const KEY_ENUMERATE_SUB_KEYS = &H8
    Const KEY_NOTIFY = &H10
    Const KEY_CREATE_LINK = &H20
    Const KEY_READ = KEY_QUERY_VALUE + KEY_ENUMERATE_SUB_KEYS + KEY_NOTIFY + READ_CONTROL
    Const KEY_WRITE = KEY_SET_VALUE + KEY_CREATE_SUB_KEY + READ_CONTROL
    Const KEY_EXECUTE = KEY_READ
    Const KEY_ALL_ACCESS = KEY_QUERY_VALUE + KEY_SET_VALUE + _
          KEY_CREATE_SUB_KEY + KEY_ENUMERATE_SUB_KEYS + _
          KEY_NOTIFY + KEY_CREATE_LINK + READ_CONTROL

    ' Registry-types...
    Const HKEY_CLASSES_ROOT = &H80000000
    Const HKEY_CURRENT_USER = &H80000001
    Const HKEY_LOCAL_MACHINE = &H80000002
    Const HKEY_USERS = &H80000003
    Const HKEY_PERFORMANCE_DATA = &H80000004

    ' Feedback...
    Const ERROR_NONE = 0
    Const ERROR_BADKEY = 2
    Const ERROR_ACCESS_DENIED = 8
    Const ERROR_SUCCESS = 0

    '---------------------------------------------------------------
    '- Accessattrib of Registry...
    '---------------------------------------------------------------
    Private Type SECURITY_ATTRIBUTES
        nLength As Long
        lpSecurityDescrīptor As Long
        bInheritHandle As Boolean
    End Type

    Dim hKey As Long, MainKeyHandle As Long
    Dim rtn As Long, lBuffer As Long, sBuffer As String
    Dim lBufferSize As Long
    Dim lDataSize As Long
    Dim ByteArray() As Byte
    '-----------------------------------------------------------
    'Example - Debug.Print UpodateKey(HKEY_CLASSES_ROOT, "keyname", "newvalue")
    '-----------------------------------------------------------

    '系统限制字符只好省略  :run

    Private Function CreateKey(SubKey As String)

        Call ParseKey(SubKey, MainKeyHandle)

        If MainKeyHandle Then
            rtn = RegCreateKey(MainKeyHandle, SubKey, hKey) 'create the key
            If rtn = ERROR_SUCCESS Then 'if the key was created then
                rtn = RegCloseKey(hKey) 'close the key
            End If
        End If

    End Function

    Public Function DeleteEntryFromSystemPanel(GUID As String)

        DeleteKey "HKEY_CLASSES_ROOT\CLSID\" & GUID
        DeleteKey "HKEY_CLASSES_ROOT\CLSID\" & GUID & "\DefaultIcon"
        DeleteKey "HKEY_CLASSES_ROOT\CLSID\" & GUID & "\InProcServer32"
        DeleteKey "HKEY_CLASSES_ROOT\CLSID\" & GUID & "\Shell\Open\Command"
        DeleteKey "HKEY_CLASSES_ROOT\CLSID\" & GUID & "\ShellEx\PropertySheetHandlers\" & GUID & ""
        DeleteKey "HKEY_CLASSES_ROOT\CLSID\" & GUID & "\ShellFolder"
        DeleteKey "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\ CurrentVersion\Explorer\Desktop\NameSpace\" & GUID
        DeleteKey "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\ CurrentVersion\Explorer\ControlPanel\NameSpace\" & GUID

    End Function    SHDeleteKey可以递归删除注册表子键
    SHSetValue操作不用开关句柄，既可以建立主键，又可以直接设置键值。             真是好家伙，增强型API。

    CreateSystemControlPanel修改.rar
    (2008-10-18 22:14:07, Size: 33.4 kB, Downloads: 11)


    CreateSystemControlPanel原.rar
    (2008-10-18 22:14:07, Size: 16.2 kB, Downloads: 8)

    查看(287) 评论(6) 收藏 推荐

  • Office2007强制完美卸載工具 *

    2008-10-14 20:24:57

    软件介绍
             
    Office2007强制完美卸載工具,此工具完美卸载安装文件并且恢复注册表到安装前状态

    Office2007卸载不了，只好找到这个了。

    office.zip

    查看(310) 评论(2) 收藏 推荐

  • 获取Createobject参数 *

    2008-10-06 22:19:21

    不喜欢引用库，动态建立对象时参数很难写，请教ben写的Project收藏备用。

    '*************************************************
    Option Explicit

    '当我们在编写一些关于地址簿等等之类的保存人员信息的程序时，通常会有一个文本框要求用户输入电子邮件地址，
    '为了检查该地址的有效性，以往得编一大段代码，比如说地址中有没有@符号，有没有小数点，等等。
    '这种方法费时费力，还不一定有效，下面本文将向你介绍一个简单的方法来检查电子邮件地址的有效性。

    '首先到微软的网站去下载一个Windows scrīpt5.1的程序(中文版)，安装后会在Windows的系统目录中添加一些动态链接库，
    '其中一个我们将用到的是VBscrīpt.dll文件。重新启动计算机后就可以用了。
    '在VB工程中添加对Microsoft VBscrīpt Regular Expressions的引用，我们将用到其中的一个叫RegExp的对象。
    Private Sub Form_Activate()
        Text1.SetFocus
    End Sub

    Private Sub Text1_LostFocus()
        Dim objWscrīpt As Object
        Dim strQQPath As String
        Set ōbjWscrīpt = CreateObject("VBscrīpt.RegExp")&nb