CBM666提供的vb代码

1.CBM666 的枚举运行中的网页并干掉它

http://hi.baidu.com/cbm666/blog/item/2723513d377da5ed3c6d97a3.html

2007年12月18日 星期二 16:21'工程中引用Microsoft Internet Controls
'添加 Command1

Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public mDocument As Object
Const WM_CLOSE = &H10
Dim phwnd&, rtn&

Private Sub Command1_Click()
   Me.Cls
   Call mComGetIEWindows
End Sub

Public Sub mComGetIEWindows()
   Dim mShellWindow As New SHDocVw.ShellWindows
   Dim mIndex As Long
   For mIndex = 0 To mShellWindow.Count - 1
      If VBA.TypeName(mShellWindow.Item(mIndex).Document) = "HTMLDocument" Then
         Print mShellWindow.Item(mIndex).Document.url
         'rtn = MsgBox(chkfile & " 运行中, 您确定要关闭吗?", vbYesNo, "进程检查")
         'If rtn = 6 Then
         phwnd = mShellWindow.Item(mIndex).hwnd
         PostMessage phwnd, WM_CLOSE, 0, 0 '关闭
         'end if
      End If
   Next mIndex
End Sub
 

2.【CBM666 的设置IE首页】2007年06月20日 星期三 16:43'添加 Command1 Command2
http://hi.baidu.com/cbm666/blog/item/e3666c81f70416dabc3e1e8d.html

Option Explicit
Const REG_SZ As Long = 1
Const HKEY_CURRENT_USER = &H80000001
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Dim hKey&
Private Sub Form_Load()
Command1.Caption = "百 度"
Command2.Caption = "空 白"
End Sub

Private Sub Command1_Click()
RegCreateKey HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\Main", hKey
RegSetValueEx hKey, "Start Page", 0, REG_SZ, ByVal "http://baidu.com", 19
MsgBox "已成功设置首页为百度!", , "菜鸟多媒体"
RegCloseKey hKey
End Sub

Private Sub Command2_Click()
RegCreateKey HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\Main", hKey
RegSetValueEx hKey, "Start Page", 0, REG_SZ, ByVal "about:blank", 11
MsgBox "已成功设置首页为空白页!", , "菜鸟多媒体"
RegCloseKey hKey
End Sub 

 
3.【CBM666 的键盘监视器】2007年06月21日 星期四 10:19'********************* 本段代码放在 Form1
http://hi.baidu.com/cbm666/blog/item/20fd42a76a0bd997d0435877.html

Private Sub Form_Load()
    Me.Caption = "键盘监视器"
    MsgBox "运行后打开记事本,输入一些东东后,退出时您将可以看到刚才敲入的一些键"
    SetTimer Me.hwnd, 0, 1, AddressOf TimerProc
End Sub

Private Sub Form_Unload(Cancel As Integer)
    KillTimer Me.hwnd, 0
    MsgBox "截获的键盘消息" & vbCrLf & Chr(10) & sSave
End Sub

'*************** 本段代码放在 Module1.bas

Public Const DT_CENTER = &H1
Public Const DT_WORDBREAK = &H10
Type RECT
     Left As Long
     Top As Long
     Right As Long
     Bottom As Long
End Type
Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" (ByVal hDC As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As Long, ByVal lpDrawTextParams As Any) As Long
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
Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Global Cnt&, sSave$, sOld$, Ret$, Tel&
Function GetPressedKey() As String
    For Cnt = 32 To 128
       If GetAsyncKeyState(Cnt) <> 0 Then
          GetPressedKey = Chr$(Cnt)
          Exit For
       End If
    Next Cnt
End Function

Sub TimerProc(ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long)
    Ret = GetPressedKey
    If Ret <> sOld Then
       sOld = Ret
       sSave = sSave + sOld
    End If
End Sub

 
4.【CBM666 的图片放大缩小与保存】2007年06月21日 星期四 21:14'添加 Command1 Command2 Picture1 CommonDialog1

Dim picwidth&, picheight&
Private Sub Form_Load()
    Picture1.BorderStyle = 0
    picwidth = 8000: picheight = 6000
    Picture1.Move Screen.Width, 0, picwidth, picheight
    Picture1.AutoRedraw = True
    Me.AutoRedraw = False
    Command1.Caption = "读取图片"
    Command2.Caption = "保存图片"
End Sub

Private Sub Command1_Click()
    On Error GoTo errhandler
    With CommonDialog1
       .CancelError = True
       .InitDir = "c:\"
       .Filter = "图片文件(*.jpg)|*.jpg|Gif(*.gif)|*.gif|Bmp(*.bmp)|*.bmp"
       .ShowOpen
    End With
    If CommonDialog1.FileName <> "" Then Me.Picture = LoadPicture(CommonDialog1.FileName)
errhandler:
    If Err > 0 Then Exit Sub
End Sub

Private Sub Command2_Click()
    On Error GoTo errhandler
    Picture1.PaintPicture Me.Picture, 0, 0, picwidth, picheight
    Picture1.Picture = Picture1.Image
    With CommonDialog1
       .CancelError = True
       .InitDir = "c:\"
       .Filter = "位图文件文件(*.bmp)|*.bmp"
       .Flags = cdlOFNOverwritePrompt   ' 若文件已存在，提示确认覆盖
       .ShowSave
    End With
    If CommonDialog1.FileName <> "" Then
       SavePicture Picture1.Image, CommonDialog1.FileName
       MsgBox "保存完成"
    End If
errhandler:
    If Err > 0 Then Exit Sub
End Sub

'Private Sub Command3_Click()
'    '如果你是 win2000 可以使用下面的代码保存为JPG 也可以放大或缩小保存
'    '工程部件kodak image edit control (Imgedit.ocx)
'    ImgEdit1.Image = "c:\124.jpg" '装载一幅图片
'    ImgEdit1.Display '将装载的图片显示出来
'    ImgEdit1.Zoom = 50 '缩小一半尺寸 50%
'     ImgEdit1.SaveAs "c:\2.jpg", wiFileTypeJPG, , 6, 0, True   '保存成JPG文件
'    '或
'    ImgEdit1.SaveAs "c:\2.jpg", wiFileTypeJPG, , 6 '保存成JPG文件
'End Sub

 
5.【CBM666 的强制关闭QQ】2007年05月29日 星期二 10:59'添加 Command1

Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessID As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Const TH32CS_SNAPHEAPLIST = &H1
Const TH32CS_SNAPPROCESS = &H2
Const TH32CS_SNAPTHREAD = &H4
Const TH32CS_SNAPMODULE = &H8
Const TH32CS_SNAPALL = (TH32CS_SNAPHEAPLIST Or TH32CS_SNAPPROCESS Or TH32CS_SNAPTHREAD Or TH32CS_SNAPMODULE)
Const TH32CS_INHERIT = &H80000000
Const MAX_PATH As Integer = 260
Const PROCESS_TERMINATE = 1 '关闭进程
Private Type PROCESSENTRY32
      dwSize As Long
      cntUsage As Long
      th32ProcessID As Long
      th32DefaultHeapID As Long
      th32ModuleID As Long
      cntThreads As Long
      th32ParentProcessID As Long
      pcPriClassBase As Long
      dwFlags As Long
      szExeFile As String * MAX_PATH
End Type
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function Process32First Lib "kernel32" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Sub CloseHandle Lib "kernel32" (ByVal hPass As Long)
Dim chkfile$, aa$, rtn&, proid&, i%

Private Sub Form_Load()
      Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
      Me.Caption = "CBM666 的强制关闭QQ"
      Call addjclist
End Sub

Private Sub Command1_Click()
      chkfile = UCase("qq.exe")
      If InStr(aa, chkfile) > 0 Then
         rtn = MsgBox(chkfile & " 运行中, 您确定要关闭吗?", vbYesNo, "进程检查")
         If rtn = 6 Then Call Closejc
      Else
         MsgBox chkfile & " 没运行"
      End If
End Sub

Sub addjclist()
      Dim hSnapShot As Long, uProcess As PROCESSENTRY32
      hSnapShot = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&)
      uProcess.dwSize = Len(uProcess)
      rtn = Process32First(hSnapShot, uProcess)
      aa = ""
      Do While rtn <> 0
         aa = aa & Left(uProcess.szExeFile, InStr(uProcess.szExeFile, Chr(0)) - 1) & "," & Str(uProcess.th32ProcessID) & "!!!"
         rtn = Process32Next(hSnapShot, uProcess)
      Loop
      aa = UCase(aa)
      CloseHandle hSnapShot
End Sub

Sub Closejc() '结束指定进程
      On Error Resume Next
      proid = GetProcessID(chkfile)
      If proid <> 0 Then
         hProcess = OpenProcess(PROCESS_TERMINATE, False, proid)
         TerminateProcess hProcess, 1
         CloseHandle hProcess
         MsgBox chkfile & " 已关闭"
      End If
End Sub

Public Function GetProcessID(ByVal lpProcess As String) As Long
      Dim s
      s = Split(aa, "!!!")
      For i = 0 To UBound(s)
         If InStr(s(i), lpProcess) > 0 Then
            s = Split(s(i), ",")
            GetProcessID = s(1)
            Exit For
         End If
      Next i
End Function

'****************************************** 代码 2 (转自女孩)

'添加 Command1

Dim procname$, rtn&, strcomputer$
Private Sub Command1_Click()
     procname = "qq.exe"
     strcomputer = "."
     Set objWMIService = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\" & strcomputer & "\root\cimv2")
     Set colProcessList = objWMIService.ExecQuery("Select * from Win32_Process Where Name = '" & procname & "'")
     If colProcessList.Count = 0 Then
        MsgBox procname & " 没有运行"
     Else
        For Each objProcess In colProcessList
           rtn = MsgBox("您确定要终止 " & procname & " 吗？", vbYesNo, "强制关闭进程")
           If rtn = 6 Then objProcess.Terminate
        Next
     End If
End Sub

6. 【CBM666 的文件夹隐藏与显示】2007年05月24日 星期四 17:17'添加 Command1 Command2

'常数 值 描述
'Normal 0 普通文件。未设置属性。
'ReadOnly 1 只读文件。
'Hidden 2 隐藏文件。
'System 4 系统文件。

Dim fname$, attrb&
Private Sub Form_Load()
    Command1.Caption = "隐藏"
    Command2.Caption = "显示"
End Sub

Private Sub Command1_Click()
    fname = "c:\kk"
    attrb = 2
    Call Changeattr(fname, attrb)
End Sub

Private Sub Command2_Click()
    fname = "c:\kk"
    attrb = 0
    Call Changeattr(fname, attrb)
End Sub

Private Sub Changeattr(folderspec$, attrno&)
    Dim fs, f
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(folderspec)
    f.Attributes = attrno
End Sub

 
7. 【检测网页是否已下载完毕】2007年05月24日 星期四 17:00'添加 WebBrowser1, Text1

Private Sub Form_Load()
    Text1.Text = "http://post.baidu.com/f?kz=204946905"
End Sub

Private Sub Command1_Click()
    WebBrowser1.Navigate Text1.Text
End Sub

Private Sub WebBrowser1_DocumentComplete(ByVal
 
8. 【CBM666 的读取与保存记事本文件】2007年05月23日 星期三 13:39'添加 CommonDialog1 Command1 Command2 Text1
'Text1的Multiline要设为True
'Text1的ScrollBars看需要自己加

Dim fname$, aa$
Private Sub Form_Load()
     Command1.Caption = "打 开"
     Command2.Caption = "保 存"
End Sub

Private Sub Command1_Click()
    On Error GoTo errhandler
    With CommonDialog1
       .CancelError = True
       .InitDir = App.Path '予设存档路径
       .Filter = "文档文件(*.txt)|*.txt"
       .ShowOpen   '打开文件
    End With
    fname = CommonDialog1.FileName
    Text1.Text = ""
    Open fname For Input As #1
    While Not EOF(1)
       Line Input #1, aa
       Text1.Text = Text1.Text & aa & vbCrLf
    Wend
    Close #1
errhandler:
    If Err = 32755 Then Exit Sub '选择了取消
End Sub

Private Sub Command2_Click()
    On Error GoTo errhandler
    With CommonDialog1
       .CancelError = True
       .InitDir = App.Path '予设存档路径
       .Filter = "文档文件(*.txt)|*.txt"
       .Showsave   '保存文件
    End With
    fname = CommonDialog1.FileName
    Open fname For Output As #1
    Print #1, Text1.Text
    Close #1
errhandler:
    If Err = 32755 Then Exit Sub '选择了取消
End Sub

'******************************************* 快速打开记事本文件

Private Sub Command1_Click()
   Open "c:\test.txt" For Input As #1
   Text1.Text = StrConv(InputB(LOF(1), 1), vbUnicode)
   Close #1
End Sub
 

9. 搜遍文件夹下的所有文件】2007年05月06日 星期日 21:55 '添加 Dir1 Command1 List1 List2 Text1 Text2 Text3 Progressbar1 Picture1 以上这些控件往窗体里放就好,别管控件大小与位置

'*************************************************************
Private Declare Function GetDiskFreeSpaceEx Lib "kernel32" Alias "GetDiskFreeSpaceExA" (ByVal lpRootPathName As String, lpFreeBytesAvailableToCaller As Currency, lpTotalNumberOfBytes As Currency, lpTotalNumberOfFreeBytes As Currency) As Long
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
'***********************************************************
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Const MaxLFNPath = 260
Const MAX_PATH = 260
Const INVALID_HANDLE_VALUE = -1
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MaxLFNPath
cShortFileName As String * 14
End Type
Dim WFD As WIN32_FIND_DATA
Dim extpatt(20) As String
Dim aa$, schdir$, schpattern$, spPath$
Dim i%, jj%, tdirs&, tfiles&, maxpattern%, tfsize#, tsize#, tmpsize#

Private Sub Form_Load()
Dir1.Visible = False
Text1.Width = 3000: Text2.Width = 2000: Text3.Width = 2400
Text1.Move 0, 0
Text2.Move Text1.Left + Text1.Width + 100, 0
Text3.Move Text2.Left + Text2.Width + 100, 0
List1.Width = 12000: List1.Height = 4000
List1.Move 0, Text1.Top + Text1.Height + 100
List2.Width = 12000: List2.Height = 4000
List2.Move 0, List1.Top + List1.Height + 100
Me.Width = List1.Width + 120: Me.Height = List1.Height + List2.Height + 800 + Command1.Height + Text1.Height
Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
Command1.Move (Me.ScaleWidth - Command1.Width) \ 2, List2.Top + List2.Height + 100
Picture1.Width = 5000
ProgressBar1.Width = 5000
ProgressBar1.Move Command1.Left + Command1.Width + 300, Command1.Top
Picture1.Move 100, Command1.Top
Text1.Text = "*.*"
End Sub

Private Sub Command1_Click()
On Error GoTo errhandler
Set spShell = CreateObject("Shell.Application")
Set spFolder = spShell.BrowseForFolder(0, "选择目录:", 0, ssfDRIVES)
Set spFolderItem = spFolder.Self
spPath = spFolderItem.Path
If Right(spPath, 1) <> "\" Then spPath = spPath & "\"
Call GetDiskFreeSpaceEx(spPath, BytesFreeToCalller, TotalBytes, TotalFreeBytes)
tsize = (TotalBytes - TotalFreeBytes) * 10000
 
schpattern = Text1.Text
tfiles = 0: tfsize = 0: tmpsize = 0
Text2.Text = ""
Text3.Text = ""
For jj = 0 To 20
extpatt(jj) = ""
Next jj
s = Split(Text1.Text, ",")
For jj = 0 To UBound(s)
If s(jj) = "" Then Exit For
extpatt(jj) = s(jj)
Next jj
 
maxpattern = jj
List1.Clear
List2.Clear
Call SearchDirs(spPath)
Text2.Text = "共有 " & Text2.Text & " 个文件"
Text3.Text = "占用 " & Text3.Text & " KBytes"
tfsize = tsize
Call showslider
Picture1.Cls
MsgBox "查找完成!!"
errhandler:
If Err > 0 Then Exit Sub
End Sub

Private Sub SearchDirs(curpath$)
On Error Resume Next
Dim dirs%, dirbuf$(), i%
Picture1.Cls
Picture1.Print "正在查找 " & curpath$
DoEvents
hItem& = FindFirstFile(curpath$ & "*", WFD)
If hItem& <> INVALID_HANDLE_VALUE Then
Do
DoEvents
If (WFD.dwFileAttributes And vbDirectory) And Asc(WFD.cFileName) <> 46 Then
If (dirs% Mod 10) = 0 Then ReDim Preserve dirbuf$(dirs% + 10)
dirs% = dirs% + 1
dirbuf$(dirs%) = Left$(WFD.cFileName, InStr(WFD.cFileName, vbNullChar) - 1)
End If
Loop While FindNextFile(hItem&, WFD)
Call FindClose(hItem&)
List1.AddItem Mid(curpath, 1, Len(curpath) - 1)
Call SearchFileSpec(curpath$)
End If
For i% = 1 To dirs%
DoEvents
SearchDirs curpath$ & dirbuf$(i%) & "\"
Next i%
End Sub

Private Sub SearchFileSpec(curpath$)
On Error Resume Next
For jj = 0 To maxpattern - 1
schpattern = extpatt(jj)
If schpattern = "" Then Exit For
hfile& = FindFirstFile(curpath$ & schpattern, WFD)
If hfile& <> INVALID_HANDLE_VALUE Then
Do
DoEvents
aa = Trim(curpath$) & Trim(WFD.cFileName)
If (WFD.dwFileAttributes And vbDirectory) Or Asc(WFD.cFileName) = 46 Then
Else
List2.AddItem aa
List2.Selected(List2.ListCount - 1) = True
tfiles = tfiles + 1
tfsize = tfsize + FileLen(aa)
Call showslider
Text2.Text = Format(Str(tfiles), "#,###")
Text3.Text = Format(Str(Int(tfsize / 1024)), "#,###")
End If
Loop While FindNextFile(hfile&, WFD)
Call FindClose(hfile&)
End If
Next jj
End Sub

Private Sub showslider()
If tsize > 0 And tfsize > 0 Then
ProgressBar1.Value = Val(Str(Int(Round(tfsize / tsize * 100))))
End If
End Sub
 
10. CBM666 的一个简单画曲线图】2007年05月01日 星期二 17:20'添加 Command1 Picture1
http://hi.baidu.com/cbm666/blog/item/44b90c332eb097f91b4cffab.html

Dim i%, jj%, a(31) As Integer
Dim x1%, y1%, x2%, y2%, oldx1%, oldy1%, perpixw!, perpixh!, perdivx!, perdivy!
Private Sub Form_Load()
      Picture1.AutoSize = True
      'Picture1.Picture = LoadPicture("c:\curve2.gif")
      Picture1.AutoRedraw = True
      Me.Width = Picture1.Width + 4000
      Me.Height = Picture1.Height + 3000
      Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
      Picture1.Move (Me.ScaleWidth - Picture1.Width) \ 2, (Me.ScaleHeight - Picture1.Height) \ 2
      Command1.Move (Me.ScaleWidth - Command1.Width) \ 2, (Me.ScaleHeight - 345 - Command1.Height)
      Me.AutoRedraw = True
End Sub

Private Sub Command1_Click()
      For i = 1 To 31
         jj = Int(Rnd * 1000)
         a(i) = jj
      Next i
      drawpic
End Sub

Private Sub drawpic()
      On Error Resume Next
      perpixw = (Picture1.Width) / 30
      perpixh = Picture1.Height / 1000
      oldx1 = 0
      oldy1 = Picture1.Height
      Call drawline
      x1 = Picture1.Left - 500
      y1 = Picture1.Top - 100
      For i = 1000 To 0 Step -50
         Me.CurrentX = x1
         Me.CurrentY = y1
         y1 = y1 + Int(Picture1.Height / 20)
         If i Mod 100 = 0 Then Me.Print Str(i)
      Next i
  
      For i = 1 To 31
         x1 = (i - 1) * perpixw
         y1 = a(i) * perpixh
         Me.CurrentY = Picture1.Top + Picture1.Height + 100
         Me.CurrentX = (Picture1.Left - 100) + x1
         If i Mod 5 = 0 Then Print Format(Str(i), "00")
         Picture1.Line (oldx1, oldy1)-(x1, y1), QBColor(Int(Rnd * 7) + 9)
         oldx1 = x1: oldy1 = y1
      Next i
End Sub

Private Sub drawline()
      Picture1.Cls
      Me.Cls
      Me.FontSize = 10
      Me.ForeColor = QBColor(0)
      perdivx = Picture1.Width \ 30
      perdivy = Picture1.Height \ 20
  
      x1 = 0: x2 = Picture1.Width
      For yy = 0 To Picture1.Height Step perdivy
         Picture1.Line (x1, yy)-(x2, yy), QBColor(3)
      Next yy
     
      y1 = 0: y2 = Picture1.Height
      For x1 = 0 To Picture1.Width Step perdivx
         Picture1.Line (x1, y1)-(x1, y2), QBColor(3)
      Next x1
End Sub

 
11.  【CBM666 的隐藏桌面图标】2007年04月30日 星期一 14:53'添加 Command1 Command2

Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Const SW_HIDE = 0
Const SW_RESTORE = 9
Dim Hwd&, rtn&

Private Sub Form_Load()
     Command1.Caption = "隐藏"
     Command2.Caption = "回复"
End Sub

Private Sub Form_Unload(Cancel As Integer)
     Command2_Click
End Sub

Private Sub Command1_Click()
    Hwd = FindWindow("Progman", vbNullString)
    rtn = ShowWindow(Hwd, SW_HIDE)
End Sub

Private Sub Command2_Click()
    Hwd = FindWindow("Progman", vbNullString)
    rtn = ShowWindow(Hwd, SW_RESTORE)
End Sub

 
12. 【CBM666 的隐藏任务栏】2007年04月30日 星期一 14:57'添加 Command1 Command2

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetWindowPos Lib "user32.dll" (ByVal lhwnd As Long, ByVal hWndInsertAfter As Long, ByVal swpX As Long, ByVal swpY As Long, ByVal cX As Long, ByVal cY As Long, ByVal wFlags As Long) As Long
Const swp_HideWindow = &H80
Const swp_ShowWindow = &H40
Dim task%, TaskbarHwn&
Private Sub Form_Load()
    Command1.Caption = "关闭任务栏"
    Command2.Caption = "显示任务栏"
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Command2_Click
End Sub

Public Sub taskclick()
    TaskbarHwn = FindWindow("Shell_traywnd", "")
    If task = 1 Then
       Call SetWindowPos(TaskbarHwn, 0, 0, 0, 0, 0, swp_HideWindow)
    Else
       Call SetWindowPos(TaskbarHwn, 0, 0, 0, 0, 0, swp_ShowWindow)
    End If
End Sub

Private Sub Command1_Click()
    task = 1 '1 关闭任务栏
    taskclick
End Sub

Private Sub Command2_Click()
    task = 2 '2 显示任务栏
    taskclick
End Sub

 
13. 关闭一个运行中的程序进程】2007年04月30日 星期一 16:38Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Const PROCESS_TERMINATE = 1
Dim AA$, ProID&, hProcess&

Private Sub Form_Load()
     '下面这个路径你要自己改
     AA = "c:\test.exe"
     If Dir(AA) <> "" Then
        ProID = Shell(AA, 3)
        SendKeys (Chr(13))
     End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
     AA = "c:\test.exe"
     If Dir(AA) <> "" Then
        hProcess = OpenProcess(PROCESS_TERMINATE, False, ProID)
        TerminateProcess hProcess, 1
        CloseHandle hProcess
     End If
     End
End Sub
 

14. 【开机自动启动程序】2007年04月29日 星期日 16:46'************ 方法 1 写进「开始」菜单\程序\启动

Dim aa$, bb$ 
Private Sub Command1_Click() 
aa = "c:\windows\abc.exe" 
bb = Environ("userprofile") & "\「开始」菜单\程序\启动\abc.exe" 
FileCopy aa, bb 
End Sub 

'******************* 方法 2    写进注册表的方法 
1.这个是使用注册表方式. 
2.下面这代码,我已在win2000下跑过没问题,但在98或winme,XP我就没试过了, 

'使用下面这三个API与两个常数(标记部份为快捷键方式增加到开始下的启动) 
Private Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long 
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long 
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long 
Const HKEY_LOCAL_MACHINE = &H80000002 
Const REG_SZ = 1 
Private Sub Command1_Click() 
Dim Ret2 As Long 
'打开 HKEY_LOCAL_MACHINE　下的　software\microsoft\windows\currentVersion\run 
RegCreateKey HKEY_LOCAL_MACHINE, "software\microsoft\windows\currentVersion\run", Ret2 
'将此主键下的 "默认" 值改为你的 exe 全路径" 
RegSetValue Ret2, vbNullString, REG_SZ, "c:\windows\abc.exe", 4 
'关闭对主键的操作 
RegCloseKey Ret2 
End Sub

15. 【CBM666 的文件下载】2008年01月23日 星期三 14:46'添加 Command1 Text1 (Multiline设为True,再加上滚动条)

Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long '-下载文件
Dim fname$, appdisk$, lngRetVal&
Private Sub Command1_Click()
   appdisk = IIf(Right(App.Path, 1) = "\", App.Path, App.Path & "\")
   fname = "eng1000.txt"
   '下载文件
   DownloadFile "HTTP://cbm666.com/" & fname, appdisk & fname
   '加进Textbox
   fname = appdisk & fname
   If Dir(fname) <> "" Then
      Open fname For Input As #1
      Text1.Text = StrConv(InputB(LOF(1), 1), vbUnicode)
      Close #1
   End If
End Sub

Public Function DownloadFile(URL As String, LocalFilename As String) As Boolean '下载文件
   lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
   If lngRetVal = 0 Then DownloadFile = True
End Function

'***************************************** 代码 2

'加上 Command1 Timer1

Option Explicit
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long '-下载文件
Dim fname$, appdisk$, lngRetVal&, DLOK As Boolean

Private Sub Form_Load()
   Timer1.Enabled = False
   Timer1.Interval = 100
End Sub

Private Sub Command1_Click()
   appdisk = IIf(Right(App.Path, 1) = "\", App.Path, App.Path & "\")
   fname = "eng1000.txt"
   If Dir(appdisk & fname) <> "" Then Kill appdisk & fname
   '下载文件
   DownloadFile "HTTP://cbm666.com/" & fname, appdisk & fname
   Timer1.Enabled = True
End Sub

Public Sub DownloadFile(URL As String, LocalFilename As String) '下载文件
   If URLDownloadToFile(0, URL, LocalFilename, 0, 0) = 0 Then DLOK = True
End Sub

Private Sub Timer1_Timer()
   If DLOK Then
      '加进Textbox
      If Dir(appdisk & fname) <> "" Then
         Open fname For Input As #1
         Text1.Text = StrConv(InputB(LOF(1), 1), vbUnicode)
         Close #1
      End If
      Timer1.Enabled = False
   End If
End Sub