分类 [ 学习编程 ] 下的全部文章


方法1:

Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function
CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function
ShellExecuteEx Lib "shell32.dll" Alias "ShellExecuteExA" (lpInfo As Any) As Long

Private
Type SHELLEXECUTEINFO
cbSize
As Long
fMask As Long
hwnd As Long
lpVerb As String
lpFile As String
lpParameters As String
lpDirectory As String
nShow As Long
hInstApp As Long
' Optional members
lpIDList As Long
lpClass As String
hkeyClass As Long
dwHotKey As Long
hIcon_OR_Monitor As Long
hProcess As Long
End
Type

Private Sub Form_Load()
Dim si As SHELLEXECUTEINFO
si.cbSize = Len(si)
si.lpVerb =
"open"
si.lpFile = "notepad.exe"
si.lpParameters = ""
si.lpDirectory = ""
si.nShow = 5 'SW_SHOW
si.fMask = &H40 'SEE_MASK_NOCLOSEPROCESS
ShellExecuteEx si
If si.hProcess <> 0 Then
WaitForSingleObject si.hProcess, &HFFFFFFFF ' 无限等待, 直到程式结束
CloseHandle si.hProcess
MsgBox
"程序运行完毕!"
End If
End Sub


方法2:

Public Declare Function OpenProcess Lib "kernel32" Alias "OpenProcess" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Public Declare Function
WaitForSingleObject Lib "kernel32" Alias "WaitForSingleObject" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Public Declare Function
CloseHandle Lib "kernel32" Alias "CloseHandle" (ByVal hObject As Long) As Long
Dim
lngPId As Long
Dim
lngPHandle As Long
lngPId = Shell("Notepad", vbNormalFocus)
lngPHandle = OpenProcess(SYNCHRONIZE,
0, lngpId)
If lngPHandle <> 0 Then
Call
WaitForSingleObject(lngPHandle, INFINITE) ' 无限等待, 直到程式结束
Call CloseHandle(lngPHandle)
End If


方法3:

Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function
GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Function nt>CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Const
PROCESS_QUERY_INFORMATION = &H400

Const STILL_ALIVE = &H103

Private Sub Command1_Click()
Dim pid As Long
pid = Shell("c:\a.bat", vbNormalFocus)
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION,
0, pid)
Do
Call
GetExitCodeProcess(hProcess, ExitCode)
DoEvents
Loop While ExitCode = STILL_ALIVE
Call CloseHandle(hProcess)
MsgBox (
"运行结束")
End Sub




重点为:向系统注册“TaskbarCreated”消息

Public Function Wndproc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If
Msg = lngMsgBarRester Then '重建托盘图标
FrmMain.cTray.InTray = False
FrmMain.cTray.InTray = True
End If
'交还控制权给系统继续监测热键
Wndproc = CallWindowProc(preWinProc, hwnd, Msg, wParam, lParam)
End Function

Sub
Main()
lngMsgBarRester = RegisterWindowMessage(
"TaskBarCreated") '注册任务栏创建的消息
End Sub




例子1:
Dim aa(10) As String
Dim
bb
Dim i As Integer
For
i = 0 To 9
aa(i) = "aa" + Str(i)
Next
bb = Filter(aa, "aa")
Label1.Caption = bb(
0)
Label2.Caption = bb(
1)
Label3.Caption = bb(
2)
'这时Label1显示aa 0,Label2显示aa 1,Label3显示aa 2。bb我也不知设为什么类型,所以就没设定。

例子2:
Dim b() As String
Dim
a(10) As String
Dim
i As Integer
For
i = 0 To 10
a(i) = Trim(Str(i))
Next i
a(
1) = "5"
b = Filter(a, "5")
MsgBox UBound(b,
1)
b = Filter(a,
"5") '就是将A数组中所有="5"的项附给B数组

例子3:
'用Filter函数取出有可能与所选项重复的值
'NewArray和MatchArray都是数组,一般用在数组的筛选上!
MatchArray = Filter(NewArray, orgArray(i), True, vbTextCompare)


'任务栏高度[此部分相关代码转载自 枕善居]
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
Private Const
SPI_GETWORKAREA = 48

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

'透明
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 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
Const
WS_EX_LAYERED = &H80000
Const GWL_EXSTYLE = (-20)
Const LWA_ALPHA = &H2
Const LWA_COLORKEY = &H1

'延迟
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'最前
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 Const
HWND_BOTTOM = 1
Private Const HWND_BROADCAST = &HFFFF&
Private Const HWND_DESKTOP = 0
Private Const HWND_NOTOPMOST = -2
Private Const HWND_TOP = 0
Private Const HWND_TOPMOST = -1

'可见区域
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function
SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function
DeleteObject Lib "gdi32" (ByVal hObject As Long<
/font>) As Long

Dim
MyRect As Long
Dim
MyRgn As Long

Dim
X1 As Integer, Y1 As Integer
Dim
X2 As Integer, Y2 As Integer
Dim
OpenSpeed As Integer
Dim
CloseSpeed As Integer

Dim
WiteLong As Integer


Private Sub
Form_Load()
'------------------------------------------------------------------
OpenSpeed = 10 '出现时速度
CloseSpeed = 10 '关闭时淡出的速度
Timer1.Interval = 10 '出现时显示平滑度
WiteLong = 30 '关闭前等待时间(秒),为0则不会自动关闭
'------------------------------------------------------------------

'计算任务栏高
Dim lRes As Long
Dim
rectVal As RECT
Dim TaskbarHeight As Integer

lRes = SystemParametersInfo(SPI_GETWORKAREA, 0, rectVal, 0)
TaskbarHeight = Screen.Height - rectVal.Bottom * Screen.TwipsPerPixelY

'确定位置
Me.Move Screen.Width * 0.75, Screen.Height * 0.75 - TaskbarHeight, _
Screen.Width \
4, Screen.Height \ 4

'永在最前
SetWindowPos Me.hWnd, HWND_TOPMOST, Me.Left \ Screen.TwipsPerPixelX, Me.Top \ Screen.TwipsPerPixelY, Me.Width, Me.Height, 1

'为遮蔽窗体计算坐标
X1 = 0
Y1 = Me.Width \ Screen.TwipsPerPixelX

X2 = Me.Width \ Screen.TwipsPerPixelX
Y2 = Me.Height \ Screen.TwipsPerPixelY -
1

'遮蔽部分窗体为不可见
MyRect = CreateRectRgn(X1, Y1, X2, Y2)
MyRgn = SetWindowRgn(Me.hWnd, MyRect,
True)
End Sub

Private Sub
Form_Unload(Cancel As Integer)
Call CloseMe(1) '以什么样的方式关闭自己,有 1-淡出 和 2-收缩 可选
Call DeleteObject(MyRect)
End Sub


Private Sub
Timer1_Timer()
Y2 = Y2 - OpenSpeed

If Y2 <= 0 Then
MyRect = CreateRectRgn(0, 0, Me.Width \ Screen.TwipsPerPixelX, Y2)
MyRgn = SetWindowRgn(Me.hWnd, MyRect,
True)

Timer1.Enabled =
False

'----------------------
If WiteLong <> 0 Then
Timer2.Interval = 1000
Timer2.Enabled = True
End If
End If

MyRect = CreateRectRgn(X1, Y1, X2, Y2)
MyRgn = SetWindowRgn(Me.hWnd, MyRect,
True)
End Sub

Private Sub
Timer2_Timer()
Static NL As Integer
NL = NL + 1

If NL >= WiteLong Then Unload Me

End Sub


'==============================================
'0 - 不使用卸载效果
'1 - 使用透明淡出效果
'2 - 使用收缩效果
'==============================================
Private Sub CloseMe(Optional N As Integer = 1)
Select Case N
Case 0
Exit Sub
Case
1
Dim rtn As Long

rtn = GetWindowLong(Me.hWnd, GWL_EXSTYLE)
rtn = rtn
Or WS_EX_LAYERED
SetWindowLong Me.hWnd, GWL_EXSTYLE, rtn

For I = 255 To 10 Step -10
SetLayeredWindowAttributes Me.hWnd, 0, I, LWA_ALPHA
DoEvents
Sleep CloseSpeed
Next I
Case 2
While Y2 < (Me.Height / Screen.TwipsPerPixelY)
Y2 = Y2 + OpenSpeed
MyRect = CreateRectRgn(X1, Y1, X2, Y2)
MyRgn = SetWindowRgn(Me.hWnd, MyRect,
True)
Sleep OpenSpeed
Wend
Case Else

End Select
End Sub




VB提供了API函数SetWindowLong和GetWindowLong,可以让我们很容易取得对窗口的操作;通过对窗口属性的操作,可以更改窗口的显示风格。有些看来是正常情况下无法实现的窗口,现在你可以很容易的实现。只要你想到,更多希奇古怪的你也能做到。快试试下面的例子吧。

'以下例子中可能用到的API声明和常量、变量声明
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
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 Const
SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOMOVE = &H2
Private Const SWP_DRAWFRAME = &H20
Private Const GWL_STYLE = (-16)
Private Const WS_THICKFRAME = &H40000
Private Const WS_DLGFRAME = &H400000
Private Const WS_POPUP = &H80000000
Private Const WS_CAPTION = &HC00000
Private Const WS_SYSMENU = &H80000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_MAXIMIZE = &H1000000


--------------------------------------------------------------------------------

'例子一:任何一个控件(只要有窗口,这是我们的前提,下同),你可以在运行时随便更改它的大小。
Private Sub ControlSize(ControlName As Control, SetTrue As Boolean)
Dim dwStyle As Long
dwStyle = GetWindowLong(ControlName.hwnd, GWL_STYLE)
If SetTrue Then
dwStyle = dwStyle Or WS_THICKFRAME
Else
dwStyle = dwStyle - WS_THICKFRAME
End If
dwStyle = SetWindowLong(ControlName.hwnd, GWL_STYLE, dwStyle)
SetWindowPos ControlName.hwnd, ControlName.Parent.hwnd,
0, 0, 0, 0, SWP_NOZORDER Or SWP_NOSIZE Or SWP_NOMOVE Or SWP_DRAWFRAME
End Sub
'用法:ControlSize picture1,true;设置第二个参数为False取消这种设置,下同


--------------------------------------------------------------------------------

'例子二:任何一个控件,我们都可以控制其显示风格为对话框的风格。
Private Sub ControlDialog(ControlName As Control, SetTrue As Boolean)
Dim dwStyle As Long
dwStyle = GetWindowLong(ControlName.hwnd, GWL_STYLE)
If SetTrue Then
dwStyle = dwStyle Or WS_DLGFRAME
Else
dwStyle = dwStyle - WS_DLGFRAME
End If
dwStyle = SetWindowLong(ControlName.hwnd, GWL_STYLE, dwStyle)
SetWindowPos ControlName.hwnd, ControlName.Parent.hwnd,
0, 0, 0, 0, SWP_NOZORDER Or SWP_NOSI
ZE
Or SWP_NOMOVE Or SWP_DRAWFRAME
End Sub
'用法:ControlSize picture1,true


--------------------------------------------------------------------------------

'例子三:任何一个控件,我们都可以控制其显示风格为模式对话框的风格
Private Sub ControlModal(ControlName As Control, SetTrue As Boolean)
Dim dwStyle As Long
dwStyle = GetWindowLong(ControlName.hwnd, GWL_STYLE)
If SetTrue Then
dwStyle = dwStyle Or WS_POPUP
Else
dwStyle = dwStyle - WS_POPUP
End If
dwStyle = SetWindowLong(ControlName.hwnd, GWL_STYLE, dwStyle)
SetWindowPos ControlName.hwnd, ControlName.Parent.hwnd,
0, 0, 0, 0, SWP_NOZORDER Or SWP_NOSIZE Or SWP_NOMOVE Or SWP_DRAWFRAME
End Sub
'用法:ControlModal Picture1,true


--------------------------------------------------------------------------------

'例子四:任何一个控件,我们都可以给它加上标题栏,通过拖动标题栏,可以实现控件的运行时移动。
Private Sub ControlCaption(ControlName As Control, SetTrue As Boolean) Dim dwStyle As Long
dwStyle = GetWindowLong(ControlName.hwnd, GWL_STYLE)
If SetTrue Then
dwStyle = dwStyle Or WS_CAPTION
Else
dwStyle = dwStyle - WS_CAPTION
End If
dwStyle = SetWindowLong(ControlName.hwnd, GWL_STYLE, dwStyle)
SetWindowPos ControlName.hwnd, ControlName.Parent.hwnd,
0, 0, 0, 0, SWP_NOZORDER Or SWP_NOSIZE Or SWP_NOMOVE Or SWP_DRAWFRAME
End Sub
'用法:ControlCaption picture1,true


--------------------------------------------------------------------------------

'例子五:任何一个控件,我们都可以给它加上ControlBox(所谓ControlBox,就是窗体的图标+最小化+最大化+关闭按钮)。
Private Sub ControlSysMenu(ControlName As Control, SetTrue As Boolean)
Dim dwStyle As Long
dwStyle = GetWindowLong(ControlName.hwnd, GWL_STYLE)
If SetTrue Then
dwStyle = dwStyle Or WS_SYSMENU
Else
dwStyle = dwStyle - WS_SYSMENU
End If
dwStyle = SetWindowLong(ControlName.hwnd, GWL_STYLE, dwStyle)
SetWindowPos ControlName.hwnd, ControlName.Parent.hwnd,
0, 0, 0, 0, SWP_NOZORDER Or SWP_NOSIZE Or SWP_NOMOVE Or SWP_DRAWFRAME
End Sub
'用法:ControlCaption picture1,true:ControlSysmenu picture1,true



'#############################
'**
'** 文件 frmDownLoad.frm 的内容
'**
'#############################
VERSION 5.00
Begin VB.Form frmDownLoad
BorderStyle =
1 'Fixed Single
Caption = "Form1"
ClientHeight = 2880
ClientLeft = 45
ClientTop = 330
ClientWidth = 6375
BeginProperty Font
Name =
"宋体"
Size = 9
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
LinkTopic =
"文件下载"
MaxButton = 0 'False
ScaleHeight = 2880
ScaleWidth = 6375
StartUpPosition = 2 'CenterScreen
Begin VB.CommandButton cmdStop
Caption =
"停止"
Enabled = 0 'False
Height = 480
Left = 1860
TabIndex = 6
Top = 2160
Width = 1365
End
Begin VB.CommandButton cmdStart
Caption =
"开始"
Height = 480
Left = 165
TabIndex = 5
Top = 2160
Width = 1365
End
Begin VB.TextBox txtFile
Height =
330
Left = 750
TabIndex = 3
Top = 705
Width = 5445
End
Begin VB.TextBox txtURL
Height =
330
Left = 750
TabIndex = 1
Top = 285
Width = 5445
End
Begin VB.Label lblCount
BackStyle =
0 'Transparent
Caption = "下载"
Height = 180
Left = 180
TabIndex = 4
Top = 1245
Width = 5130
End
Begin VB.Label Label1
AutoSize = -
1 'True
Caption = "文件:"
Height = 180
Left = 195
TabIndex = 2
Top = 780
Width = 450
End
Begin VB.Label lblURL
AutoSize = -
1 'True
Caption = "URL:"
Height = 180
Left = 195
TabIndex = 0
Top = 360
Width = 360
End
End
Attribute VB_Name = "frmDownLoad"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option
Explicit

Private Declare Function StrFormatByteSize Lib "shlwapi" Alias _
"StrFormatByteSizeA" (ByVal dw As Long, ByVal pszBuf As String, ByRef _
cchBuf
As Long nt color="#000000">)
As String

Private Declare Function
InternetOpen Lib "wininet.dll" _
Alias "InternetOpenA" (ByVal sAgent As String, _
ByVal lAccessType As Long, ByVal sProxyName As String, _
ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Private Declare Function
InternetOpenUrl Lib "wininet.dll" _
Alias "InternetOpenUrlA" (ByVal hOpen As Long, _
ByVal surl As String, ByVal sHeaders As String, _
ByVal lLength As Long, ByVal lFlags As Long, _
ByVal lContext As Long) As Long

Private Declare Function
HttpOpenRequest Lib "wininet.dll" _
Alias "HttpOpenRequestA" _
(
ByVal hInternetSession As Long, _
ByVal lpszVerb As String, _
ByVal lpszObjectName As String, _
ByVal lpszVersion As String, _
ByVal lpszReferer As String, _
ByVal lpszAcceptTypes As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Private Declare Function
InternetConnect Lib "wininet.dll" _
Alias "InternetConnectA" _
(
ByVal hInternetSession As Long, _
ByVal lpszServerName As String, _
ByVal nProxyPort As Integer, _
ByVal lpszUsername As String, _
ByVal lpszPassword As String, _
ByVal dwService As Long, _
ByVal dwFlags As Long, _
ByVal dwContext As Long) As Long
Private Declare Function
HttpSendRequest Lib "wininet.dll" _
Alias "HttpSendRequestA" _
(
ByVal hHttpRequest As Long, _
ByVal sHeaders As String, _
ByVal lHeadersLength As Long, _
ByVal sOptional As String, _
ByVal lOptionalLength As Long) As Boolean

Private Declare Function
InternetReadFile Lib "wininet.dll" _
(
ByVal hFile As Long, ByRef sBuffer As Byte, _
ByVal lNumBytesToRead As Long, lNumberOfBytesRead As Long) _
As Integer
Private Declare Function
InternetCloseHandle Lib "wininet.dll" _
(
ByVal hInet As Long) As Integer

Private Declare Function
GetLastError Lib "kernel32" () As Long

' Adds one or more HTTP request headers to the HTTP request handle.
'Public Declare Function HttpAddRequestHeaders Lib "wininet.dll" Ali
as "HttpAddRequestHeadersA" _
'(ByVal hHttpRequest As Long, ByVal sHeaders As String, ByVal lHeadersLength As Long, _
'ByVal lModifiers As Long) As Integer
Private bolStop As Boolean
' 然后,我们可以得到包含了一份详细说明的URL文本文件,它显示在下面的函数中:
Public Function DownloadFile(ByVal surl As String, ByVal strFile As String) As Long
Dim
s As String
Dim
hOpen As Long
Dim
hOpenUrl As Long
Dim
bDoLoop As Boolean
Dim
bRet As Boolean
Dim
intFH As Integer

Dim
sReadBuffer() As Byte
Dim
lNumberOfBytesRead As Long
Dim
lCount As Long
Dim
myCount As New clsCount
Const INTERNET_OPEN_TYPE_PRECONFIG = 0
Const INTERNET_OPEN_TYPE_DIRECT = 1
Const INTERNET_OPEN_TYPE_PROXY = 3
Const scUserAgent = "VB OpenUrl"
Const INTERNET_FLAG_RELOAD = &H80000000

lblCount.Caption = "正在连接服务器..."
lblCount.Refresh
hOpen = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString,
0)
hOpenUrl = InternetOpenUrl(hOpen, surl, vbNullString,
0, INTERNET_FLAG_RELOAD, 0)
lCount =
0

If hOpen <> 0 And hOpenUrl <> 0 Then
intFH = FreeFile
If Dir(strFile) <> "" Then
VBA.FileSystem.Kill strFile
End If
Open strFile For Binary As #intFH
myCount.Clear
Do While True
ReDim
sReadBuffer(2048)
bRet = InternetReadFile(hOpenUrl, sReadBuffer(
0), 2048, lNumberOfBytesRead)
If lNumberOfBytesRead > 0 And bRet = True Then
'if lnumberofbytesread<>2048 then
ReDim Preserve sReadBuffer(0 To lNumberOfBytesRead - 1)
Put
#intFH, , sReadBuffer
'
' buf.AddRange sReadBuffer, 0, lNumberOfBytesRead - 1
lCount = lCount + lNumberOfBytesRead
myCount.Count lNumberOfBytesRead
lblCount.Caption =
"已下载 " & VBStrFormatByteSize(lCount) & " [ " & VBStrFormatByteSize(myCount.Speed) & " /秒 ]"
lblCount.Refresh
Else
Exit Do
End If
bolStop = False
DoEvents
If bolStop = True Then
Exit Do
End If
Loop
Close #intFH
lblCount.Caption = "共下载 " & lCount & " 字节"
Else
lblCount.Caption = "打开URL错误"
End If

If
hOpenUrl <> 0 Then InternetCloseHandle (hOpenUrl)
If hOpen <> 0 Then InternetCloseHandle (hOpen)
Set myCount = Nothing
DownloadFile = lCount
End Function
Private Sub
cmdStart_Click()
txtURL.Enabled =
False
txtFile.Enabled = False
cmdStart.Enabled = False
cmdStop.Enabled = True
DownloadFile txtURL.Text, txtFile.Text
cmdStop.Enabled =
False
cmdStart.Enabled = True
txtFile.Enabled = True
txtURL.Enabled = True

End Sub
Private Sub
cmdStop_Click()
bolStop =
True
End Sub
Private Sub
SetText(ByVal txt As TextBox)
txt.Text = GetSetting(App.Title, Me.Name,
txt.Name)
End Sub
Private Sub
SaveText(ByVal txt As TextBox)
SaveSetting App.Title, Me.Name, txt.Name, txt.Text
End Sub
Private Sub
Form_Load()
SetText Me.txtFile
SetText Me.txtURL
End Sub
Private Sub
Form_Unload(Cancel As Integer)
SaveText Me.txtFile
SaveText Me.txtURL
End Sub

Private Function
VBStrFormatByteSize(ByVal lngSize As Long) As String
Dim
strSize As String * 128
Dim strData As String
Dim
lPos As Long
StrFormatByteSize lngSize, strSize, 128
lPos = InStr(1, strSize, Chr$(0))
strData = Left$(strSize, lPos -
1)
If lngSize > 1024 Then
strData = lngSize & "字节(" & strData & ")"
End If
VBStrFormatByteSize = strData
End Function



'########################
'**
'** 文件 clsCount.cls 的内容
'**
'########################
VERSION 1.0 CLASS
BEGIN
MultiUse = -
1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "clsCount"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option
Explicit
'******************************************************************************
'**
'** 用于计算速度的类模块
'**
'** 该类模块设定一个计数器,由程序不断的累计数据,并根据所花时间计算数据
'**
'** 编制: 袁永福
'** 时间: 2002-4-2
'**
'******************************************************************************
Private Declare Function GetTickCount Lib "kernel32" () As Long

Private
lngCountStart As Long
Private
lngCountCurrent As Long
Private
lngCountLast As Long
Private
lngSpeed As Long
Private
lngTickStart As Long
Private
lngTickCurrent As Long
Private
lngTickLast As Long
'Public StopCount As Boolean
'** 获得计数数据 **************************************************************
'** 累计初始值
Public Property Get CountStart() As Long
CountStart = lngCountStart
End Property
'** 累计终止值
Public Property Get CountEnd() As Long
CountEnd = lngCountCurrent
End Property
'** 累计总的速度
Public Property Get TotalSpeed() As Long
If
lngTickCurrent = lngTickStart Then
TotalSpeed = 0
Else
TotalSpeed = (lngCountCurrent - lngCountStart) / ((lngTickCurrent - lngTickStart) / 1000)
End If
End Property
'** 累计所花毫秒数
Public Property Get TotalTickCount() As Long
TotalTickCount = lngTickCurrent - lngTickStart
End Property
'** 清除所有数据 **************************************************************
Public Sub Clear()
lngCountStart =
0
lngCountCurrent = 0
lngCountLast = 0

lngSpeed = 0

lngTickStart = GetTickCount()
lngTickCurrent = lngTickStart
lngTickLast = lngTickStart

'StopCount = False
End Sub
'** 设置累计基数
Public Property Let CountStart(ByVal lStart As Long)
lngCountStart = lStart
lngCountCurrent = lStart
End Property
'** 累加数据 **
Public Sub Count(Optional ByVal lCount As Long = 1)
lngCountCurrent = lngCountCurrent + lCount
lngTickCurrent = GetTickCount()
End Sub

'** 获得速度 **
Public Property Get Speed() As Long
'lngTickCurrent = GetTickCount()
If lngTickLast = lngTickCurrent Then
Speed = lngSpeed
Else
Speed = (lngCountCurrent - lngCountLast) / ((lngTickCurrent - lngTickLast) / 1000)
lngSpeed = Speed
lngTickLast = lngTickCurrent
lngCountLast = lngCountCurrent
End If
End Property

'** 数据是否是最新更新的 **
Public Property Get NewSpeed() As Boolean
Dim
bolNew As Boolean
If
lngTickCurrent > lngTickLast + 1000 Then
bolNew = True
Else
bolNew = False
End If
NewSpeed = bolNew
End Property




【方法一】

StrComp(string1, String2, [Compare])

'函数功能:比较字符串string1和string2。

'返回说明:返回整数值:当string1string2时,返回值>0。这种比较是按照字符的字典序进行比较。


【方法二】

Declare Function lstrcmp Lib "kernel32" Alias "lstrcmpA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long

'或者用API的lstrcmp也能很快地实现字符串的对比


【方法三】

'By JiaJia 2008-05-30
Private Function MyStrCmp(str1 As String, str2 As String) As String
Dim
TmpFor As Long, Log As Long
Dim
Len1 As Long, Len2 As Long
If
Len1 <> Len2 Then '长度不等直接退出
If Instr(str1, str2) > 0 Or Instr(str2, str1) > 0 Then
MyStrCmp = "长度不同,有匹配字符存在。"
Else
MyStrCmp = "完全不同。"
End If
Exit Function
ElseIf
Len1 = Len2 Then
For
TmpFor = 1 To Len1
If Mid(str1, TmpFor, 1) <> Mid(str2, TmpFor, 1) Then Log = Log + 1
Next
If
Log = 0 Then
MyStrCmp = "长度相同,有 " & Log & " 个字符不同。"
Else
MyStrCmp = "完全相同。"
End If
Exit Function
End If
End Function



'窗体代码
Private Sub Form_Load()
HookMouse Me.hwnd
End Sub

Private Sub
Form_Unload(Cancel As Integer)
UnHookMouse Me.hwnd
End Sub



'模块代码
'***********************************************************
'mMouseWheel
'鼠标滚轮的事件检测
'***********************************************************
Option Explicit

Private Declare Function CallWindowProc Lib "User32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function
SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Private Const
GWL_WNDPROC = -4
Private Const WM_MOUSEWHEEL = &H20A

Global lpPrevWndProcA As Long

Public
bMouseFlag As Boolean '鼠标事件激活标志

Public Sub HookMouse(ByVal hwnd As Long)
lpPrevWndProcA = SetWindowLong(hwnd, GWL_WNDPROC,
AddressOf WindowProc)
End Sub

Public Sub
UnHookMouse(ByVal hwnd As Long)
SetWindowLong hwnd, GWL_WNDPROC, lpPrevWndProcA
End Sub

Private Function
WindowProc(ByVal hw As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case
uMsg
Case WM_MOUSEWHEEL '滚动
Dim wzDelta, wKeys As Integer
'wzDelta传递滚轮滚动的快慢,该值小于零表示滚轮向后滚动(朝用户方向),
'大于零表示滚轮向前滚动(朝显示器方向)
wzDelta = HIWORD(wParam)
'wKeys指出是否有CTRL=8、SHIFT=4、鼠标键(左=2、中=16、右=2、附加)按下,允许复合
wKeys = LOWORD(wParam)
'--------------------------------------------------
If wzDelta < 0 Then '朝用户方向
Form1.Cls
Form1.Print
"朝用户方向滚"
Else '朝显示器方向
Form1.Cls
Form1.Print
"朝显示器方向"
End If
'--------------------------------------------------
Case Else
WindowProc = CallWindowProc(lpPrevWndProcA, hw, uMsg, wParam, lParam)
End Select
End Function

Private Function
HIWORD(LongIn As Long) As Integer
HIWORD = (LongIn And &HFFFF0000) \ &H10000 '取出32位值的高16位
End Function
Private Function
LOWORD(LongIn As Long) As Integer
LOWORD = LongIn And &HFFFF& '取出32位值的低16位
End Function



'VB也可以使用CallBack,下面是一个例子:
'先把下面的代码放入BAS模块:
Option Explicit

'common to both methods
Public Type BROWSEINFO
hOwner
As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End
Type

Public Declare Function SHBrowseForFolder Lib _
"shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo
As BROWSEINFO) As Long

Public Declare Function
SHGetPathFromIDList Lib _
"shell32.dll" Alias "SHGetPathFromIDListA" _
(
ByVal pidl As Long, _
ByVal pszPath As String) As Long

Public Declare Sub
CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

Public Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(
ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam
As Any) As Long

Public Declare Sub
MoveMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(pDest
As Any, _
pSource
As Any, _
ByVal dwLength As Long)

Public Const MAX_PATH = 260
Public Const WM_USER = &H400
Public Const BFFM_INITIALIZED = 1

'Constants ending in 'A' are for Win95 ANSI
'calls; those ending in 'W' are the wide Unicode
'calls for NT.

'Sets the status text to the null-terminated
'string specified by the lParam parameter.
'wParam is ignored and should be set to 0.
Public Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Public Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)

'If the lParam parameter is non-zero, enables the
'OK button, or disables it if lParam is zero.
'(docs erroneously said wParam!)
'wParam is ignored and should be set to 0.
Public Const BFFM_ENABLEOK As Long = (WM_USER + 101)

'Selects the specified folder. If the wParam
'parameter is FALSE, the lParam parameter is the
'PIDL of the folder to select , or it is the path
'of the folder if wParam is the C value TRUE (or 1).
'Note that after this message is sent, the browse
'dialog receives a subsequent BFFM_SelectIONCHANGED
'message.
Public Const BFFM_SETSelectIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSelectIONW As Long = (WM_USER + 103)


'specific to the PIDL method
'Undocumented call for the example. IShellFolder's
'ParseDisplayName member function should be used instead.
Public Declare Function SHSimpleIDListFromPath Lib _
"shell32" Alias "#162" _
(
ByVal szPath As String) As Long


'specific to the STRING method
Public Declare Function LocalAlloc Lib "kernel32" _
(
ByVal uFlags As Long, _
ByVal uBytes As Long) As Long

Public Declare Function
LocalFree Lib "kernel32" _
(
ByVal hMem As Long) As Long

Public Declare Function
lstrcpyA Lib "kernel32" t color="#000000">_
(lpString1
As Any, lpString2 As Any) As Long

Public Declare Function
lstrlenA Lib "kernel32" _
(lpString
As Any) As Long

Public Const
LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)


Public Function BrowseCallbackProcStr(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long

'Callback for the Browse STRING method.

'On initialization, set the dialog's
'pre-selected folder from the pointer
'to the path allocated as bi.lParam,
'passed back to the callback as lpData param.

Select Case uMsg
Case BFFM_INITIALIZED

Call SendMessage(hWnd, BFFM_SETSelectIONA, _
True, ByVal StrFromPtrA(lpData))

Case Else:

End Select

End Function


Public Function
BrowseCallbackProc(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal lParam As Long, _
ByVal lpData As Long) As Long

'Callback for the Browse PIDL method.

'On initialization, set the dialog's
'pre-selected folder using the pidl
'set as the bi.lParam, and passed back
'to the callback as lpData param.

Select Case uMsg
Case BFFM_INITIALIZED

Call SendMessage(hWnd, BFFM_SETSelectIONA, _
False, ByVal lpData)

Case Else:

End Select

End Function


Public Function
FARPROC(pfn As Long) As Long

'A dummy procedure that receives and returns
'the value of the AddressOf operator.

'Obtain and set the address of the callback
'This workaround is needed as you can't assign
'AddressOf directly to a member of a user-
'defined type, but you can assign it to another
'long and use that (as returned here)

FARPROC = pfn

End Function


Public Function
StrFromPtrA(lpszA As Long) As String

'Returns an ANSI string from a pointer to an ANSI string.

Dim sRtn As String
sRtn = String$(lstrlenA(ByVal lpszA), 0)
Call lstrcpyA(ByVal sRtn, ByVal lpszA)
StrFromPtrA = sRtn

End Function

'--end block--'



'-----------------------------------------------------------------------------------------
'将下面代码加入窗体。窗体上还应放置三个按钮和两个TextBox。
'-----------------------------------------------------------------------------------------
Option Explicit

Private Sub cmdString_Click()
Text2 =
""
Text2 = BrowseForFolderByPath((Text1))
End Sub


Private Sub
cmdPIDL_Click()
Text2 =
""
Text2 = BrowseForFolderByPIDL((Text1))
End Sub


Private Sub
cmdEnd_Click()
Unload
Me
End Sub


Public Function
BrowseForFolderByPath(sSelPath As String) As String
Dim
BI As BROWSEINFO
Dim pidl As Long
Dim
lpSelPath As Long
Dim
sPath As String * MAX_PATH

With BI
.hOwner = Me.hWnd
.pidlRoot =
0
.lpszTitle = "Pre-selecting the folder using the folder's string."
.lpfn = FARPROC(AddressOf BrowseCallbackProcStr)

lpSelPath = LocalAlloc(LPTR, Len(sSelPath))
MoveMemory
ByVal lpSelPath, ByVal sSelPath, Len(sSelPath)
.lParam = lpSelPath

End With

pidl = SHBrowseForFolder(BI)

If p
idl
Then
If
SHGetPathFromIDList(pidl, sPath) Then
BrowseForFolderByPath = Left$(sPath, InStr(sPath, vbNullChar) - 1)
End If
Call
CoTaskMemFree(pidl)
End If

Call
LocalFree(lpSelPath)
End Function


Public Function
BrowseForFolderByPIDL(sSelPath As String) As String
Dim
BI As BROWSEINFO
Dim pidl As Long
Dim
sPath As String * MAX_PATH

With BI
.hOwner = Me.hWnd
.pidlRoot =
0
.lpszTitle = "Pre-selecting a folder using the folder's pidl."
.lpfn = FARPROC(AddressOf BrowseCallbackProc)
.lParam = SHSimpleIDListFromPath(sSelPath)
End With

pidl = SHBrowseForFolder(BI)

If pidl Then
If
SHGetPathFromIDList(pidl, sPath) Then
BrowseForFolderByPIDL = Left$(sPath, InStr(sPath, vbNullChar) - 1)
End If
Call
CoTaskMemFree(pidl)
End If

Call
CoTaskMemFree(BI.lParam)
End Function



Public Function chrConvert(strInput As String, Method As Integer) As String
' Method = 0 for Text to vbChr
' Method = 1 for Text to HTML
' Method = 2 for Text to Hex
' Method = 3 for vbChr to Text
' Method = 4 for HTML to Text
' Method = 5 for Hex to Text
If Method = 0 Or Method = 1 Or Method = 2 Then
chrConvert = ToChr(strInput, Method)
ElseIf Method = 3 Or Method = 4 Or Method = 5 Then
chrConvert = ToTxt(strInput, Method)
End If
End Function

Private Function
ToChr(strInput As String, Method As Integer) As String
strTmp = ""

For L = 1 To Len(strInput)
A = Asc(Mid(strInput, L,
1))
If Method = 0 Then
strTmp = strTmp & " & Chr(" & A & ")"
ElseIf Method = 1 Then
strTmp = strTmp & "&#" & A & ";"
ElseIf Method = 2 Then
strTmp = strTmp & "%" & Hex(A)
End If
Next
L
If Method = 0 Then strTmp = Right(strTmp, Len(strTmp) - 3)
ToChr = strTmp
End Function

Private Function
ToTxt(strInput As String, Method As Integer) As String
strTmp = ""
Dim inChr() As String
Dim
F As Integer, ForChr As Integer, tmpInput As String
If
Method = 3 Then
strInput = Replace(strInput, ")", "")
strInput = Replace(strInput,
" & ", "")
strInput = Replace(strInput,
"Chr(", "")
ElseIf Method = 4 Then
strInput = Replace(strInput, "&#", "")
strInput = Replace(strInput,
";", "")
ElseIf Method = 5 Then
strInput = Replace(strInput, "%", "")
End If
inChr = Split(strInput, "")

For F = 1 To ChrNum(strInput)
inChr(F) = AddZeros(
3 - Len(inChr(F))) & inChr(F)
tmpInput = tmpInput & inChr(F)
Next F

For L = 1 To Len(tmpInput)
A = Mid(tmpInput, L,
3)
If Method = 5 Then A = Val("&H" & A)
strTmp = strTmp & Chr(A)
L = L +
2
Next L
ToTxt = strTmp
End Function

Private Function
ChrNum(strInput As String) As Integer
Dim
lngLen As Long, lngFound As Long, lngEnd As Long
ChrNum = 0
lngLen& = Len(strInput$)
lngFound& = InStr(strInput$,
"")

Do While lngFound& <> 0
ChrNum = ChrNum + 1
lngFound& = InStr(lngFound& + 1, strInput$, "")
Loop
End Function

Private Function
AddZeros(Number As Integer) or="#0000FF">As String
Dim
Z As Integer, tmpZeros As String

For
Z = 1 To Number
tmpZeros = tmpZeros &
"0"
Next Z
AddZeros = tmpZeros
End Function