namespace
[转载]Microsof
'你只要在你的Form1随便添加一张图片, 不加也没事.
'***************************************** 淡进淡出
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Boolean
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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Const GWL_EXSTYLE = -20
Const WS_EX_LAYERED = &H80000
Const LWA_COLORKEY = &H1
Const LWA_ALPHA = &H2
Private Sub Form_Load()
Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
'***********************************************************************
Call SetWindowLong(Me.hWnd, GWL_EXSTYLE, GetWindowLong(Me.hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED)
Me.Show
DoEvents
lwa_FadeIn Me.hWnd, 1
End Sub
Private Sub Form_Unload(Cancel As Integer)
lwa_FadeOut Me.hWnd, 1
End
End Sub
'***************************************** 淡进
Public Sub lwa_FadeIn(ByVal hWnd As Long, Optional ByVal iStep As Integer = 1)
Dim bAlpha As Integer
bAlpha = 0
While bAlpha < 255
If bAlpha > 255 Then bAlpha = 255
SetLayeredWindowAttributes hWnd, 0, bAlpha, LWA_ALPHA
DoEvents
bAlpha = bAlpha + iStep
Wend
End Sub
'***************************************** 淡出
Public Sub lwa_FadeOut(ByVal hWnd As Long, Optional ByVal iStep As Integer = 1)
Dim bAlpha As Integer
bAlpha = 255
While bAlpha > 0
If bAlpha < 0 Then bAlpha = 0
SetLayeredWindowAttributes hWnd, 0, bAlpha, LWA_ALPHA
DoEvents
bAlpha = bAlpha - iStep
Wend
End Sub
给看不懂的初学者几句话:
你不必看懂上面的每一行代码, 更不需花脑子理解,你只要会用就好了
1.如果你有多个窗体就把
'***************************************** 淡进
'***************************************** 淡出
这两个标题下的代码把它们放在模块Module1.bas
放进去就好了,你不用再去看它们一眼,摆在那就行了.
2.同样的,也把下面这些摆在Module1.bas
放进去就好了,你不用再去看它们一眼,摆在那就行了.
(6F的代码是单一个Form,在下面是多个Form,把Private改为Public)
'***************************************** 淡进淡出
Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Boolean
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Const GWL_EXSTYLE = -20
Public Const WS_EX_LAYERED = &H80000
Public Const LWA_COLORKEY = &H1
Public Const LWA_ALPHA = &H2
************************************************************
上面动作就是复制与粘贴就好了, 你不用再去理它们了.
在每一个Form 的 Form_Load()事件就把下面代码贴上去,再加上你自己的一些东东就好啦.
Private Sub Form_Load()
Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
Call SetWindowLong(Me.hWnd, GWL_EXSTYLE, GetWindowLong(Me.hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED)
Me.Show
DoEvents
lwa_FadeIn Me.hWnd, 1
End Sub
'*********************************************
在每一个Form 的 Form_Unload()事件就把下面代码贴上去,再加上你自己的一些东东就好啦.
Private Sub Form_Unload(Cancel As Integer)
lwa_FadeOut Me.hWnd, 1
End
End Sub
*************************************************************
添加一个计时器timer1,Interval设置为10
添加一个模块,调用相应的API
模块源码为:
Public 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
Public Const HWND_TOPMOST& = -1
Public Const SWP_NOSIZE& = &H1
Public Const SWP_NOMOVE& = &H2
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Public Const WS_EX_LAYERED = &H80000
Public Const GWL_EXSTYLE = (-20)
Public Const LWA_ALPHA = &H2
Public Const LWA_COLORKEY = &H1
窗体源码为:
Public xx
'以下是让窗体出现时透明
Private Sub Form_Load()
rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong hwnd, GWL_EXSTYLE, rtn
SetLayeredWindowAttributes hwnd, 0, 0, LWA_ALPHA
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End Sub
'以下是浅入效果
Private Sub Timer1_Timer()
rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong hwnd, GWL_EXSTYLE, rtn
SetLayeredWindowAttributes hwnd, 0, xx, LWA_ALPHA
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
xx = xx + 1
If xx = 255 Then
Timer1.Interval = 0
Timer2.Interval = 10
End If
End Sub
'以下是浅出效果
Private Sub Timer2_Timer()
rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong hwnd, GWL_EXSTYLE, rtn
SetLayeredWindowAttributes hwnd, 0, xx, LWA_ALPHA
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
xx = xx - 1
If xx = 0 Then End
End Sub
VB中MD5算法(1)
调用方法：
程序的XP化已经不是一个新话题了，使用图片或ActiveX控件的比比皆是，但这样的XP化并不是真正的，只是模仿了XP的外观。使用. manifest文件倒是真的，不过在exe文件之外还要有一个.manifest文件，也不太方便，尤其是在做只有一个exe文件的小工具时。那么，能不能把.manifest文件整合到exe里面呢，经过测试，我终于发现了方法。
注意：有程序员用了本方法后反应没有效果，再此特别申明，这是真正的XP样式，使用的资源也是XP系统里的，所以要看到效果，必须是在XP系统，并使用XP风格样式时才行，Win2000的就不要试了，在系统不是XP外观时，用此方法生成的程序也不会有XP样式。另外，在VB IDE里面也不会有效果，需要编译为.exe文件。
下面我们来具体看一下实现的方法。请先下载本文附件的"XPStyle.res"文件，正常编辑程序界面后（如图），在工程资源管理器窗口的空白区域点鼠标右键，选择“添加”->“添加文件”，选择本文附件中的"XPStyle.res"，具体过程请参考附图。第二步，在程序中声明API函数 InitCommonControls，声明语句为Private Declare Sub InitCommonControls Lib "comctl32.dll" ()，在启动窗口的Initialize事件中调用此函数。注意，是Initialize事件，如果在Load事件中调用此函数将造成窗口不能被正确加载。现在将其编译为.exe文件就可以看到效果了。
这样实现的XP样式还有一个问题，就是如果把控件放在Frame控件里，将不能正常显示，尤其是OptionButton，将完全变成黑色。解决起来其实也不难，就是不要把控件做为Frame的子窗口，如果必须要这样做，可以在Frame里再添加一个PictureBox，将控件做为 PictureBox的子窗口。
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
代码
_______________________________________________________________
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Sub Form_Initialize()
InitCommonControls
End Sub
'***************************************** 淡进淡出
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Boolean
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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Const GWL_EXSTYLE = -20
Const WS_EX_LAYERED = &H80000
Const LWA_COLORKEY = &H1
Const LWA_ALPHA = &H2
Private Sub Form_Load()
Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
'***********************************************************************
Call SetWindowLong(Me.hWnd, GWL_EXSTYLE, GetWindowLong(Me.hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED)
Me.Show
DoEvents
lwa_FadeIn Me.hWnd, 1
End Sub
Private Sub Form_Unload(Cancel As Integer)
lwa_FadeOut Me.hWnd, 1
End
End Sub
'***************************************** 淡进
Public Sub lwa_FadeIn(ByVal hWnd As Long, Optional ByVal iStep As Integer = 1)
Dim bAlpha As Integer
bAlpha = 0
While bAlpha < 255
If bAlpha > 255 Then bAlpha = 255
SetLayeredWindowAttributes hWnd, 0, bAlpha, LWA_ALPHA
DoEvents
bAlpha = bAlpha + iStep
Wend
End Sub
'***************************************** 淡出
Public Sub lwa_FadeOut(ByVal hWnd As Long, Optional ByVal iStep As Integer = 1)
Dim bAlpha As Integer
bAlpha = 255
While bAlpha > 0
If bAlpha < 0 Then bAlpha = 0
SetLayeredWindowAttributes hWnd, 0, bAlpha, LWA_ALPHA
DoEvents
bAlpha = bAlpha - iStep
Wend
End Sub
给看不懂的初学者几句话:
你不必看懂上面的每一行代码, 更不需花脑子理解,你只要会用就好了
1.如果你有多个窗体就把
'***************************************** 淡进
'***************************************** 淡出
这两个标题下的代码把它们放在模块Module1.bas
放进去就好了,你不用再去看它们一眼,摆在那就行了.
2.同样的,也把下面这些摆在Module1.bas
放进去就好了,你不用再去看它们一眼,摆在那就行了.
(6F的代码是单一个Form,在下面是多个Form,把Private改为Public)
'***************************************** 淡进淡出
Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Boolean
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Const GWL_EXSTYLE = -20
Public Const WS_EX_LAYERED = &H80000
Public Const LWA_COLORKEY = &H1
Public Const LWA_ALPHA = &H2
************************************************************
上面动作就是复制与粘贴就好了, 你不用再去理它们了.
在每一个Form 的 Form_Load()事件就把下面代码贴上去,再加上你自己的一些东东就好啦.
Private Sub Form_Load()
Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
Call SetWindowLong(Me.hWnd, GWL_EXSTYLE, GetWindowLong(Me.hWnd, GWL_EXSTYLE) Or WS_EX_LAYERED)
Me.Show
DoEvents
lwa_FadeIn Me.hWnd, 1
End Sub
'*********************************************
在每一个Form 的 Form_Unload()事件就把下面代码贴上去,再加上你自己的一些东东就好啦.
Private Sub Form_Unload(Cancel As Integer)
lwa_FadeOut Me.hWnd, 1
End
End Sub
*************************************************************
添加一个计时器timer1,Interval设置为10
添加一个模块,调用相应的API
模块源码为:
Public 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
Public Const HWND_TOPMOST& = -1
Public Const SWP_NOSIZE& = &H1
Public Const SWP_NOMOVE& = &H2
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Public Const WS_EX_LAYERED = &H80000
Public Const GWL_EXSTYLE = (-20)
Public Const LWA_ALPHA = &H2
Public Const LWA_COLORKEY = &H1
窗体源码为:
Public xx
'以下是让窗体出现时透明
Private Sub Form_Load()
rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong hwnd, GWL_EXSTYLE, rtn
SetLayeredWindowAttributes hwnd, 0, 0, LWA_ALPHA
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
End Sub
'以下是浅入效果
Private Sub Timer1_Timer()
rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong hwnd, GWL_EXSTYLE, rtn
SetLayeredWindowAttributes hwnd, 0, xx, LWA_ALPHA
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
xx = xx + 1
If xx = 255 Then
Timer1.Interval = 0
Timer2.Interval = 10
End If
End Sub
'以下是浅出效果
Private Sub Timer2_Timer()
rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong hwnd, GWL_EXSTYLE, rtn
SetLayeredWindowAttributes hwnd, 0, xx, LWA_ALPHA
SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
xx = xx - 1
If xx = 0 Then End
End Sub
VB中MD5算法(1)
调用方法：
Private Sub Command1_Click()
Text2.Text = Md5_String_Calc(Text1.Text)
End Sub
Text2.Text = Md5_String_Calc(Text1.Text)
End Sub
' MD5加密类模块
Option Explicit
Private Const OFFSET_4 = 4294967296#
Private Const MAXINT_4 = 2147483647
Private State(4) As Long
Private ByteCounter As Long
Private ByteBuffer(63) As Byte
Private Const S11 = 7
Private Const S12 = 12
Private Const S13 = 17
Private Const S14 = 22
Private Const S21 = 5
Private Const S22 = 9
Private Const S23 = 14
Private Const S24 = 20
Private Const S31 = 4
Private Const S32 = 11
Private Const S33 = 16
Private Const S34 = 23
Private Const S41 = 6
Private Const S42 = 10
Private Const S43 = 15
Private Const S44 = 21
Property Get RegisterA() As String
RegisterA = State(1)
End Property
Property Get RegisterB() As String
RegisterB = State(2)
End Property
Property Get RegisterC() As String
RegisterC = State(3)
End Property
Property Get RegisterD() As String
RegisterD = State(4)
End Property
Public Function Md5_String_Calc(SourceString As String) As String
MD5Init
MD5Update LenB(StrConv(SourceString, vbFromUnicode)), StringToArray(SourceString)
MD5Final
Md5_String_Calc = GetValues
End Function
Public Function Md5_File_Calc(InFile As String) As String
On Error GoTo errorhandler
GoSub begin
errorhandler:
Md5_File_Calc = ""
Exit Function
begin:
Dim FileO As Integer
FileO = FreeFile
Call FileLen(InFile)
Open InFile For Binary Access Read As #FileO
MD5Init
Do While Not EOF(FileO)
Get #FileO, , ByteBuffer
If Loc(FileO) < LOF(FileO) Then
ByteCounter = ByteCounter + 64
MD5Transform ByteBuffer
End If
Loop
ByteCounter = ByteCounter + (LOF(FileO) Mod 64)
Close #FileO
MD5Final
Md5_File_Calc = GetValues
End Function
Private Function StringToArray(InString As String) As Byte()
Dim I As Integer, bytBuffer() As Byte
ReDim bytBuffer(LenB(StrConv(InString, vbFromUnicode)))
bytBuffer = StrConv(InString, vbFromUnicode)
StringToArray = bytBuffer
End Function
Public Function GetValues() As String
GetValues = LongToString(State(1)) & LongToString(State(2)) & LongToString(State(3)) & LongToString(State(4))
End Function
Private Function LongToString(Num As Long) As String
Dim A As Byte, B As Byte, C As Byte, d As Byte
A = Num And &HFF&
If A < 16 Then LongToString = "0" & Hex(A) Else LongToString = Hex(A)
B = (Num And &HFF00&) \ 256
If B < 16 Then LongToString = LongToString & "0" & Hex(B) Else LongToString = LongToString & Hex(B)
C = (Num And &HFF0000) \ 65536
If C < 16 Then LongToString = LongToString & "0" & Hex(C) Else LongToString = LongToString & Hex(C)
If Num < 0 Then d = ((Num And &H7F000000) \ 16777216) Or &H80& Else d = (Num And &HFF000000) \ 16777216
If d < 16 Then LongToString = LongToString & "0" & Hex(d) Else LongToString = LongToString & Hex(d)
End Function
Public Sub MD5Init()
ByteCounter = 0
State(1) = UnsignedToLong(1732584193#)
State(2) = UnsignedToLong(4023233417#)
State(3) = UnsignedToLong(2562383102#)
State(4) = UnsignedToLong(271733878#)
End Sub
Public Sub MD5Final()
Dim dblBits As Double, padding(72) As Byte, lngBytesBuffered As Long
padding(0) = &H80
dblBits = ByteCounter * 8
lngBytesBuffered = ByteCounter Mod 64
If lngBytesBuffered <= 56 Then MD5Update 56 - lngBytesBuffered, padding Else MD5Update 120 - ByteCounter, padding
padding(0) = UnsignedToLong(dblBits) And &HFF&
padding(1) = UnsignedToLong(dblBits) \ 256 And &HFF&
padding(2) = UnsignedToLong(dblBits) \ 65536 And &HFF&
padding(3) = UnsignedToLong(dblBits) \ 16777216 And &HFF&
padding(4) = 0
padding(5) = 0
padding(6) = 0
padding(7) = 0
MD5Update 8, padding
End Sub
Public Sub MD5Update(InputLen As Long, InputBuffer() As Byte)
Dim II As Integer, I As Integer, J As Integer, K As Integer, lngBufferedBytes As Long, lngBufferRemaining As Long, lngRem As Long
lngBufferedBytes = ByteCounter Mod 64
lngBufferRemaining = 64 - lngBufferedBytes
ByteCounter = ByteCounter + InputLen
If InputLen >= lngBufferRemaining Then
For II = 0 To lngBufferRemaining - 1
ByteBuffer(lngBufferedBytes + II) = InputBuffer(II)
Next II
MD5Transform ByteBuffer
lngRem = (InputLen) Mod 64
For I = lngBufferRemaining To InputLen - II - lngRem Step 64
For J = 0 To 63
ByteBuffer(J) = InputBuffer(I + J)
Next J
MD5Transform ByteBuffer
Next I
lngBufferedBytes = 0
Else
I = 0
End If
For K = 0 To InputLen - I - 1
ByteBuffer(lngBufferedBytes + K) = InputBuffer(I + K)
Next K
End Sub
Private Sub MD5Transform(Buffer() As Byte)
Dim X(16) As Long, A As Long, B As Long, C As Long, d As Long
A = State(1)
B = State(2)
C = State(3)
d = State(4)
Decode 64, X, Buffer
FF A, B, C, d, X(0), S11, -680876936
FF d, A, B, C, X(1), S12, -389564586
FF C, d, A, B, X(2), S13, 606105819
FF B, C, d, A, X(3), S14, -1044525330
FF A, B, C, d, X(4), S11, -176418897
FF d, A, B, C, X(5), S12, 1200080426
FF C, d, A, B, X(6), S13, -1473231341
FF B, C, d, A, X(7), S14, -45705983
FF A, B, C, d, X(8), S11, 1770035416
FF d, A, B, C, X(9), S12, -1958414417
FF C, d, A, B, X(10), S13, -42063
FF B, C, d, A, X(11), S14, -1990404162
FF A, B, C, d, X(12), S11, 1804603682
FF d, A, B, C, X(13), S12, -40341101
FF C, d, A, B, X(14), S13, -1502002290
FF B, C, d, A, X(15), S14, 1236535329
GG A, B, C, d, X(1), S21, -165796510
GG d, A, B, C, X(6), S22, -1069501632
GG C, d, A, B, X(11), S23, 643717713
GG B, C, d, A, X(0), S24, -373897302
GG A, B, C, d, X(5), S21, -701558691
GG d, A, B, C, X(10), S22, 38016083
GG C, d, A, B, X(15), S23, -660478335
GG B, C, d, A, X(4), S24, -405537848
GG A, B, C, d, X(9), S21, 568446438
GG d, A, B, C, X(14), S22, -1019803690
GG C, d, A, B, X(3), S23, -187363961
GG B, C, d, A, X(8), S24, 1163531501
GG A, B, C, d, X(13), S21, -1444681467
GG d, A, B, C, X(2), S22, -51403784
GG C, d, A, B, X(7), S23, 1735328473
GG B, C, d, A, X(12), S24, -1926607734
HH A, B, C, d, X(5), S31, -378558
HH d, A, B, C, X(8), S32, -2022574463
HH C, d, A, B, X(11), S33, 1839030562
HH B, C, d, A, X(14), S34, -35309556
HH A, B, C, d, X(1), S31, -1530992060
HH d, A, B, C, X(4), S32, 1272893353
HH C, d, A, B, X(7), S33, -155497632
HH B, C, d, A, X(10), S34, -1094730640
HH A, B, C, d, X(13), S31, 681279174
HH d, A, B, C, X(0), S32, -358537222
HH C, d, A, B, X(3), S33, -722521979
HH B, C, d, A, X(6), S34, 76029189
HH A, B, C, d, X(9), S31, -640364487
HH d, A, B, C, X(12), S32, -421815835
HH C, d, A, B, X(15), S33, 530742520
HH B, C, d, A, X(2), S34, -995338651
II A, B, C, d, X(0), S41, -198630844
II d, A, B, C, X(7), S42, 1126891415
II C, d, A, B, X(14), S43, -1416354905
II B, C, d, A, X(5), S44, -57434055
II A, B, C, d, X(12), S41, 1700485571
II d, A, B, C, X(3), S42, -1894986606
II C, d, A, B, X(10), S43, -1051523
II B, C, d, A, X(1), S44, -2054922799
II A, B, C, d, X(8), S41, 1873313359
II d, A, B, C, X(15), S42, -30611744
II C, d, A, B, X(6), S43, -1560198380
II B, C, d, A, X(13), S44, 1309151649
II A, B, C, d, X(4), S41, -145523070
II d, A, B, C, X(11), S42, -1120210379
II C, d, A, B, X(2), S43, 718787259
II B, C, d, A, X(9), S44, -343485551
State(1) = LongOverflowAdd(State(1), A)
State(2) = LongOverflowAdd(State(2), B)
State(3) = LongOverflowAdd(State(3), C)
State(4) = LongOverflowAdd(State(4), d)
End Sub
Private Sub Decode(Length As Integer, OutputBuffer() As Long, InputBuffer() As Byte)
Dim intDblIndex As Integer, intByteIndex As Integer, dblSum As Double
For intByteIndex = 0 To Length - 1 Step 4
dblSum = InputBuffer(intByteIndex) + InputBuffer(intByteIndex + 1) * 256# + InputBuffer(intByteIndex + 2) * 65536# + InputBuffer(intByteIndex + 3) * 16777216#
OutputBuffer(intDblIndex) = UnsignedToLong(dblSum)
intDblIndex = intDblIndex + 1
Next intByteIndex
End Sub
Private Function FF(A As Long, B As Long, C As Long, d As Long, X As Long, S As Long, ac As Long) As Long
A = LongOverflowAdd4(A, (B And C) Or (Not (B) And d), X, ac)
A = LongLeftRotate(A, S)
A = LongOverflowAdd(A, B)
End Function
Private Function GG(A As Long, B As Long, C As Long, d As Long, X As Long, S As Long, ac As Long) As Long
A = LongOverflowAdd4(A, (B And d) Or (C And Not (d)), X, ac)
A = LongLeftRotate(A, S)
A = LongOverflowAdd(A, B)
End Function
Private Function HH(A As Long, B As Long, C As Long, d As Long, X As Long, S As Long, ac As Long) As Long
A = LongOverflowAdd4(A, B Xor C Xor d, X, ac)
A = LongLeftRotate(A, S)
A = LongOverflowAdd(A, B)
End Function
Private Function II(A As Long, B As Long, C As Long, d As Long, X As Long, S As Long, ac As Long) As Long
A = LongOverflowAdd4(A, C Xor (B Or Not (d)), X, ac)
A = LongLeftRotate(A, S)
A = LongOverflowAdd(A, B)
End Function
Function LongLeftRotate(value As Long, Bits As Long) As Long
Dim lngSign As Long, lngI As Long
Bits = Bits Mod 32
If Bits = 0 Then LongLeftRotate = value: Exit Function
For lngI = 1 To Bits
lngSign = value And &HC0000000
value = (value And &H3FFFFFFF) * 2
value = value Or ((lngSign < 0) And 1) Or (CBool(lngSign And &H40000000) And &H80000000)
Next
LongLeftRotate = value
End Function
Private Function LongOverflowAdd(Val1 As Long, Val2 As Long) As Long
Dim lngHighWord As Long, lngLowWord As Long, lngOverflow As Long
lngLowWord = (Val1 And &HFFFF&) + (Val2 And &HFFFF&)
lngOverflow = lngLowWord \ 65536
lngHighWord = (((Val1 And &HFFFF0000) \ 65536) + ((Val2 And &HFFFF0000) \ 65536) + lngOverflow) And &HFFFF&
LongOverflowAdd = UnsignedToLong((lngHighWord * 65536#) + (lngLowWord And &HFFFF&))
End Function
Private Function LongOverflowAdd4(Val1 As Long, Val2 As Long, val3 As Long, val4 As Long) As Long
Dim lngHighWord As Long, lngLowWord As Long, lngOverflow As Long
lngLowWord = (Val1 And &HFFFF&) + (Val2 And &HFFFF&) + (val3 And &HFFFF&) + (val4 And &HFFFF&)
lngOverflow = lngLowWord \ 65536
lngHighWord = (((Val1 And &HFFFF0000) \ 65536) + ((Val2 And &HFFFF0000) \ 65536) + ((val3 And &HFFFF0000) \ 65536) + ((val4 And &HFFFF0000) \ 65536) + lngOverflow) And &HFFFF&
LongOverflowAdd4 = UnsignedToLong((lngHighWord * 65536#) + (lngLowWord And &HFFFF&))
End Function
Private Function UnsignedToLong(value As Double) As Long
If value < 0 Or value >= OFFSET_4 Then Error 6
If value <= MAXINT_4 Then UnsignedToLong = value Else UnsignedToLong = value - OFFSET_4
End Function
Private Function LongToUnsigned(value As Long) As Double
If value < 0 Then LongToUnsigned = value + OFFSET_4 Else LongToUnsigned = value
End Function
Option Explicit
Private Const OFFSET_4 = 4294967296#
Private Const MAXINT_4 = 2147483647
Private State(4) As Long
Private ByteCounter As Long
Private ByteBuffer(63) As Byte
Private Const S11 = 7
Private Const S12 = 12
Private Const S13 = 17
Private Const S14 = 22
Private Const S21 = 5
Private Const S22 = 9
Private Const S23 = 14
Private Const S24 = 20
Private Const S31 = 4
Private Const S32 = 11
Private Const S33 = 16
Private Const S34 = 23
Private Const S41 = 6
Private Const S42 = 10
Private Const S43 = 15
Private Const S44 = 21
Property Get RegisterA() As String
RegisterA = State(1)
End Property
Property Get RegisterB() As String
RegisterB = State(2)
End Property
Property Get RegisterC() As String
RegisterC = State(3)
End Property
Property Get RegisterD() As String
RegisterD = State(4)
End Property
Public Function Md5_String_Calc(SourceString As String) As String
MD5Init
MD5Update LenB(StrConv(SourceString, vbFromUnicode)), StringToArray(SourceString)
MD5Final
Md5_String_Calc = GetValues
End Function
Public Function Md5_File_Calc(InFile As String) As String
On Error GoTo errorhandler
GoSub begin
errorhandler:
Md5_File_Calc = ""
Exit Function
begin:
Dim FileO As Integer
FileO = FreeFile
Call FileLen(InFile)
Open InFile For Binary Access Read As #FileO
MD5Init
Do While Not EOF(FileO)
Get #FileO, , ByteBuffer
If Loc(FileO) < LOF(FileO) Then
ByteCounter = ByteCounter + 64
MD5Transform ByteBuffer
End If
Loop
ByteCounter = ByteCounter + (LOF(FileO) Mod 64)
Close #FileO
MD5Final
Md5_File_Calc = GetValues
End Function
Private Function StringToArray(InString As String) As Byte()
Dim I As Integer, bytBuffer() As Byte
ReDim bytBuffer(LenB(StrConv(InString, vbFromUnicode)))
bytBuffer = StrConv(InString, vbFromUnicode)
StringToArray = bytBuffer
End Function
Public Function GetValues() As String
GetValues = LongToString(State(1)) & LongToString(State(2)) & LongToString(State(3)) & LongToString(State(4))
End Function
Private Function LongToString(Num As Long) As String
Dim A As Byte, B As Byte, C As Byte, d As Byte
A = Num And &HFF&
If A < 16 Then LongToString = "0" & Hex(A) Else LongToString = Hex(A)
B = (Num And &HFF00&) \ 256
If B < 16 Then LongToString = LongToString & "0" & Hex(B) Else LongToString = LongToString & Hex(B)
C = (Num And &HFF0000) \ 65536
If C < 16 Then LongToString = LongToString & "0" & Hex(C) Else LongToString = LongToString & Hex(C)
If Num < 0 Then d = ((Num And &H7F000000) \ 16777216) Or &H80& Else d = (Num And &HFF000000) \ 16777216
If d < 16 Then LongToString = LongToString & "0" & Hex(d) Else LongToString = LongToString & Hex(d)
End Function
Public Sub MD5Init()
ByteCounter = 0
State(1) = UnsignedToLong(1732584193#)
State(2) = UnsignedToLong(4023233417#)
State(3) = UnsignedToLong(2562383102#)
State(4) = UnsignedToLong(271733878#)
End Sub
Public Sub MD5Final()
Dim dblBits As Double, padding(72) As Byte, lngBytesBuffered As Long
padding(0) = &H80
dblBits = ByteCounter * 8
lngBytesBuffered = ByteCounter Mod 64
If lngBytesBuffered <= 56 Then MD5Update 56 - lngBytesBuffered, padding Else MD5Update 120 - ByteCounter, padding
padding(0) = UnsignedToLong(dblBits) And &HFF&
padding(1) = UnsignedToLong(dblBits) \ 256 And &HFF&
padding(2) = UnsignedToLong(dblBits) \ 65536 And &HFF&
padding(3) = UnsignedToLong(dblBits) \ 16777216 And &HFF&
padding(4) = 0
padding(5) = 0
padding(6) = 0
padding(7) = 0
MD5Update 8, padding
End Sub
Public Sub MD5Update(InputLen As Long, InputBuffer() As Byte)
Dim II As Integer, I As Integer, J As Integer, K As Integer, lngBufferedBytes As Long, lngBufferRemaining As Long, lngRem As Long
lngBufferedBytes = ByteCounter Mod 64
lngBufferRemaining = 64 - lngBufferedBytes
ByteCounter = ByteCounter + InputLen
If InputLen >= lngBufferRemaining Then
For II = 0 To lngBufferRemaining - 1
ByteBuffer(lngBufferedBytes + II) = InputBuffer(II)
Next II
MD5Transform ByteBuffer
lngRem = (InputLen) Mod 64
For I = lngBufferRemaining To InputLen - II - lngRem Step 64
For J = 0 To 63
ByteBuffer(J) = InputBuffer(I + J)
Next J
MD5Transform ByteBuffer
Next I
lngBufferedBytes = 0
Else
I = 0
End If
For K = 0 To InputLen - I - 1
ByteBuffer(lngBufferedBytes + K) = InputBuffer(I + K)
Next K
End Sub
Private Sub MD5Transform(Buffer() As Byte)
Dim X(16) As Long, A As Long, B As Long, C As Long, d As Long
A = State(1)
B = State(2)
C = State(3)
d = State(4)
Decode 64, X, Buffer
FF A, B, C, d, X(0), S11, -680876936
FF d, A, B, C, X(1), S12, -389564586
FF C, d, A, B, X(2), S13, 606105819
FF B, C, d, A, X(3), S14, -1044525330
FF A, B, C, d, X(4), S11, -176418897
FF d, A, B, C, X(5), S12, 1200080426
FF C, d, A, B, X(6), S13, -1473231341
FF B, C, d, A, X(7), S14, -45705983
FF A, B, C, d, X(8), S11, 1770035416
FF d, A, B, C, X(9), S12, -1958414417
FF C, d, A, B, X(10), S13, -42063
FF B, C, d, A, X(11), S14, -1990404162
FF A, B, C, d, X(12), S11, 1804603682
FF d, A, B, C, X(13), S12, -40341101
FF C, d, A, B, X(14), S13, -1502002290
FF B, C, d, A, X(15), S14, 1236535329
GG A, B, C, d, X(1), S21, -165796510
GG d, A, B, C, X(6), S22, -1069501632
GG C, d, A, B, X(11), S23, 643717713
GG B, C, d, A, X(0), S24, -373897302
GG A, B, C, d, X(5), S21, -701558691
GG d, A, B, C, X(10), S22, 38016083
GG C, d, A, B, X(15), S23, -660478335
GG B, C, d, A, X(4), S24, -405537848
GG A, B, C, d, X(9), S21, 568446438
GG d, A, B, C, X(14), S22, -1019803690
GG C, d, A, B, X(3), S23, -187363961
GG B, C, d, A, X(8), S24, 1163531501
GG A, B, C, d, X(13), S21, -1444681467
GG d, A, B, C, X(2), S22, -51403784
GG C, d, A, B, X(7), S23, 1735328473
GG B, C, d, A, X(12), S24, -1926607734
HH A, B, C, d, X(5), S31, -378558
HH d, A, B, C, X(8), S32, -2022574463
HH C, d, A, B, X(11), S33, 1839030562
HH B, C, d, A, X(14), S34, -35309556
HH A, B, C, d, X(1), S31, -1530992060
HH d, A, B, C, X(4), S32, 1272893353
HH C, d, A, B, X(7), S33, -155497632
HH B, C, d, A, X(10), S34, -1094730640
HH A, B, C, d, X(13), S31, 681279174
HH d, A, B, C, X(0), S32, -358537222
HH C, d, A, B, X(3), S33, -722521979
HH B, C, d, A, X(6), S34, 76029189
HH A, B, C, d, X(9), S31, -640364487
HH d, A, B, C, X(12), S32, -421815835
HH C, d, A, B, X(15), S33, 530742520
HH B, C, d, A, X(2), S34, -995338651
II A, B, C, d, X(0), S41, -198630844
II d, A, B, C, X(7), S42, 1126891415
II C, d, A, B, X(14), S43, -1416354905
II B, C, d, A, X(5), S44, -57434055
II A, B, C, d, X(12), S41, 1700485571
II d, A, B, C, X(3), S42, -1894986606
II C, d, A, B, X(10), S43, -1051523
II B, C, d, A, X(1), S44, -2054922799
II A, B, C, d, X(8), S41, 1873313359
II d, A, B, C, X(15), S42, -30611744
II C, d, A, B, X(6), S43, -1560198380
II B, C, d, A, X(13), S44, 1309151649
II A, B, C, d, X(4), S41, -145523070
II d, A, B, C, X(11), S42, -1120210379
II C, d, A, B, X(2), S43, 718787259
II B, C, d, A, X(9), S44, -343485551
State(1) = LongOverflowAdd(State(1), A)
State(2) = LongOverflowAdd(State(2), B)
State(3) = LongOverflowAdd(State(3), C)
State(4) = LongOverflowAdd(State(4), d)
End Sub
Private Sub Decode(Length As Integer, OutputBuffer() As Long, InputBuffer() As Byte)
Dim intDblIndex As Integer, intByteIndex As Integer, dblSum As Double
For intByteIndex = 0 To Length - 1 Step 4
dblSum = InputBuffer(intByteIndex) + InputBuffer(intByteIndex + 1) * 256# + InputBuffer(intByteIndex + 2) * 65536# + InputBuffer(intByteIndex + 3) * 16777216#
OutputBuffer(intDblIndex) = UnsignedToLong(dblSum)
intDblIndex = intDblIndex + 1
Next intByteIndex
End Sub
Private Function FF(A As Long, B As Long, C As Long, d As Long, X As Long, S As Long, ac As Long) As Long
A = LongOverflowAdd4(A, (B And C) Or (Not (B) And d), X, ac)
A = LongLeftRotate(A, S)
A = LongOverflowAdd(A, B)
End Function
Private Function GG(A As Long, B As Long, C As Long, d As Long, X As Long, S As Long, ac As Long) As Long
A = LongOverflowAdd4(A, (B And d) Or (C And Not (d)), X, ac)
A = LongLeftRotate(A, S)
A = LongOverflowAdd(A, B)
End Function
Private Function HH(A As Long, B As Long, C As Long, d As Long, X As Long, S As Long, ac As Long) As Long
A = LongOverflowAdd4(A, B Xor C Xor d, X, ac)
A = LongLeftRotate(A, S)
A = LongOverflowAdd(A, B)
End Function
Private Function II(A As Long, B As Long, C As Long, d As Long, X As Long, S As Long, ac As Long) As Long
A = LongOverflowAdd4(A, C Xor (B Or Not (d)), X, ac)
A = LongLeftRotate(A, S)
A = LongOverflowAdd(A, B)
End Function
Function LongLeftRotate(value As Long, Bits As Long) As Long
Dim lngSign As Long, lngI As Long
Bits = Bits Mod 32
If Bits = 0 Then LongLeftRotate = value: Exit Function
For lngI = 1 To Bits
lngSign = value And &HC0000000
value = (value And &H3FFFFFFF) * 2
value = value Or ((lngSign < 0) And 1) Or (CBool(lngSign And &H40000000) And &H80000000)
Next
LongLeftRotate = value
End Function
Private Function LongOverflowAdd(Val1 As Long, Val2 As Long) As Long
Dim lngHighWord As Long, lngLowWord As Long, lngOverflow As Long
lngLowWord = (Val1 And &HFFFF&) + (Val2 And &HFFFF&)
lngOverflow = lngLowWord \ 65536
lngHighWord = (((Val1 And &HFFFF0000) \ 65536) + ((Val2 And &HFFFF0000) \ 65536) + lngOverflow) And &HFFFF&
LongOverflowAdd = UnsignedToLong((lngHighWord * 65536#) + (lngLowWord And &HFFFF&))
End Function
Private Function LongOverflowAdd4(Val1 As Long, Val2 As Long, val3 As Long, val4 As Long) As Long
Dim lngHighWord As Long, lngLowWord As Long, lngOverflow As Long
lngLowWord = (Val1 And &HFFFF&) + (Val2 And &HFFFF&) + (val3 And &HFFFF&) + (val4 And &HFFFF&)
lngOverflow = lngLowWord \ 65536
lngHighWord = (((Val1 And &HFFFF0000) \ 65536) + ((Val2 And &HFFFF0000) \ 65536) + ((val3 And &HFFFF0000) \ 65536) + ((val4 And &HFFFF0000) \ 65536) + lngOverflow) And &HFFFF&
LongOverflowAdd4 = UnsignedToLong((lngHighWord * 65536#) + (lngLowWord And &HFFFF&))
End Function
Private Function UnsignedToLong(value As Double) As Long
If value < 0 Or value >= OFFSET_4 Then Error 6
If value <= MAXINT_4 Then UnsignedToLong = value Else UnsignedToLong = value - OFFSET_4
End Function
Private Function LongToUnsigned(value As Long) As Double
If value < 0 Then LongToUnsigned = value + OFFSET_4 Else LongToUnsigned = value
End Function
程序的XP化已经不是一个新话题了，使用图片或ActiveX控件的比比皆是，但这样的XP化并不是真正的，只是模仿了XP的外观。使用. manifest文件倒是真的，不过在exe文件之外还要有一个.manifest文件，也不太方便，尤其是在做只有一个exe文件的小工具时。那么，能不能把.manifest文件整合到exe里面呢，经过测试，我终于发现了方法。
注意：有程序员用了本方法后反应没有效果，再此特别申明，这是真正的XP样式，使用的资源也是XP系统里的，所以要看到效果，必须是在XP系统，并使用XP风格样式时才行，Win2000的就不要试了，在系统不是XP外观时，用此方法生成的程序也不会有XP样式。另外，在VB IDE里面也不会有效果，需要编译为.exe文件。
下面我们来具体看一下实现的方法。请先下载本文附件的"XPStyle.res"文件，正常编辑程序界面后（如图），在工程资源管理器窗口的空白区域点鼠标右键，选择“添加”->“添加文件”，选择本文附件中的"XPStyle.res"，具体过程请参考附图。第二步，在程序中声明API函数 InitCommonControls，声明语句为Private Declare Sub InitCommonControls Lib "comctl32.dll" ()，在启动窗口的Initialize事件中调用此函数。注意，是Initialize事件，如果在Load事件中调用此函数将造成窗口不能被正确加载。现在将其编译为.exe文件就可以看到效果了。
这样实现的XP样式还有一个问题，就是如果把控件放在Frame控件里，将不能正常显示，尤其是OptionButton，将完全变成黑色。解决起来其实也不难，就是不要把控件做为Frame的子窗口，如果必须要这样做，可以在Frame里再添加一个PictureBox，将控件做为 PictureBox的子窗口。
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
代码
_______________________________________________________________
Private Declare Sub InitCommonControls Lib "comctl32.dll" ()
Private Sub Form_Initialize()
InitCommonControls
End Sub
