Access使用VBA实现表或查询每相邻两行字段相减

为了实现如下的功能：表或查询每相邻两行字段相减。例如下面的这张表或查询，结果是成绩列的每两行相减。

姓名 学号 成绩
小王 001 240
大王 002 260
小王 001 280
大王 002 290
大王 002 260

思路如下：
1、先把表另存一份表1，加一个自增长的ID。
2、表1再另存一份表2。
3、表1和表2用“表1的ID=表2ID-1”来连接，就是相邻两行连接起来。
4、将上面的连接表成绩字段相减，再另存一份。
5、删除表1和表2.

Access使用VBA实现表或查询每相邻两行字段相减

为了实现如下的功能：表或查询每相邻两行字段相减。例如下面的这张表或查询，结果是成绩列的每两行相减。

姓名 学号 成绩
小王 001 240
大王 002 260
小王 001 280
大王 002 290
大王 002 260

思路如下：
1、先把表另存一份表1，加一个自增长的ID。
2、表1再另存一份表2。
3、表1和表2用“表1的ID=表2ID-1”来连接，就是相邻两行连接起来。
4、将上面的连接表成绩字段相减，再另存一份。
5、删除表1和表2.

使用VBA实现Vlookup实例

最近使用EXCEL处理数据，总是会用到2张表数据的查找匹配的功能，EXCEL提供了强大的Vlookup函数能很好的实现我需要的功能。但是函数在用起来有点麻烦，尤其是在2张表之间切换时很容易会点错参数，而且敲击代码对非程序员很不友好，于是就想找一个VBA窗体实现Vlookup的模板。可是在网上找了好久都没能找到，只能自己动手做一个出来了。

这个VBA实例很简单，也就是把Vlookup进行了改写，提供了用户输入界面的窗体。

先来看下Vlookup函数：VLOOKUP(lookup_value,table_array,col_index_num,range_lookup)

翻译过来就是VLOOKUP(查找关键字,查找的范围,返回列,模糊匹配)，需要把这些参数设置为变量，让用户输入即可。

1、 在EXCEL表1中添加一个按钮

2、点击按钮，显示VlookupForm输入窗口

3、输入数据（只需要输入第几列）就可以实现vlookup的功能了

下面简单介绍下代码。模块里面就是按钮单击事件，调用/显示VlookupForm窗口。

Sub VlookupSub()   VlookupForm.ShowEnd Sub

VlookupForm窗体的代码主要还是使用vlookup函数把输入的数据进行处理。

Private Sub CommandOK_Click()Dim RowStartDim RowEndDim ppRowStart = Val(TextStart.Text)RowEnd = Val(TextEnd.Text)For m = RowStart To RowEnd     pp = Application.VLookup(Cells(m, Val(TextKeyword.Text)), Sheets(TextSheet.Text).Range("a:z"), Val(TextReturn.Text), 0)     If Not Application.IsNA(pp) Then       Sheets("Sheet1").Cells(m, Val(TextInsert.Text)) = pp     Else       '查找不到匹配项，置为0，vlookup默认为N/A       Sheets("Sheet1").Cells(m, Val(TextInsert.Text)) = 0     End IfNext m    End SubPrivate Sub HideButton_Click()    VlookupForm.HideEnd Sub

整个的实例下载地址：使用VBA实现Vlookup实例.rar

使用VBA实现Vlookup实例

最近使用EXCEL处理数据，总是会用到2张表数据的查找匹配的功能，EXCEL提供了强大的Vlookup函数能很好的实现我需要的功能。但是函数在用起来有点麻烦，尤其是在2张表之间切换时很容易会点错参数，而且敲击代码对非程序员很不友好，于是就想找一个VBA窗体实现Vlookup的模板。可是在网上找了好久都没能找到，只能自己动手做一个出来了。

这个VBA实例很简单，也就是把Vlookup进行了改写，提供了用户输入界面的窗体。

先来看下Vlookup函数：VLOOKUP(lookup_value,table_array,col_index_num,range_lookup)

翻译过来就是VLOOKUP(查找关键字,查找的范围,返回列,模糊匹配)，需要把这些参数设置为变量，让用户输入即可。

1、 在EXCEL表1中添加一个按钮

2、点击按钮，显示VlookupForm输入窗口

3、输入数据（只需要输入第几列）就可以实现vlookup的功能了

下面简单介绍下代码。模块里面就是按钮单击事件，调用/显示VlookupForm窗口。

Sub VlookupSub()   VlookupForm.ShowEnd Sub

VlookupForm窗体的代码主要还是使用vlookup函数把输入的数据进行处理。

Private Sub CommandOK_Click()Dim RowStartDim RowEndDim ppRowStart = Val(TextStart.Text)RowEnd = Val(TextEnd.Text)For m = RowStart To RowEnd     pp = Application.VLookup(Cells(m, Val(TextKeyword.Text)), Sheets(TextSheet.Text).Range("a:z"), Val(TextReturn.Text), 0)     If Not Application.IsNA(pp) Then       Sheets("Sheet1").Cells(m, Val(TextInsert.Text)) = pp     Else       '查找不到匹配项，置为0，vlookup默认为N/A       Sheets("Sheet1").Cells(m, Val(TextInsert.Text)) = 0     End IfNext m    End SubPrivate Sub HideButton_Click()    VlookupForm.HideEnd Sub

整个的实例下载地址：使用VBA实现Vlookup实例.rar

防止文件被改写的简单实现方式

最近在写的一个小程序中有个配置文件，这个文件对整个程序来说是至关重要的，如果它被删除或者改写的话，整个程序无法运行，或者运行后无法关闭。所以我一直在寻找如果让手工无法改写文件的方法。

对于“删除”来说是很容易解决的，程序中查找配置文件的路径，若为空则创建，并给些默认值。VB的示例代码如下：

FileName = App.Path + "\CONFIG"
'如果文件不存在，则创建文件
If Dir(FileName) = "" Then
     Open FileName For Output As #1 '打开顺序文件，我们可以使用Open语句
     a = Encode("123") + vbCrLf + "10" + vbCrLf 'vbCrLf为回车
     Print #1, a '写数据
     Close #1 '关闭文件       
End If

对于手工改写配置文件，我一直无能为力，我试图在程序中把该文件隐藏掉。VB的示例代码如下：

SetAttr FileName, vbSystem Or vbHidden '隐藏文件

但终归来说是治标不治本，文件仍然会被改写的。然后我想到修改配置文件后缀法，让人手工没那么容易打开文件，但是总是有方法打开的。最终让我想到一个简单的解决方法是，在程序中先打开配置文件，之后手工就无法打开了。VB的示例代码如下：

Open FileName For Binary As #99

只是记得程序在改写该文件时要先关闭打开的文件，不然改写会失败的。VB的示例代码如下：

Close #99 '关闭文件

总结一下，防止文件被改写的简单实现方式就是在程序中先打开该文件。完整的程序示例可参考这里。

防止文件被改写的简单实现方式

最近在写的一个小程序中有个配置文件，这个文件对整个程序来说是至关重要的，如果它被删除或者改写的话，整个程序无法运行，或者运行后无法关闭。所以我一直在寻找如果让手工无法改写文件的方法。

对于“删除”来说是很容易解决的，程序中查找配置文件的路径，若为空则创建，并给些默认值。VB的示例代码如下：

FileName = App.Path + "\CONFIG"'如果文件不存在，则创建文件If Dir(FileName) = "" Then     Open FileName For Output As #1 '打开顺序文件，我们可以使用Open语句     a = Encode("123") + vbCrLf + "10" + vbCrLf 'vbCrLf为回车     Print #1, a '写数据     Close #1 '关闭文件       End If

对于手工改写配置文件，我一直无能为力，我试图在程序中把该文件隐藏掉。VB的示例代码如下：

SetAttr FileName, vbSystem Or vbHidden '隐藏文件

但终归来说是治标不治本，文件仍然会被改写的。然后我想到修改配置文件后缀法，让人手工没那么容易打开文件，但是总是有方法打开的。最终让我想到一个简单的解决方法是，在程序中先打开配置文件，之后手工就无法打开了。VB的示例代码如下：

Open FileName For Binary As #99

只是记得程序在改写该文件时要先关闭打开的文件，不然改写会失败的。VB的示例代码如下：

Close #99 '关闭文件

总结一下，防止文件被改写的简单实现方式就是在程序中先打开该文件。完整的程序示例可参考这里。

屏幕锁PcLocker更新

最近把以前写的一个小程序PClock做了一次更新，以前的程序是程序运行后系统界面锁定，需输入密码方能解锁。这次更新后的效果是，程序运行以后在后台监视空闲的时间（键盘和鼠标无动作），当空闲的时间等于设定时间时Windows系统界面锁定。

就是这么一个小功能的更新，花了我3天的时间，主要原因是走了不少的弯路。在差不多要放弃的时候让我找到了解决的方法。

程序的界面和功能没有太大的改变，以下是程序的ChangeLog：

1、程序的名称从PClock改为PcLocker

2、程序转为后台运行，当系统空闲时锁定Windows系统，类似于进入屏幕保护程序

3、改变了禁用任务管理器的方式

4、实现了手工无法修改配置文件

5、优化并精简了代码

6、程序适用于Windows XP、Windows 7，其他的系统没有测试

7、初始密码123，程序默认空闲启动时间为10分钟，默认随机自启动关闭

源程序的下载地址：点我

下面就是整个程序的源码，主要包括1个模块module1.bas，1个主程序窗口MainForm.frm，1个设置窗口setform.frm

主程序窗口MainForm.frm的代码如下，程序的主要功能集中在此。

'计算空闲时间
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function EnableWindow Lib "user32" (ByVal hWnd As Integer, ByVal aBOOL As Integer) As Integer
Private Declare Function IsWindowEnabled Lib "user32" (ByVal hWnd As Integer) As Integer
Private Declare Function GetMenu Lib "user32" (ByVal hWnd As Integer) As Integer
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long

'常量声明
Const SWP_NOMOVE = &H2    '保持当前位置（x和y设定将被忽略）
Const SWP_NOSIZE = &H1   '保持当前大小（cx和cy会被忽略）
Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const flags = SWP_NOMOVE Or SWP_NOSIZE

'使用GetLastInputInfo来检测键盘、鼠标无动作
Private Declare Function GetLastInputInfo Lib "user32" (plii As LASTINPUTINFO) As Boolean
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Type LASTINPUTINFO
    cbSize As Long
    dwTime As Long
End Type

Private Sub Form_Load()
    If App.PrevInstance = True Then
        '用APP对象的PrevInstance属性，防止同时运行屏幕保护程序的两个实例
        Unload Me
        Exit Sub
    End If
    
    Timer1.Interval = 1000
    '读取配置信息
    Call GetConfig
    '打开配置文件,防止手工修改
    FileName = App.Path + "\CONFIG"
    Open FileName For Binary As #99
End Sub

Private Sub BntOk_Click()
    If (Text1.Text = password) Then
         ' 卸载钩子
        UnhookWindowsHookEx lHook
    
        Timer1.Enabled = True
        Me.Visible = False
        Text1.Text = ""
        Timer2.Enabled = False
    Else
        Label2.Visible = True
        Label2.Caption = "输入密码不正确，请重新输入！"
        Text1.Text = ""
        Text1.SetFocus
    End If
End Sub

Private Sub BntEmpty_Click()
    Text1.Text = ""
End Sub

'显示主程序界面
Private Sub ShowForm()
    ' 安装钩子
    lHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf CallKeyHookProc, App.hInstance, 0)
    
    '如果更改的背景文件不存在，或者文件目录为空，则显示默认背景
    If (filedir <> "" And Dir(filedir) <> "") Then
        '开始的时候使用的是改变窗口的默认背景，这样的话这个背景不会被拉伸，只能保持默认大小，舍弃 Me.Picture = LoadPicture(filedir)
        '现在使用image控件来实现
        Image1.Width = Screen.Width
        Image1.Height = Screen.Height
        
        '这里把窗口设为全屏，因为image 要随着窗口变化
        Top = 0
        Left = 0
        Me.Width = Screen.Width
        Me.Height = Screen.Height
        
        Me.Image1.Visible = False
        Me.Image1.Picture = LoadPicture(filedir)
        Me.AutoRedraw = True
        Me.PaintPicture Image1.Picture, 0, 0, Me.ScaleWidth, Me.ScaleHeight
    End If
    
    Me.Show 'setFocus前面须有这个
    '设置窗口在最上面
    Dim Ok
    Ok = SetWindowPos(Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, flags)
    '设置全屏
    Top = 0
    Left = 0
    Me.Width = Screen.Width
    Me.Height = Screen.Height
    '设置输入框的位置
    Frame1.Top = Screen.Height - Frame1.Height
    Frame1.Left = Screen.Width - Frame1.Width
    Label2.Left = Frame1.Left
    Label2.Top = Frame1.Top - Label2.Height
    Label2.Width = Frame1.Width
    Label2.Visible = False
    Text1.SetFocus
    '禁用alt+ctrl+delete
    'Open Environ$("WinDir") & "\system32\taskmgr.exe" For Binary As #1
    Timer1.Enabled = False
    Timer2.Enabled = True
    Text1.SetFocus
End Sub
'设置窗口
Private Sub BntSet_Click()
    If (Text1.Text = password) Then
        ' 卸载钩子
        UnhookWindowsHookEx lHook
        Me.Visible = False
        Text1.Text = ""
        setform.Show
        Timer1.Enabled = True
    Else
        Label2.Visible = True
        Label2.Caption = "输入密码不正确，请重新输入！"
        Text1.Text = ""
        Text1.SetFocus
    End If
End Sub

'回车之后的动作
Private Sub Text1_KeyPress(KeyAscii As Integer)
    ' Text1 响应回车键
    If KeyAscii = 13 Then
        If (Text1.Text = password) Then
            ' 卸载钩子
            UnhookWindowsHookEx lHook
            Me.Visible = False
            Text1.Text = ""
            Timer1.Enabled = True
            Timer2.Enabled = False
        Else
            Label2.Visible = True
            Label2.Caption = "输入密码不正确，请重新输入！"
            Text1.Text = ""
            Text1.SetFocus
        End If
    End If
End Sub
'当空闲时间大于IntervalTime时，调用ShowForm
Private Sub Timer1_Timer()
    Dim lii As LASTINPUTINFO
    lii.cbSize = Len(lii)
    If GetLastInputInfo(lii) Then
        If (GetTickCount - lii.dwTime)/60000 > IntervalTime Then
            Call ShowForm
        End If
    End If
End Sub
'禁用任务管理器
Private Sub Timer2_Timer()
   Shell ("cmd /c taskkill /f /im taskmgr.exe"), vbHide
End Sub

设置窗口setform.frm的代码，包括密码设置、背景图片设置、开机自启动设置和空闲启动时间设置。

Dim change As Boolean
Private Sub Command1_Click()

    '先读出密码
    passwordstr = password
    FileName = App.Path + "\CONFIG" '配置文件路径
    '验证密码
    If Text1.Text = passwordstr And Text3.Text = Text2.Text Then
        NewPassword = Encode(Text2.Text)
        change = SetConfig(NewPassword, 0)
        '设置以后重新读取配置文件
        Call GetConfig
        If (change = True) Then MsgBox "口令修改成功"
    Else
    If Text2.Text <> Text3.Text Then
        MsgBox "两次口令输入不一致，请重新输入"
    Else
        MsgBox "旧口令错，请重新输入"
    End If
    End If
End Sub

Private Sub Command2_Click()
    Unload Me
End Sub


Private Sub Command3_Click()
    Set w = CreateObject("wscript.shell")
    w.regwrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName, App.Path & "\" & App.EXEName & ".exe"
    MsgBox "已经设置为开机自启动"
End Sub

Private Sub Command4_Click()
    Set w = CreateObject("wscript.shell")
    w.regdelete "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName
    MsgBox "已经取消开机自启动"
End Sub

Private Sub Command5_Click()
    
    CommonDialog1.Filter = "jpg|*.jpg"
    CommonDialog1.ShowOpen
    filedir = CommonDialog1.FileName
    If (filedir <> "") Then change = True
    
    change = SetConfig(filedir, 2)
    '设置以后重新读取配置文件
     Call GetConfig
    If (change = True) Then MsgBox "背景替换成功"
End Sub

Private Sub Command6_Click()
    change = SetConfig("", 2)
    '设置以后重新读取配置文件
    Call GetConfig
    If (change = True) Then MsgBox "已恢复为默认背景"
End Sub

Private Sub Command7_Click()
    Unload Me
End Sub

Private Sub IntervalBnt_Click()
    change = SetConfig(setform.IntervalTxt.Text, 1)
    '设置以后重新读取配置文件
    Call GetConfig
    If (change = True) Then MsgBox "修改成功"
End Sub

模块module1.bas代码，主要是禁用键盘和加密函数。

Option Explicit

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Public Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Public Const HC_ACTION = 0
Public Const WM_KEYDOWN = &H100
Public Const WM_KEYUP = &H101
Public Const WM_SYSKEYDOWN = &H104
Public Const WM_SYSKEYUP = &H105
Public Const VK_TAB = &H9
Public Const VK_CONTROL = &H11
Public Const VK_ESCAPE = &H1B
Public Const VK_DELETE = &H2E
Public Const WH_KEYBOARD_LL = 13
Public Const LLKHF_ALTDOWN = &H20

'禁用键盘的功能键
Public Type KBDLLHOOKSTRUCT
    vkCode As Long
    scanCode As Long
    flags As Long
    time As Long
    dwExtraInfo As Long
End Type
Public lHook As Long
Dim p As KBDLLHOOKSTRUCT
Dim key()     As Byte
'全局变量
Public password As String
Public IntervalTime As Integer
Public filedir As String
Public FileName As String

'键盘钩子
Public Function CallKeyHookProc(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim fEatKeystroke As Boolean
    
    If (ncode = HC_ACTION) Then
        If wParam = WM_KEYDOWN Or wParam = WM_SYSKEYDOWN Or wParam = WM_KEYUP Or wParam = WM_SYSKEYUP Then
            CopyMemory p, ByVal lParam, Len(p)
            fEatKeystroke = _
            ((p.vkCode = VK_TAB) And ((p.flags And LLKHF_ALTDOWN) <> 0)) Or _
            ((p.vkCode = VK_ESCAPE) And ((p.flags And LLKHF_ALTDOWN) <> 0)) Or _
            ((p.flags And LLKHF_ALTDOWN) <> 0) Or _
            ((p.vkCode = VK_ESCAPE) And ((GetKeyState(VK_CONTROL) And &H8000) <> 0)) Or _
            ((p.vkCode = 91) Or (p.vkCode = VK_ESCAPE) Or (p.vkCode = 92) Or (p.vkCode = 93))
            '判断是否按下了：TAB+ALT、Esc+ALT、Alt(Alt+F4)、Esc+Ctrl、左右 Win 和徽标键\Esc
        End If
    End If
    
    If fEatKeystroke Then
        ' 设置为 1 可以屏蔽按键
        CallKeyHookProc = 1
    Else
        CallKeyHookProc = CallNextHookEx(0, ncode, wParam, ByVal lParam)
    End If
End Function

Sub initkey()       '这里为密匙，建议定义的复杂些，我这里仅仅是个示例
          ReDim key(9)
          key(0) = 12
          key(1) = 43
          key(2) = 53
          key(3) = 67
          key(4) = 78
          key(5) = 82
          key(6) = 91
          key(7) = 245
          key(8) = 218
          key(9) = 190
  End Sub
    
 Function Encode(ByVal s As String) As String                 '加密
          On Error GoTo myerr
          initkey
          Dim buff()     As Byte
          buff = StrConv(s, vbFromUnicode)
          Dim i     As Long, j       As Long
          Dim k     As Long
          k = UBound(key) + 1
          For i = 0 To UBound(buff)
                  j = i Mod k
                  buff(i) = buff(i) Xor key(j)
          Next
          Dim mstr     As String
          mstr = "abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
          Dim outstr     As String
          Dim temps     As String
          For i = 0 To UBound(buff)
                  k = buff(i) \ Len(mstr)
                  j = buff(i) Mod Len(mstr)
                  temps = Mid(mstr, j + 1, 1) + Mid(mstr, k + 1, 1)
                  outstr = outstr + temps
          Next
          Encode = outstr
          Exit Function
myerr:
          Encode = ""
  End Function
 Function Decode(ByVal s As String) As String                 '解密
          On Error GoTo myerr
          initkey
          Dim i     As Long, j       As Long
          Dim k     As Long, n       As Long
          Dim mstr     As String
          mstr = "abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
          Dim outstr     As String
          Dim temps     As String
          If Len(s) Mod 2 = 1 Then
                  Decode = ""
                  Exit Function
          End If
          Dim t1     As String
          Dim t2     As String
          Dim buff()     As Byte
          Dim m     As Long
          m = 0
          For i = 1 To Len(s) Step 2
                  t1 = Mid(s, i, 1)
                  t2 = Mid(s, i + 1, 1)
                  j = InStr(1, mstr, t1)
                  k = InStr(1, mstr, t2)
                  n = j - 1 + (k - 1) * Len(mstr)
                  ReDim Preserve buff(m)
                  buff(m) = n
                  m = m + 1
          Next
          k = UBound(key) + 1
          For i = 0 To UBound(buff)
                  j = i Mod k
                  buff(i) = buff(i) Xor key(j)
          Next
          Decode = StrConv(buff, vbUnicode)
          Exit Function
myerr:
          Decode = ""
End Function

'配置信息
'定义变量，password密码，IntervalTime空闲时间


Function GetConfig()
    Dim s As String, t() As String, a As String
    FileName = App.Path + "\CONFIG"
    '如果文件不存在，则创建文件
    If Dir(FileName) = "" Then
       Open FileName For Output As #1 '打开顺序文件，我们可以使用Open语句
       a = Encode("123") + vbCrLf + "10" + vbCrLf 'vbCrLf为回车
       Print #1, a '写数据
       Close #1 '关闭文件
       '隐藏文件
       'SetAttr FileName, vbSystem Or vbHidden
    End If
    Open FileName For Binary As #11
    s = Input(LOF(11), #11)
    Close #11
    t = Split(s, vbCrLf)
    password = Decode(t(0))
    IntervalTime = t(1) '第三行是2，第四行是3，类推
    filedir = t(2)
End Function

Function SetConfig(ByVal Value As String, ByVal Weizhi As Integer) As Boolean
    Close #99 '关闭打开的配置文件
    FileName = App.Path + "\CONFIG"
    Dim s As String, t() As String
    Open FileName For Binary As #123
    s = Input(LOF(123), #123)
    Close #123
    t = Split(s, vbCrLf)
    t(Weizhi) = Value  '第三行是2，第四行是3，类推
    s = Join(t, vbCrLf)
    Kill FileName
    Open FileName For Binary As #11
    Put #11, , s
    Close #11
    SetConfig = True
    Open FileName For Binary As #99 '打开配置文件,防止手工修改
End Function

屏幕锁PcLocker更新

最近把以前写的一个小程序PClock做了一次更新，以前的程序是程序运行后系统界面锁定，需输入密码方能解锁。这次更新后的效果是，程序运行以后在后台监视空闲的时间（键盘和鼠标无动作），当空闲的时间等于设定时间时Windows系统界面锁定。

就是这么一个小功能的更新，花了我3天的时间，主要原因是走了不少的弯路。在差不多要放弃的时候让我找到了解决的方法。

程序的界面和功能没有太大的改变，以下是程序的ChangeLog：

1、程序的名称从PClock改为PcLocker

2、程序转为后台运行，当系统空闲时锁定Windows系统，类似于进入屏幕保护程序

3、改变了禁用任务管理器的方式

4、实现了手工无法修改配置文件

5、优化并精简了代码

6、程序适用于Windows XP、Windows 7，其他的系统没有测试

7、初始密码123，程序默认空闲启动时间为10分钟，默认随机自启动关闭

源程序的下载地址：点我

下面就是整个程序的源码，主要包括1个模块module1.bas，1个主程序窗口MainForm.frm，1个设置窗口setform.frm

主程序窗口MainForm.frm的代码如下，程序的主要功能集中在此。

'计算空闲时间Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As LongPrivate Declare Function EnableWindow Lib "user32" (ByVal hWnd As Integer, ByVal aBOOL As Integer) As IntegerPrivate Declare Function IsWindowEnabled Lib "user32" (ByVal hWnd As Integer) As IntegerPrivate Declare Function GetMenu Lib "user32" (ByVal hWnd As Integer) As IntegerPrivate Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPrivate Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long'常量声明Const SWP_NOMOVE = &H2    '保持当前位置（x和y设定将被忽略）Const SWP_NOSIZE = &H1   '保持当前大小（cx和cy会被忽略）Const HWND_TOPMOST = -1Const HWND_NOTOPMOST = -2Const flags = SWP_NOMOVE Or SWP_NOSIZE'使用GetLastInputInfo来检测键盘、鼠标无动作Private Declare Function GetLastInputInfo Lib "user32" (plii As LASTINPUTINFO) As BooleanPrivate Declare Function GetTickCount Lib "kernel32" () As LongPrivate Type LASTINPUTINFO    cbSize As Long    dwTime As LongEnd TypePrivate Sub Form_Load()    If App.PrevInstance = True Then        '用APP对象的PrevInstance属性，防止同时运行屏幕保护程序的两个实例        Unload Me        Exit Sub    End If        Timer1.Interval = 1000    '读取配置信息    Call GetConfig    '打开配置文件,防止手工修改    FileName = App.Path + "\CONFIG"    Open FileName For Binary As #99End SubPrivate Sub BntOk_Click()    If (Text1.Text = password) Then         ' 卸载钩子        UnhookWindowsHookEx lHook            Timer1.Enabled = True        Me.Visible = False        Text1.Text = ""        Timer2.Enabled = False    Else        Label2.Visible = True        Label2.Caption = "输入密码不正确，请重新输入！"        Text1.Text = ""        Text1.SetFocus    End IfEnd SubPrivate Sub BntEmpty_Click()    Text1.Text = ""End Sub'显示主程序界面Private Sub ShowForm()    ' 安装钩子    lHook = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf CallKeyHookProc, App.hInstance, 0)        '如果更改的背景文件不存在，或者文件目录为空，则显示默认背景    If (filedir <> "" And Dir(filedir) <> "") Then        '开始的时候使用的是改变窗口的默认背景，这样的话这个背景不会被拉伸，只能保持默认大小，舍弃 Me.Picture = LoadPicture(filedir)        '现在使用image控件来实现        Image1.Width = Screen.Width        Image1.Height = Screen.Height                '这里把窗口设为全屏，因为image 要随着窗口变化        Top = 0        Left = 0        Me.Width = Screen.Width        Me.Height = Screen.Height                Me.Image1.Visible = False        Me.Image1.Picture = LoadPicture(filedir)        Me.AutoRedraw = True        Me.PaintPicture Image1.Picture, 0, 0, Me.ScaleWidth, Me.ScaleHeight    End If        Me.Show 'setFocus前面须有这个    '设置窗口在最上面    Dim Ok    Ok = SetWindowPos(Me.hWnd, HWND_TOPMOST, 0, 0, 0, 0, flags)    '设置全屏    Top = 0    Left = 0    Me.Width = Screen.Width    Me.Height = Screen.Height    '设置输入框的位置    Frame1.Top = Screen.Height - Frame1.Height    Frame1.Left = Screen.Width - Frame1.Width    Label2.Left = Frame1.Left    Label2.Top = Frame1.Top - Label2.Height    Label2.Width = Frame1.Width    Label2.Visible = False    Text1.SetFocus    '禁用alt+ctrl+delete    'Open Environ$("WinDir") & "\system32\taskmgr.exe" For Binary As #1    Timer1.Enabled = False    Timer2.Enabled = True    Text1.SetFocusEnd Sub'设置窗口Private Sub BntSet_Click()    If (Text1.Text = password) Then        ' 卸载钩子        UnhookWindowsHookEx lHook        Me.Visible = False        Text1.Text = ""        setform.Show        Timer1.Enabled = True    Else        Label2.Visible = True        Label2.Caption = "输入密码不正确，请重新输入！"        Text1.Text = ""        Text1.SetFocus    End IfEnd Sub'回车之后的动作Private Sub Text1_KeyPress(KeyAscii As Integer)    ' Text1 响应回车键    If KeyAscii = 13 Then        If (Text1.Text = password) Then            ' 卸载钩子            UnhookWindowsHookEx lHook            Me.Visible = False            Text1.Text = ""            Timer1.Enabled = True            Timer2.Enabled = False        Else            Label2.Visible = True            Label2.Caption = "输入密码不正确，请重新输入！"            Text1.Text = ""            Text1.SetFocus        End If    End IfEnd Sub'当空闲时间大于IntervalTime时，调用ShowFormPrivate Sub Timer1_Timer()    Dim lii As LASTINPUTINFO    lii.cbSize = Len(lii)    If GetLastInputInfo(lii) Then        If (GetTickCount - lii.dwTime)/60000 > IntervalTime Then            Call ShowForm        End If    End IfEnd Sub'禁用任务管理器Private Sub Timer2_Timer()   Shell ("cmd /c taskkill /f /im taskmgr.exe"), vbHideEnd Sub

设置窗口setform.frm的代码，包括密码设置、背景图片设置、开机自启动设置和空闲启动时间设置。

Dim change As BooleanPrivate Sub Command1_Click()    '先读出密码    passwordstr = password    FileName = App.Path + "\CONFIG" '配置文件路径    '验证密码    If Text1.Text = passwordstr And Text3.Text = Text2.Text Then        NewPassword = Encode(Text2.Text)        change = SetConfig(NewPassword, 0)        '设置以后重新读取配置文件        Call GetConfig        If (change = True) Then MsgBox "口令修改成功"    Else    If Text2.Text <> Text3.Text Then        MsgBox "两次口令输入不一致，请重新输入"    Else        MsgBox "旧口令错，请重新输入"    End If    End IfEnd SubPrivate Sub Command2_Click()    Unload MeEnd SubPrivate Sub Command3_Click()    Set w = CreateObject("wscript.shell")    w.regwrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName, App.Path & "\" & App.EXEName & ".exe"    MsgBox "已经设置为开机自启动"End SubPrivate Sub Command4_Click()    Set w = CreateObject("wscript.shell")    w.regdelete "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName    MsgBox "已经取消开机自启动"End SubPrivate Sub Command5_Click()        CommonDialog1.Filter = "jpg|*.jpg"    CommonDialog1.ShowOpen    filedir = CommonDialog1.FileName    If (filedir <> "") Then change = True        change = SetConfig(filedir, 2)    '设置以后重新读取配置文件     Call GetConfig    If (change = True) Then MsgBox "背景替换成功"End SubPrivate Sub Command6_Click()    change = SetConfig("", 2)    '设置以后重新读取配置文件    Call GetConfig    If (change = True) Then MsgBox "已恢复为默认背景"End SubPrivate Sub Command7_Click()    Unload MeEnd SubPrivate Sub IntervalBnt_Click()    change = SetConfig(setform.IntervalTxt.Text, 1)    '设置以后重新读取配置文件    Call GetConfig    If (change = True) Then MsgBox "修改成功"End Sub

模块module1.bas代码，主要是禁用键盘和加密函数。

Option ExplicitPublic Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As IntegerPublic Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As LongPublic Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal ncode As Long, ByVal wParam As Long, lParam As Any) As LongPublic Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As LongPublic Const HC_ACTION = 0Public Const WM_KEYDOWN = &H100Public Const WM_KEYUP = &H101Public Const WM_SYSKEYDOWN = &H104Public Const WM_SYSKEYUP = &H105Public Const VK_TAB = &H9Public Const VK_CONTROL = &H11Public Const VK_ESCAPE = &H1BPublic Const VK_DELETE = &H2EPublic Const WH_KEYBOARD_LL = 13Public Const LLKHF_ALTDOWN = &H20'禁用键盘的功能键Public Type KBDLLHOOKSTRUCT    vkCode As Long    scanCode As Long    flags As Long    time As Long    dwExtraInfo As LongEnd TypePublic lHook As LongDim p As KBDLLHOOKSTRUCTDim key()     As Byte'全局变量Public password As StringPublic IntervalTime As IntegerPublic filedir As StringPublic FileName As String'键盘钩子Public Function CallKeyHookProc(ByVal ncode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long    Dim fEatKeystroke As Boolean        If (ncode = HC_ACTION) Then        If wParam = WM_KEYDOWN Or wParam = WM_SYSKEYDOWN Or wParam = WM_KEYUP Or wParam = WM_SYSKEYUP Then            CopyMemory p, ByVal lParam, Len(p)            fEatKeystroke = _            ((p.vkCode = VK_TAB) And ((p.flags And LLKHF_ALTDOWN) <> 0)) Or _            ((p.vkCode = VK_ESCAPE) And ((p.flags And LLKHF_ALTDOWN) <> 0)) Or _            ((p.flags And LLKHF_ALTDOWN) <> 0) Or _            ((p.vkCode = VK_ESCAPE) And ((GetKeyState(VK_CONTROL) And &H8000) <> 0)) Or _            ((p.vkCode = 91) Or (p.vkCode = VK_ESCAPE) Or (p.vkCode = 92) Or (p.vkCode = 93))            '判断是否按下了：TAB+ALT、Esc+ALT、Alt(Alt+F4)、Esc+Ctrl、左右 Win 和徽标键\Esc        End If    End If        If fEatKeystroke Then        ' 设置为 1 可以屏蔽按键        CallKeyHookProc = 1    Else        CallKeyHookProc = CallNextHookEx(0, ncode, wParam, ByVal lParam)    End IfEnd FunctionSub initkey()       '这里为密匙，建议定义的复杂些，我这里仅仅是个示例          ReDim key(9)          key(0) = 12          key(1) = 43          key(2) = 53          key(3) = 67          key(4) = 78          key(5) = 82          key(6) = 91          key(7) = 245          key(8) = 218          key(9) = 190  End Sub     Function Encode(ByVal s As String) As String                 '加密          On Error GoTo myerr          initkey          Dim buff()     As Byte          buff = StrConv(s, vbFromUnicode)          Dim i     As Long, j       As Long          Dim k     As Long          k = UBound(key) + 1          For i = 0 To UBound(buff)                  j = i Mod k                  buff(i) = buff(i) Xor key(j)          Next          Dim mstr     As String          mstr = "abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"          Dim outstr     As String          Dim temps     As String          For i = 0 To UBound(buff)                  k = buff(i) \ Len(mstr)                  j = buff(i) Mod Len(mstr)                  temps = Mid(mstr, j + 1, 1) + Mid(mstr, k + 1, 1)                  outstr = outstr + temps          Next          Encode = outstr          Exit Functionmyerr:          Encode = ""  End Function Function Decode(ByVal s As String) As String                 '解密          On Error GoTo myerr          initkey          Dim i     As Long, j       As Long          Dim k     As Long, n       As Long          Dim mstr     As String          mstr = "abcdefghijklmnopqrstuvwxyz0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"          Dim outstr     As String          Dim temps     As String          If Len(s) Mod 2 = 1 Then                  Decode = ""                  Exit Function          End If          Dim t1     As String          Dim t2     As String          Dim buff()     As Byte          Dim m     As Long          m = 0          For i = 1 To Len(s) Step 2                  t1 = Mid(s, i, 1)                  t2 = Mid(s, i + 1, 1)                  j = InStr(1, mstr, t1)                  k = InStr(1, mstr, t2)                  n = j - 1 + (k - 1) * Len(mstr)                  ReDim Preserve buff(m)                  buff(m) = n                  m = m + 1          Next          k = UBound(key) + 1          For i = 0 To UBound(buff)                  j = i Mod k                  buff(i) = buff(i) Xor key(j)          Next          Decode = StrConv(buff, vbUnicode)          Exit Functionmyerr:          Decode = ""End Function'配置信息'定义变量，password密码，IntervalTime空闲时间Function GetConfig()    Dim s As String, t() As String, a As String    FileName = App.Path + "\CONFIG"    '如果文件不存在，则创建文件    If Dir(FileName) = "" Then       Open FileName For Output As #1 '打开顺序文件，我们可以使用Open语句       a = Encode("123") + vbCrLf + "10" + vbCrLf 'vbCrLf为回车       Print #1, a '写数据       Close #1 '关闭文件       '隐藏文件       'SetAttr FileName, vbSystem Or vbHidden    End If    Open FileName For Binary As #11    s = Input(LOF(11), #11)    Close #11    t = Split(s, vbCrLf)    password = Decode(t(0))    IntervalTime = t(1) '第三行是2，第四行是3，类推    filedir = t(2)End FunctionFunction SetConfig(ByVal Value As String, ByVal Weizhi As Integer) As Boolean    Close #99 '关闭打开的配置文件    FileName = App.Path + "\CONFIG"    Dim s As String, t() As String    Open FileName For Binary As #123    s = Input(LOF(123), #123)    Close #123    t = Split(s, vbCrLf)    t(Weizhi) = Value  '第三行是2，第四行是3，类推    s = Join(t, vbCrLf)    Kill FileName    Open FileName For Binary As #11    Put #11, , s    Close #11    SetConfig = True    Open FileName For Binary As #99 '打开配置文件,防止手工修改End Function

VB禁用Ctrl-Alt-Delete/任务管理器的方法

在Windows XP下禁用Ctrl-Alt-Delete的方法比较简单，因为Ctrl-Alt-Delete组合键的功能就是调用任务管理器，直接把任务管理器给禁用了，Ctrl-Alt-Delete的功能也就没有了，相当于也给禁用了。这个方法的简单的实现是用二进制 stream 形式先打开 C:\windows\system32\taskmgr.exe任务管理器程序，使后续无法手工正常打开任务管理器。代码如下：

Open "C:\WINDOWS\system32\taskmgr.exe" For Binary As #1

这种方法在XP上是可行的，但是在VISTA和WIN7上是无效的。我的解决方法是用taskkill命令来结束任务管理器程序taskmgr.exe。代码如下：

Shell ("cmd /c taskkill /f /im taskmgr.exe"), vbHide

在VB程序里实现的话，最好把上述语句放到Timer事件中，每隔一段时间执行一次，就能实现禁用任务管理器的目的了。代码如下：

Private Sub Timer1_timer()
Shell ("cmd /c taskkill /f /im taskmgr.exe"), vbHide
End Sub

VB禁用Ctrl-Alt-Delete/任务管理器的方法

在Windows XP下禁用Ctrl-Alt-Delete的方法比较简单，因为Ctrl-Alt-Delete组合键的功能就是调用任务管理器，直接把任务管理器给禁用了，Ctrl-Alt-Delete的功能也就没有了，相当于也给禁用了。这个方法的简单的实现是用二进制 stream 形式先打开 C:\windows\system32\taskmgr.exe任务管理器程序，使后续无法手工正常打开任务管理器。代码如下：

Open "C:\WINDOWS\system32\taskmgr.exe" For Binary As #1

这种方法在XP上是可行的，但是在VISTA和WIN7上是无效的。我的解决方法是用taskkill命令来结束任务管理器程序taskmgr.exe。代码如下：

Shell ("cmd /c taskkill /f /im taskmgr.exe"), vbHide

在VB程序里实现的话，最好把上述语句放到Timer事件中，每隔一段时间执行一次，就能实现禁用任务管理器的目的了。代码如下：

Private Sub Timer1_timer()    Shell ("cmd /c taskkill /f /im taskmgr.exe"), vbHideEnd Sub

VB键盘鼠标无动作调用程序的尝试

我想要实现的功能是，当键盘无输入、鼠标无移动或点击动作时调用程序。首先想到的是用钩子HOOK来获取键盘或者鼠标的动作，如果无动作时调用程序。我尝试的结果是HOOK来HOOK去总是有问题。

后来想到Windows的屏幕保护程序就是当键盘鼠标无动作时进入屏幕保护的，于是改变思路，想把程序做成这样的形式，键盘鼠标无动作，系统进入屏幕保护，然后检测系统是否运行屏幕保护程序，如果运行的话则调用程序。这种方式就是以屏幕保护程序作为中介，把检测键盘鼠标动作的工作交给屏幕保护程序来完成了。SystemParametersInfo可以实现获取屏幕保护信息的函数。参考代码如下：

'API调用与常用定义：
Private Declare Function SystemParametersInfo _
    Lib "user32" _
    Alias "SystemParametersInfoA" _
      (ByVal uiAction As Long, _
       ByVal uiParam As Long, _
       pvParam As Any, _
       ByVal fWInIni As Long) As Boolean

Private Const SPI_GETSCREENSAVEACTIVE As Long = &H10   '屏保是否启用的常量
Private Const SPI_GETSCREENSAVERRUNNING As Long = &H72 '屏保是否运行的常量

Private Sub Timer1_Timer()
    Dim bRunning As Boolean     '屏保是否运行的变量,当然你可以定义全局变量
    SystemParametersInfo SPI_GETSCREENSAVERRUNNING, 0, bRunning, False '调用API,bRunning返回屏保运行状态
    Debug.Print Time; "屏保运行="; bRunning '演示:打印屏保是否运行的信息
End Sub

'另外,查看屏保是否启用,也可以用下面方法:
SystemParametersInfo SPI_GETSCREENSAVEACTIVE, 0, bActive, False 'bActive为返回值(逻辑型)

可是不知道为什么我在WIN7下调试还是有问题，提示SystemParametersInfo SPI_GETSCREENSAVERRUNNING, 0, bRunning, False
中的bRunning类型错误，只能作罢。

最后来说一下最终实现的方案是使用GetLastInputInfo函数获取系统的空闲时间，参考代码如下：

Option Explicit
Private Declare Function GetLastInputInfo Lib "user32" (plii As LASTINPUTINFO) As Boolean
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Type LASTINPUTINFO
    cbSize As Long
    dwTime As Long
End Type

Private Sub Form_Load()
     Timer1.Interval = 1000    
End Sub

Private Sub Timer1_Timer()
    Dim lii As LASTINPUTINFO
    lii.cbSize = Len(lii)
    If GetLastInputInfo(lii) Then
        If (GetTickCount - lii.dwTime) / 60000 >= 15 Then            
            Call MsgBox("由于本机15分钟没有操作，如果3分钟后没有反应，系统将强制关机", vbYesNo + vbExclamation + vbDefaultButton2, "提示")
        End If
    End If
End Sub

VB键盘鼠标无动作调用程序的尝试

我想要实现的功能是，当键盘无输入、鼠标无移动或点击动作时调用程序。首先想到的是用钩子HOOK来获取键盘或者鼠标的动作，如果无动作时调用程序。我尝试的结果是HOOK来HOOK去总是有问题。

后来想到Windows的屏幕保护程序就是当键盘鼠标无动作时进入屏幕保护的，于是改变思路，想把程序做成这样的形式，键盘鼠标无动作，系统进入屏幕保护，然后检测系统是否运行屏幕保护程序，如果运行的话则调用程序。这种方式就是以屏幕保护程序作为中介，把检测键盘鼠标动作的工作交给屏幕保护程序来完成了。SystemParametersInfo可以实现获取屏幕保护信息的函数。参考代码如下：

'API调用与常用定义：Private Declare Function SystemParametersInfo _    Lib "user32" _    Alias "SystemParametersInfoA" _      (ByVal uiAction As Long, _       ByVal uiParam As Long, _       pvParam As Any, _       ByVal fWInIni As Long) As BooleanPrivate Const SPI_GETSCREENSAVEACTIVE As Long = &H10   '屏保是否启用的常量Private Const SPI_GETSCREENSAVERRUNNING As Long = &H72 '屏保是否运行的常量Private Sub Timer1_Timer()    Dim bRunning As Boolean     '屏保是否运行的变量,当然你可以定义全局变量    SystemParametersInfo SPI_GETSCREENSAVERRUNNING, 0, bRunning, False '调用API,bRunning返回屏保运行状态    Debug.Print Time; "屏保运行="; bRunning '演示:打印屏保是否运行的信息End Sub'另外,查看屏保是否启用,也可以用下面方法:SystemParametersInfo SPI_GETSCREENSAVEACTIVE, 0, bActive, False 'bActive为返回值(逻辑型)

可是不知道为什么我在WIN7下调试还是有问题，提示SystemParametersInfo SPI_GETSCREENSAVERRUNNING, 0, bRunning, False
中的bRunning类型错误，只能作罢。

最后来说一下最终实现的方案是使用GetLastInputInfo函数获取系统的空闲时间，参考代码如下：

Option ExplicitPrivate Declare Function GetLastInputInfo Lib "user32" (plii As LASTINPUTINFO) As BooleanPrivate Declare Function GetTickCount Lib "kernel32" () As LongPrivate Type LASTINPUTINFO    cbSize As Long    dwTime As LongEnd TypePrivate Sub Form_Load()     Timer1.Interval = 1000    End SubPrivate Sub Timer1_Timer()    Dim lii As LASTINPUTINFO    lii.cbSize = Len(lii)    If GetLastInputInfo(lii) Then        If (GetTickCount - lii.dwTime) / 60000 >= 15 Then                        Call MsgBox("由于本机15分钟没有操作，如果3分钟后没有反应，系统将强制关机", vbYesNo + vbExclamation + vbDefaultButton2, "提示")        End If    End IfEnd Sub

ACCESS使用VBA实现列值累加并取得累加阀值的记录

题目很拗口，主要是想要表达的东西比较曲折，还是以实例来说明比较直观，假设在Access中有以下的表table1。table1是一张成绩表，我想要的结果是：所有人的成绩按着总分（Score）从大到小排列，然后在排列好的表中从上到下累加English/Score列（第1行+第2行+……+第N行的值），当累加值>0.7时，取出第1行到第N行的记录。

ACCESS使用VBA实现列值累加并取得累加阀值的记录

题目很拗口，主要是想要表达的东西比较曲折，还是以实例来说明比较直观，假设在Access中有以下的表table1。table1是一张成绩表，我想要的结果是：所有人的成绩按着总分（Score）从大到小排列，然后在排列好的表中从上到下累加English/Score列（第1行+第2行+……+第N行的值），当累加值>0.7时，取出第1行到第N行的记录。

VB使用ADO操作Access数据库简单实例

这里只是个简单不能再简单的VB小程序实例，但它包含这几个关键字：VB6.0、ADO、Access

环境：visual basic 6.0 企业版（非精简版，不然会缺少必须的控件）

数据库：Access数据库，数据库是xs.mbd，内建表为xj

结果：vb使用ADO连接access数据库，查询xj表中的所有数据，然后把查询到的结果循环输出到窗口中。

代码：

Private Sub Form_Click()
Dim db As New ADODB.Connection, RS As New ADODB.Recordset 'ADO连接对象和记录集
Dim strSQL As String 'SQL字符串
db.ConnectionString = "provider=Microsoft.Jet.OLEDB.4.0;Data source =" & App.Path & "/xs.mdb" '数据库连接
db.Open '打开数据库

strSQL = "select * from xj" 'SQL字符串
RS.Open strSQL, db, 3, 1 '查询数据表
Do While Not RS.EOF '循环输出查询到的结果
Print RS!姓名; RS!性别; RS!班级; RS!出生年月 '在窗口中打印输出结果
RS.MoveNext '记录下移
Loop
RS.Close '关闭记录集
Set RS = Nothing
End Sub

源代码下载地址：vb_ado_access.zip

VB使用ADO操作Access数据库简单实例

这里只是个简单不能再简单的VB小程序实例，但它包含这几个关键字：VB6.0、ADO、Access

环境：visual basic 6.0 企业版（非精简版，不然会缺少必须的控件）

数据库：Access数据库，数据库是xs.mbd，内建表为xj

结果：vb使用ADO连接access数据库，查询xj表中的所有数据，然后把查询到的结果循环输出到窗口中。

代码：

Private Sub Form_Click()Dim db As New ADODB.Connection, RS As New ADODB.Recordset 'ADO连接对象和记录集Dim strSQL As String 'SQL字符串db.ConnectionString = "provider=Microsoft.Jet.OLEDB.4.0;Data source =" & App.Path & "/xs.mdb" '数据库连接db.Open '打开数据库strSQL = "select * from xj" 'SQL字符串RS.Open strSQL, db, 3, 1 '查询数据表Do While Not RS.EOF '循环输出查询到的结果Print RS!姓名; RS!性别; RS!班级; RS!出生年月 '在窗口中打印输出结果RS.MoveNext '记录下移LoopRS.Close '关闭记录集Set RS = NothingEnd Sub

源代码下载地址：vb_ado_access.zip

质数，合数，分解质因数等相关概念

好多VB教材中会用质数，合数等作例子来讲解知识，现在来总结一下它们的主要概念。

质数：也叫做素数，除了1和它本身，不能被其它数整除的正整数。也就是说，只能分解成1和它本身相乘。比如：2、3、5、7、9……

合数：除了1和它本身，可以被其它数整除的正整数。比如：4、6、8、10……

1既不是质数也不是合数。 每个合数都可以分解成几个质数相乘的形式。

质因数（质因子）：能整除给定正整数的质数。

正整数的因数分解（分解质因数）：將正整数表示为一连串的质因子相乘。

短除法分解质因数的方法：

①用能整除这个数的最小质数去除

②商是合数，继续除下去

③商是质数，把各个除数和商写成连乘的形式

例子：分解质因数24

用能整除这个数的最小质数去除24：24/2=12

商是12，为合数，继续除：12/2=6

商是6，为合数，继续除：6/2=3

商是3，为质数，结束。12=2*2*2*3

VB程序

Public Function decprime(k As Integer) As Boolean
           Dim i As Integer
           i = 2 '用最小质数2去除
           While k > 1
                 If k Mod i = 0 Then '如果可以整除，则i为所求的质因子
                       Print i
                       k = k / i '求得商
                 Else
                       i = i + 1
                End If
           Wend
End Function

电脑屏幕锁PClock

有些时候接个电话或者有急事处理需要离开电脑，此时不想关闭电脑或者没有时间，再或者想出门让电脑自己运行下载资料，同时不想别人动自己的电脑，这时候我们需要一个可以让电脑运行，但不能被操作的简单软件。于是，我花了两天的时间写了一个很小的程序软件来实现这个功能。

软件主要功能:

1. 在您离开座位时迅速锁定电脑桌面，阻止他人未经您的许可使用您的电脑。


2. 可个性化打造您中意的锁屏界面，设置界面可让您插入图片(照片等)，更改背景。


3. 可随时修改您的登陆密码;密码加密,保证您电脑的安全。


4. 软件可设置是否随系统启动。


5. 当他人使用\"Ctrl+Alt+Del\",\"Win\"或\"Ctrl+Esc\"等功能键要强行进入电脑时,软件将屏蔽所有键盘按键。

软件的主界面

这个就是程序运行起来的主要界面，通过输入密码，点击确定进入系统。输入密码，点击设置，进入系统并设置。




设置界面

设置界面可以修改密码，更换背景，设置开机启动等。



下面是整个程序的安装文件和源文件。值得说明的是，程序做好后应该使用专业的程序打包软件来进行打包。Setup Factory是个非常不错的程序打包制作工具。对于VB程序来说，主要的步骤是：a.新建工程，根据向导填入信息。b.工具->扫描visual basic工程，添加vb程序的路径，它会自动添加需要的文件。自己再把vb生成的exe文件添加进去即可。 （程序安装完毕，记住初始密码是123，再运行。）

下载地址