昨天散分，想让大家谈感想。好象效果不太好。
今天这样，号召大家向cooly大侠学习，先看看下面这一贴。
http://expert.csdn.net/Expert/topic/1555/1555609.xml?temp=5.865115E-02
明白了吧？
大家有什么好的东西，贴出来给菜鸟分享。不需太高深，不要太复杂。简短实用就行。
每段代码5分。收集20个好东西。
当然高手是不在乎分数的。高手也都是热心肠的人。在这里也只是想让大家多交流一下。
高手棒场啊。
46 个解决方案
#1
我带个头~~~~ 分儿就不用给了~~~~
下面是昨天帮别人改的一段Quoted Printable编码转换函数。
Public Function QpDecode(inString As String) As String
Dim myB As Byte
Dim myByte1 As Byte, myByte2 As Byte
Dim convStr() As Byte
Dim mOutByte As Byte
Dim FinishPercent As Long
Dim TotalB, k As Long
Dim tmpByte As Byte
convStr = StrConv(inString, vbFromUnicode)
TotalB = UBound(convStr)
For k = 0 To TotalB
myB = convStr(k)
If myB = Asc("=") Then
k = k + 1
myByte1 = convStr(k)
If myByte1 = &HA Then
'如果是回车,继续
Else
'取第二个字节
k = k + 1
myByte2 = convStr(k)
Call DecodeByte(myByte1, myByte2, mOutByte)
If mOutByte >= 127 Then
If tmpByte <> 0 Then
QpDecode = QpDecode & Chr(Val("&H" & Hex(tmpByte) & Hex(mOutByte)))
tmpByte = 0
Else
tmpByte = mOutByte
End If
Else
QpDecode = QpDecode & Chr(mOutByte)
tmpByte = 0
End If
End If
Else
mOutByte = myB
QpDecode = QpDecode & Chr(mOutByte)
End If
Next
End Function
Private Sub DecodeByte(mInByte1 As Byte, mInByte2 As Byte, mOutByte As Byte)
Dim tbyte1 As Integer, tbyte2 As Integer
If mInByte1 > Asc("9") Then
tbyte1 = mInByte1 - Asc("A") + 10
Else
tbyte1 = mInByte1 - Asc("0")
End If
If mInByte2 > Asc("9") Then
tbyte2 = mInByte2 - Asc("A") + 10
Else
tbyte2 = mInByte2 - Asc("0")
End If
mOutByte = tbyte1 * 16 + tbyte2
End Sub
Private Sub EncodeByte(mInByte As Byte, mOutStr As String)
If (mInByte >= 33 And mInByte <= 60) Or (mInByte >= 62 And mInByte <= 126) Then
mOutStr = Chr(mInByte)
Else
If mInByte <= &HF Then
mOutStr = "=0" & Hex(mInByte)
Else
mOutStr = "=" & Hex(mInByte)
End If
End If
End Sub
Public Function QpEncode(inString As String) As String
Dim myB As Byte
Dim convByte() As Byte
Dim mOutStr As String
Dim FinishPercent As Long
Dim TotalB, k As Long
convByte = StrConv(inString, vbFromUnicode)
TotalB = UBound(convByte)
For k = 0 To TotalB
myB = convByte(k)
EncodeByte myB, mOutStr
QpEncode = QpEncode & mOutStr
Next
End Function
Private Sub Command1_Click()
MsgBox QpDecode("=B2=E2=CA=D4=D2=BB")
End Sub
Private Sub Command2_Click()
MsgBox QpEncode("测试一")
End Sub
下面是昨天帮别人改的一段Quoted Printable编码转换函数。
Public Function QpDecode(inString As String) As String
Dim myB As Byte
Dim myByte1 As Byte, myByte2 As Byte
Dim convStr() As Byte
Dim mOutByte As Byte
Dim FinishPercent As Long
Dim TotalB, k As Long
Dim tmpByte As Byte
convStr = StrConv(inString, vbFromUnicode)
TotalB = UBound(convStr)
For k = 0 To TotalB
myB = convStr(k)
If myB = Asc("=") Then
k = k + 1
myByte1 = convStr(k)
If myByte1 = &HA Then
'如果是回车,继续
Else
'取第二个字节
k = k + 1
myByte2 = convStr(k)
Call DecodeByte(myByte1, myByte2, mOutByte)
If mOutByte >= 127 Then
If tmpByte <> 0 Then
QpDecode = QpDecode & Chr(Val("&H" & Hex(tmpByte) & Hex(mOutByte)))
tmpByte = 0
Else
tmpByte = mOutByte
End If
Else
QpDecode = QpDecode & Chr(mOutByte)
tmpByte = 0
End If
End If
Else
mOutByte = myB
QpDecode = QpDecode & Chr(mOutByte)
End If
Next
End Function
Private Sub DecodeByte(mInByte1 As Byte, mInByte2 As Byte, mOutByte As Byte)
Dim tbyte1 As Integer, tbyte2 As Integer
If mInByte1 > Asc("9") Then
tbyte1 = mInByte1 - Asc("A") + 10
Else
tbyte1 = mInByte1 - Asc("0")
End If
If mInByte2 > Asc("9") Then
tbyte2 = mInByte2 - Asc("A") + 10
Else
tbyte2 = mInByte2 - Asc("0")
End If
mOutByte = tbyte1 * 16 + tbyte2
End Sub
Private Sub EncodeByte(mInByte As Byte, mOutStr As String)
If (mInByte >= 33 And mInByte <= 60) Or (mInByte >= 62 And mInByte <= 126) Then
mOutStr = Chr(mInByte)
Else
If mInByte <= &HF Then
mOutStr = "=0" & Hex(mInByte)
Else
mOutStr = "=" & Hex(mInByte)
End If
End If
End Sub
Public Function QpEncode(inString As String) As String
Dim myB As Byte
Dim convByte() As Byte
Dim mOutStr As String
Dim FinishPercent As Long
Dim TotalB, k As Long
convByte = StrConv(inString, vbFromUnicode)
TotalB = UBound(convByte)
For k = 0 To TotalB
myB = convByte(k)
EncodeByte myB, mOutStr
QpEncode = QpEncode & mOutStr
Next
End Function
Private Sub Command1_Click()
MsgBox QpDecode("=B2=E2=CA=D4=D2=BB")
End Sub
Private Sub Command2_Click()
MsgBox QpEncode("测试一")
End Sub
#2
Rem ===============API Function Define==============================
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
Rem ===============API Constant Define =============================
Private Const GWL_STYLE = (-16) 'Window field offset
Rem ===============The below constant is not exist in win32api.txt==
Private Const BS_BITMAP& = &H80& 'show bitmap in button
Private Const BS_BOTTOM& = &H800& 'button caption seted bottom
Private Const BS_CENTER& = &H300& 'button caption seted center
Private Const BS_ICON& = &H40& 'show icon in button
Private Const BS_LEFT& = &H100& 'button caption seted left
Private Const BS_RIGHT& = &H200& 'button caption seted RIGHT
Private Const BS_MULTILINE& = &H2000& 'button caption seted multiline
Private Const BS_NOTIFY& = &H4000& '
Private Const BS_PUSHLIKE& = &H1000& 'make style of checkbox and optionbox same with button
Private Const BS_TOP& = &H400& 'button caption seted TOP
Private Const BS_VCENTER& = &HC00& 'button caption seted vertical and center
Rem ===============Custom Define Variable============================
Rem -----------------------------------------------------------------
Rem this argument used to CaptionAlignment function
Private Const ca_HorizontalCenter = 0
Private Const ca_VerticalCenter = 1
Private Const ca_Left = 2
Private Const ca_Right = 3
Private Const ca_Top = 4
Private Const ca_Bottom = 5
Private Const ca_Default = 6
Rem ----------------------------------------------------------------
Private oldBtnStyle As Long
Private SetFlg As Boolean
Private AlignmentStyle&
'Alignment button caption
'Argument :
' btnhWnd button handle
' AlignmentStyle 0 default) Horizontal center
' 1) Vertical center
' 2) Alignment left
' 3) Alignment Right
' 4) Alignment top
' 5) Alignment bottom
' 6) restore original style
'@Note : only use to button text
Public Function CaptionAlignment(ByVal btnhWnd As Long, Optional AlignmentStyle As Integer = 0) As Boolean
Dim lngStyle As Long
Dim lngAlignment As Long
Dim Rtn&
On Error GoTo Alignment_Error
If btnhWnd = 0 Then GoTo Alignment_Error
CaptionAlignment = True
If Not SetFlg Then
SetFlg = True
oldBtnStyle = GetWindowLong(btnhWnd, GWL_STYLE) 'get original style
End If
Select Case AlignmentStyle
Case ca_HorizontalCenter 'horizontal center
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not (BS_LEFT Or BS_RIGHT)
lngAlignment = BS_CENTER
Case ca_VerticalCenter 'vertical center
lngAlignment = BS_CENTER
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not (BS_TOP Or BS_BOTTOM)
Case ca_Left 'left
lngAlignment = BS_LEFT
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not BS_RIGHT
Case ca_Right 'right
lngAlignment = BS_RIGHT
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not BS_LEFT
Case ca_Top 'top
lngAlignment = BS_TOP
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not BS_BOTTOM
Case ca_Bottom 'bottom
lngAlignment = BS_BOTTOM
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not BS_TOP
Case ca_Default 'restore original style
lngAlignment = oldBtnStyle
If lngAlignment = 0 Then Exit Function
Rtn = SetWindowLong(btnhWnd, GWL_STYLE, lngAlignment)
Exit Function
End Select
'set position
Rtn = SetWindowLong(btnhWnd, GWL_STYLE, lngStyle Or lngAlignment)
Exit Function
Alignment_Error:
CaptionAlignment = False
End Function
这是command控件caption德对齐方式。
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
Rem ===============API Constant Define =============================
Private Const GWL_STYLE = (-16) 'Window field offset
Rem ===============The below constant is not exist in win32api.txt==
Private Const BS_BITMAP& = &H80& 'show bitmap in button
Private Const BS_BOTTOM& = &H800& 'button caption seted bottom
Private Const BS_CENTER& = &H300& 'button caption seted center
Private Const BS_ICON& = &H40& 'show icon in button
Private Const BS_LEFT& = &H100& 'button caption seted left
Private Const BS_RIGHT& = &H200& 'button caption seted RIGHT
Private Const BS_MULTILINE& = &H2000& 'button caption seted multiline
Private Const BS_NOTIFY& = &H4000& '
Private Const BS_PUSHLIKE& = &H1000& 'make style of checkbox and optionbox same with button
Private Const BS_TOP& = &H400& 'button caption seted TOP
Private Const BS_VCENTER& = &HC00& 'button caption seted vertical and center
Rem ===============Custom Define Variable============================
Rem -----------------------------------------------------------------
Rem this argument used to CaptionAlignment function
Private Const ca_HorizontalCenter = 0
Private Const ca_VerticalCenter = 1
Private Const ca_Left = 2
Private Const ca_Right = 3
Private Const ca_Top = 4
Private Const ca_Bottom = 5
Private Const ca_Default = 6
Rem ----------------------------------------------------------------
Private oldBtnStyle As Long
Private SetFlg As Boolean
Private AlignmentStyle&
'Alignment button caption
'Argument :
' btnhWnd button handle
' AlignmentStyle 0 default) Horizontal center
' 1) Vertical center
' 2) Alignment left
' 3) Alignment Right
' 4) Alignment top
' 5) Alignment bottom
' 6) restore original style
'@Note : only use to button text
Public Function CaptionAlignment(ByVal btnhWnd As Long, Optional AlignmentStyle As Integer = 0) As Boolean
Dim lngStyle As Long
Dim lngAlignment As Long
Dim Rtn&
On Error GoTo Alignment_Error
If btnhWnd = 0 Then GoTo Alignment_Error
CaptionAlignment = True
If Not SetFlg Then
SetFlg = True
oldBtnStyle = GetWindowLong(btnhWnd, GWL_STYLE) 'get original style
End If
Select Case AlignmentStyle
Case ca_HorizontalCenter 'horizontal center
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not (BS_LEFT Or BS_RIGHT)
lngAlignment = BS_CENTER
Case ca_VerticalCenter 'vertical center
lngAlignment = BS_CENTER
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not (BS_TOP Or BS_BOTTOM)
Case ca_Left 'left
lngAlignment = BS_LEFT
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not BS_RIGHT
Case ca_Right 'right
lngAlignment = BS_RIGHT
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not BS_LEFT
Case ca_Top 'top
lngAlignment = BS_TOP
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not BS_BOTTOM
Case ca_Bottom 'bottom
lngAlignment = BS_BOTTOM
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not BS_TOP
Case ca_Default 'restore original style
lngAlignment = oldBtnStyle
If lngAlignment = 0 Then Exit Function
Rtn = SetWindowLong(btnhWnd, GWL_STYLE, lngAlignment)
Exit Function
End Select
'set position
Rtn = SetWindowLong(btnhWnd, GWL_STYLE, lngStyle Or lngAlignment)
Exit Function
Alignment_Error:
CaptionAlignment = False
End Function
这是command控件caption德对齐方式。
#3
Rem =====================API Function Define=========================================================================
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 GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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 Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Rem =====================API Constant Define=========================================================================
Private Const HWND_BOTTOM = 1 'set to bottom of Z ordering
Private Const HWND_NOTOPMOST = -2 'not topmost
Private Const HWND_TOPMOST = -1 'set to top of all window
Private Const HWND_TOP = 0 'Set to Top of Z ordering
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'below constant is used to GetWindowLong function
Private Const GWL_STYLE = (-16) 'Window field offset
Private Const GWL_EXSTYLE = (-20)
Private Const GWL_HINSTANCE = (-6)
Private Const GWL_HWNDPARENT = (-8)
Private Const GWL_ID = (-12)
Private Const GWL_USERDATA = (-21)
Private Const GWL_WNDPROC = (-4)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const WS_CAPTION = &HC00000 ' WS_BORDER Or WS_DLGFRAME
Private Const WS_BORDER = &H800000
Private Const WS_CHILD = &H40000000
Private Const WS_CHILDWINDOW = (WS_CHILD)
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_DISABLED = &H8000000
Private Const WS_DLGFRAME = &H400000
Private Const WS_EX_ACCEPTFILES = &H10&
Private Const WS_EX_DLGMODALFRAME = &H1&
Private Const WS_EX_NOPARENTNOTIFY = &H4&
Private Const WS_EX_TOPMOST = &H8&
Private Const WS_EX_TRANSPARENT = &H20&
Private Const WS_GROUP = &H20000
Private Const WS_HSCROLL = &H100000
Private Const WS_MAXIMIZE = &H1000000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_ICONIC = WS_MINIMIZE
Private Const WS_OVERLAPPED = &H0&
Private Const WS_POPUP = &H80000000
Private Const WS_SYSMENU = &H80000
Private Const WS_POPUPWINDOW = (WS_POPUP Or WS_BORDER Or WS_SYSMENU)
Private Const WS_TABSTOP = &H10000
Private Const WS_THICKFRAME = &H40000
Private Const WS_TILED = WS_OVERLAPPED
Private Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
Private Const WS_TILEDWINDOW = WS_OVERLAPPEDWINDOW
Private Const WS_SIZEBOX = WS_THICKFRAME
Private Const WS_VISIBLE = &H10000000
Private Const WS_VSCROLL = &H200000
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const WM_USER = &H400
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_MBUTTONDOWN = &H207
Private Const WM_MBUTTONUP = &H208
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Rem =====================API Type Define=============================================================================
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'this enumerable type is used to SetWindowPos function
Private Enum WndPosStyle
SWP_FRAMECHANGED = &H20 ' The frame changed: send WM_NCCALCSIZE
SWP_DRAWFRAME = SWP_FRAMECHANGED
SWP_HIDEWINDOW = &H80
SWP_NOACTIVATE = &H10
SWP_NOCOPYBITS = &H100
SWP_NOMOVE = &H2
SWP_NOOWNERZORDER = &H200 ' Don't do owner Z ordering
SWP_NOREDRAW = &H8
SWP_NOREPOSITION = SWP_NOOWNERZORDER
SWP_NOSIZE = &H1
SWP_NOZORDER = &H4
SWP_SHOWWINDOW = &H40
End Enum
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Rem =====================Custom Define Variable======================================================================
Private mWndRect As RECT
Private mWndCaption As String
'--------------------------------------------------------------------------------------------------------------------
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'$$ set ordering for window $$
'$$ hWnd handle of window $$
'$$ orderflg ordering style $$
'$$ 0) set to bottom of $$
'$$ Z ordering $$
'$$ 1) not topmost $$
'$$ 2) Set to Top of Z ordering$$
'$$ 3) set to top of all window$$
'$$ ReturnValue $$
'$$ true success $$
'$$ false fail $$
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
Public Function SetWindowOrder(ByVal hwnd As Long, Optional OrderFlg As Integer = 0) As Boolean
Dim Style As Long
Dim Rtn&
Dim X As Long
Dim Y As Long
Dim WndWidth As Long
Dim WndHeight As Long
Dim wFlag As Long
'first get rectangle of window
Rtn = GetWindowRect(hwnd, mWndRect)
If Rtn Then
'success
wFlag = SWP_SHOWWINDOW
With mWndRect
X = .Left
Y = .Top
WndWidth = .Right - .Left
WndHeight = .Bottom - .Top
End With
Else
'fail,ingore (X,Y,CX,CY) argument
wFlag = SWP_NOMOVE Or SWP_NOSIZE
End If
Select Case OrderFlg
Case 0 'set to bottom of Z ordering
Style = HWND_BOTTOM
Case 1 'not topmost
Style = HWND_NOTOPMOST
Case 2 'Set to Top of Z ordering
Style = HWND_TOP
Case 3 'set to top of all window
Style = HWND_TOPMOST
End Select
SetWindowOrder = SetWindowPos(hwnd, Style, X, Y, WndWidth, WndHeight, wFlag)
End Function
这是改变窗体z-order顺的函数
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 GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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 Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Rem =====================API Constant Define=========================================================================
Private Const HWND_BOTTOM = 1 'set to bottom of Z ordering
Private Const HWND_NOTOPMOST = -2 'not topmost
Private Const HWND_TOPMOST = -1 'set to top of all window
Private Const HWND_TOP = 0 'Set to Top of Z ordering
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'below constant is used to GetWindowLong function
Private Const GWL_STYLE = (-16) 'Window field offset
Private Const GWL_EXSTYLE = (-20)
Private Const GWL_HINSTANCE = (-6)
Private Const GWL_HWNDPARENT = (-8)
Private Const GWL_ID = (-12)
Private Const GWL_USERDATA = (-21)
Private Const GWL_WNDPROC = (-4)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const WS_CAPTION = &HC00000 ' WS_BORDER Or WS_DLGFRAME
Private Const WS_BORDER = &H800000
Private Const WS_CHILD = &H40000000
Private Const WS_CHILDWINDOW = (WS_CHILD)
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_DISABLED = &H8000000
Private Const WS_DLGFRAME = &H400000
Private Const WS_EX_ACCEPTFILES = &H10&
Private Const WS_EX_DLGMODALFRAME = &H1&
Private Const WS_EX_NOPARENTNOTIFY = &H4&
Private Const WS_EX_TOPMOST = &H8&
Private Const WS_EX_TRANSPARENT = &H20&
Private Const WS_GROUP = &H20000
Private Const WS_HSCROLL = &H100000
Private Const WS_MAXIMIZE = &H1000000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_ICONIC = WS_MINIMIZE
Private Const WS_OVERLAPPED = &H0&
Private Const WS_POPUP = &H80000000
Private Const WS_SYSMENU = &H80000
Private Const WS_POPUPWINDOW = (WS_POPUP Or WS_BORDER Or WS_SYSMENU)
Private Const WS_TABSTOP = &H10000
Private Const WS_THICKFRAME = &H40000
Private Const WS_TILED = WS_OVERLAPPED
Private Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
Private Const WS_TILEDWINDOW = WS_OVERLAPPEDWINDOW
Private Const WS_SIZEBOX = WS_THICKFRAME
Private Const WS_VISIBLE = &H10000000
Private Const WS_VSCROLL = &H200000
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const WM_USER = &H400
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_MBUTTONDOWN = &H207
Private Const WM_MBUTTONUP = &H208
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Rem =====================API Type Define=============================================================================
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'this enumerable type is used to SetWindowPos function
Private Enum WndPosStyle
SWP_FRAMECHANGED = &H20 ' The frame changed: send WM_NCCALCSIZE
SWP_DRAWFRAME = SWP_FRAMECHANGED
SWP_HIDEWINDOW = &H80
SWP_NOACTIVATE = &H10
SWP_NOCOPYBITS = &H100
SWP_NOMOVE = &H2
SWP_NOOWNERZORDER = &H200 ' Don't do owner Z ordering
SWP_NOREDRAW = &H8
SWP_NOREPOSITION = SWP_NOOWNERZORDER
SWP_NOSIZE = &H1
SWP_NOZORDER = &H4
SWP_SHOWWINDOW = &H40
End Enum
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Rem =====================Custom Define Variable======================================================================
Private mWndRect As RECT
Private mWndCaption As String
'--------------------------------------------------------------------------------------------------------------------
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'$$ set ordering for window $$
'$$ hWnd handle of window $$
'$$ orderflg ordering style $$
'$$ 0) set to bottom of $$
'$$ Z ordering $$
'$$ 1) not topmost $$
'$$ 2) Set to Top of Z ordering$$
'$$ 3) set to top of all window$$
'$$ ReturnValue $$
'$$ true success $$
'$$ false fail $$
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
Public Function SetWindowOrder(ByVal hwnd As Long, Optional OrderFlg As Integer = 0) As Boolean
Dim Style As Long
Dim Rtn&
Dim X As Long
Dim Y As Long
Dim WndWidth As Long
Dim WndHeight As Long
Dim wFlag As Long
'first get rectangle of window
Rtn = GetWindowRect(hwnd, mWndRect)
If Rtn Then
'success
wFlag = SWP_SHOWWINDOW
With mWndRect
X = .Left
Y = .Top
WndWidth = .Right - .Left
WndHeight = .Bottom - .Top
End With
Else
'fail,ingore (X,Y,CX,CY) argument
wFlag = SWP_NOMOVE Or SWP_NOSIZE
End If
Select Case OrderFlg
Case 0 'set to bottom of Z ordering
Style = HWND_BOTTOM
Case 1 'not topmost
Style = HWND_NOTOPMOST
Case 2 'Set to Top of Z ordering
Style = HWND_TOP
Case 3 'set to top of all window
Style = HWND_TOPMOST
End Select
SetWindowOrder = SetWindowPos(hwnd, Style, X, Y, WndWidth, WndHeight, wFlag)
End Function
这是改变窗体z-order顺的函数
#4
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'$$ take out the caption bar of window $$
'$$ hWnd handle of form $$
'$$ ThrowOffFlg:optional argument $$
'$$ true god rid of the caption $$
'$$ false restore original caption $$
'$$ ReturnValue $$
'$$ True success $$
'$$ False fail $$
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
Public Function ThrowOffWndCaption(ByVal hwnd As Long, Optional ThrowOffFlg As Boolean = True) As Boolean
Dim lStyle As Long
Dim Rtn&
Dim wFlags As Long
ThrowOffWndCaption = True
'set new style for window
wFlags = SWP_NOMOVE Or SWP_NOSIZE Or SWP_FRAMECHANGED Or SWP_NOREPOSITION Or SWP_NOZORDER
mWndCaption = String(255, 0)
'first get caption or window
Rtn = GetWindowText(hwnd, mWndCaption, Len(mWndCaption))
If Rtn >= 0 Then mWndCaption = Left(mWndCaption, Rtn)
'get original style of window
lStyle = GetWindowLong(hwnd, GWL_STYLE)
If (ThrowOffFlg) Then 'god rid of the caption
lStyle = lStyle And Not WS_CAPTION
lStyle = lStyle And Not WS_MAXIMIZEBOX
lStyle = lStyle And Not WS_MINIMIZEBOX
lStyle = lStyle And Not WS_SYSMENU
Else 'restore original caption
lStyle = lStyle Or WS_CAPTION
lStyle = lStyle Or WS_MAXIMIZEBOX
lStyle = lStyle Or WS_MINIMIZEBOX
lStyle = lStyle Or WS_SYSMENU
'set original caption of window
If mWndCaption <> "" Then Rtn = SetWindowText(hwnd, mWndCaption)
End If
'set new style for window
Rtn = SetWindowLong(hwnd, GWL_STYLE, lStyle)
If Rtn < 0 Then GoTo ThrowOff_Error
'set position for window
Rtn = SetWindowPos(hwnd, 0&, 0, 0, 0, 0, wFlags)
If Rtn < 0 Then GoTo ThrowOff_Error
Exit Function
ThrowOff_Error:
ThrowOffWndCaption = False
End Function
这是去掉或恢复窗体标题的函数。
'$$ take out the caption bar of window $$
'$$ hWnd handle of form $$
'$$ ThrowOffFlg:optional argument $$
'$$ true god rid of the caption $$
'$$ false restore original caption $$
'$$ ReturnValue $$
'$$ True success $$
'$$ False fail $$
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
Public Function ThrowOffWndCaption(ByVal hwnd As Long, Optional ThrowOffFlg As Boolean = True) As Boolean
Dim lStyle As Long
Dim Rtn&
Dim wFlags As Long
ThrowOffWndCaption = True
'set new style for window
wFlags = SWP_NOMOVE Or SWP_NOSIZE Or SWP_FRAMECHANGED Or SWP_NOREPOSITION Or SWP_NOZORDER
mWndCaption = String(255, 0)
'first get caption or window
Rtn = GetWindowText(hwnd, mWndCaption, Len(mWndCaption))
If Rtn >= 0 Then mWndCaption = Left(mWndCaption, Rtn)
'get original style of window
lStyle = GetWindowLong(hwnd, GWL_STYLE)
If (ThrowOffFlg) Then 'god rid of the caption
lStyle = lStyle And Not WS_CAPTION
lStyle = lStyle And Not WS_MAXIMIZEBOX
lStyle = lStyle And Not WS_MINIMIZEBOX
lStyle = lStyle And Not WS_SYSMENU
Else 'restore original caption
lStyle = lStyle Or WS_CAPTION
lStyle = lStyle Or WS_MAXIMIZEBOX
lStyle = lStyle Or WS_MINIMIZEBOX
lStyle = lStyle Or WS_SYSMENU
'set original caption of window
If mWndCaption <> "" Then Rtn = SetWindowText(hwnd, mWndCaption)
End If
'set new style for window
Rtn = SetWindowLong(hwnd, GWL_STYLE, lStyle)
If Rtn < 0 Then GoTo ThrowOff_Error
'set position for window
Rtn = SetWindowPos(hwnd, 0&, 0, 0, 0, 0, wFlags)
If Rtn < 0 Then GoTo ThrowOff_Error
Exit Function
ThrowOff_Error:
ThrowOffWndCaption = False
End Function
这是去掉或恢复窗体标题的函数。
#5
保存图片到数据库
private sub save()
Dim Chunk() As Byte
Filename="a.jpg"
Chunk() = Image2Chunk(Filename)
rs.Fields("thumb").AppendChunk Chunk()
rs.Update
end sub
Private Function Image2Chunk(Filename As String) As Variant
On Error GoTo ProcErr
Dim Datafile As Integer
Dim FileLength As Long
Dim Chunk() As Byte
Datafile = FreeFile
Open Filename For Binary Access Read As Datafile
FileLength = LOF(Datafile)
If FileLength = 0 Then GoTo ProcErr
ReDim Chunk(FileLength)
Get Datafile, , Chunk()
Close Datafile
ProcExit:
Image2Chunk = Chunk()
Exit Function
ProcErr:
Image2Chunk = 0
End Function
private sub save()
Dim Chunk() As Byte
Filename="a.jpg"
Chunk() = Image2Chunk(Filename)
rs.Fields("thumb").AppendChunk Chunk()
rs.Update
end sub
Private Function Image2Chunk(Filename As String) As Variant
On Error GoTo ProcErr
Dim Datafile As Integer
Dim FileLength As Long
Dim Chunk() As Byte
Datafile = FreeFile
Open Filename For Binary Access Read As Datafile
FileLength = LOF(Datafile)
If FileLength = 0 Then GoTo ProcErr
ReDim Chunk(FileLength)
Get Datafile, , Chunk()
Close Datafile
ProcExit:
Image2Chunk = Chunk()
Exit Function
ProcErr:
Image2Chunk = 0
End Function
#6
有两位高手捧场了，真是荣幸，还是这样散分的效果好。大侠们慢慢整理啊，不急，我先离开一段时间，等20个好东西收齐。
#7
下面以问答方式给出一些简单常用问题：
问：如何让VB应用程序中的连接具有超级链接效果？
答：我们以一个网址链接为例，讲解实现的方法。
首先我们新建一表单,在表单中加入一标签,Caption属性为http://ses518.8u8.com/，MouseIcon值为操作系统下Curors目录里的Hand.ico文件，MousePointer值为99。
在标签的MouseMove事件中加入如下代码:
Label1.ForeColor=&&HFF
在表单的MouseMove事件中加入如下代码:
Label1.ForeColor=&&HFF0000
在标签的Click事件中加入如下代码:
Dim a As String
a=Shell("Explorer.exe http://ses518.8u8.com/",3)
问：在VB应用程序中，如何取消窗体右上角的关闭功能？
答：如果你不想别人使用程序时直接用右上角的关闭功能来关闭程序,可用以下代码来实现该功能。
在Form_Unload事件中加入代码:Cancel=True即可。
即:Private Sub Form_Unload(Cancel As Integer)
Cancel=True
End Sub
如果你想在关闭程序时提示是否关闭,可在Form_Unload事件中加入一个判断语句：
Private Sub Form_Unload(Cancel As Integer)
Cancel=True
Select Case msgbox ("您真的想关闭吗?" ,VbOkCancel) '应加上括号，要用到返回值，所以以函数格式调用
Case VbOk
Cancel=False
Case Else
Cancel=True
End Select
End Sub
问：如何在VB应用程序下关闭其它运行的Windows程序？
答：如果你想用自己的程序关闭正在运行的Windows其它程序,可用以下代码来实现。
首先声明两个函数:
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function PostMessage Lib "user32" Alias "PostMessageA"(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
例如要检测“计算器”程序是否正在运行，如果是则关闭它，可以使用如下代码来实现:
Dim winHwnd As Long
Dim RetVal As Long
winHwnd=FindWindow(vbNullString,"计算器")
If winHwnd〈〉0 Then
RetVal = PostMessage(winHwnd, &&H10, 0&&, 0&&)
If RetVal = 0 Then
MsgBox "关闭计算器出错!"
End If
Else
MsgBox "计算器程序没有运行。"
End If
问：在应用程序中如何编程实现禁用热键(包括Ctrl+Alt+Delete和所有功能键)？
答：如果你想做个屏保或禁止别人使用热键(包括Ctrl+Alt+Delete),以下代码可以实现：
首先定义一常量：
Private Const SPI_SCREENSAVERRUNNING = 97&&
进行函数声明：
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long,lpvParam As Any,ByVal fuWinIni As Long) As Long
再定义一个子过程：
Public Sub AllowKeys(bParam As Boolean)
Dim lRetVal As Long, bOld As Boolean
lRetVal = SystemParametersInfo(SPI_SCREENSAVERRUNNING, bParam, bOld, 0&&)
End Sub
最后，在任意事件中加入AllowKeys(True/False),当AllowKeys为真时会禁止所有热键。
问：在VB应用程序中，如何实现窗体的简易移动？
答：如果你的窗体不需要标题栏,又希望能移动它,像WinAmp一样,有个简易移动,我们可以利用以下代码实现：
Declare Function ReleaseCapture Lib "user32" () As Long
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 Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &&HA1
下面是将功能加入窗体的MouseDowm事件中,你也可将其加入其它控件的事件中：
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'以下二行代码可加入各控件的MouseDown之中
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&&
窗体在屏幕中居中代码:
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
希望对大家有所帮助~!!!
问：如何让VB应用程序中的连接具有超级链接效果？
答：我们以一个网址链接为例，讲解实现的方法。
首先我们新建一表单,在表单中加入一标签,Caption属性为http://ses518.8u8.com/，MouseIcon值为操作系统下Curors目录里的Hand.ico文件，MousePointer值为99。
在标签的MouseMove事件中加入如下代码:
Label1.ForeColor=&&HFF
在表单的MouseMove事件中加入如下代码:
Label1.ForeColor=&&HFF0000
在标签的Click事件中加入如下代码:
Dim a As String
a=Shell("Explorer.exe http://ses518.8u8.com/",3)
问：在VB应用程序中，如何取消窗体右上角的关闭功能？
答：如果你不想别人使用程序时直接用右上角的关闭功能来关闭程序,可用以下代码来实现该功能。
在Form_Unload事件中加入代码:Cancel=True即可。
即:Private Sub Form_Unload(Cancel As Integer)
Cancel=True
End Sub
如果你想在关闭程序时提示是否关闭,可在Form_Unload事件中加入一个判断语句：
Private Sub Form_Unload(Cancel As Integer)
Cancel=True
Select Case msgbox ("您真的想关闭吗?" ,VbOkCancel) '应加上括号，要用到返回值，所以以函数格式调用
Case VbOk
Cancel=False
Case Else
Cancel=True
End Select
End Sub
问：如何在VB应用程序下关闭其它运行的Windows程序？
答：如果你想用自己的程序关闭正在运行的Windows其它程序,可用以下代码来实现。
首先声明两个函数:
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function PostMessage Lib "user32" Alias "PostMessageA"(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
例如要检测“计算器”程序是否正在运行，如果是则关闭它，可以使用如下代码来实现:
Dim winHwnd As Long
Dim RetVal As Long
winHwnd=FindWindow(vbNullString,"计算器")
If winHwnd〈〉0 Then
RetVal = PostMessage(winHwnd, &&H10, 0&&, 0&&)
If RetVal = 0 Then
MsgBox "关闭计算器出错!"
End If
Else
MsgBox "计算器程序没有运行。"
End If
问：在应用程序中如何编程实现禁用热键(包括Ctrl+Alt+Delete和所有功能键)？
答：如果你想做个屏保或禁止别人使用热键(包括Ctrl+Alt+Delete),以下代码可以实现：
首先定义一常量：
Private Const SPI_SCREENSAVERRUNNING = 97&&
进行函数声明：
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long,lpvParam As Any,ByVal fuWinIni As Long) As Long
再定义一个子过程：
Public Sub AllowKeys(bParam As Boolean)
Dim lRetVal As Long, bOld As Boolean
lRetVal = SystemParametersInfo(SPI_SCREENSAVERRUNNING, bParam, bOld, 0&&)
End Sub
最后，在任意事件中加入AllowKeys(True/False),当AllowKeys为真时会禁止所有热键。
问：在VB应用程序中，如何实现窗体的简易移动？
答：如果你的窗体不需要标题栏,又希望能移动它,像WinAmp一样,有个简易移动,我们可以利用以下代码实现：
Declare Function ReleaseCapture Lib "user32" () As Long
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 Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &&HA1
下面是将功能加入窗体的MouseDowm事件中,你也可将其加入其它控件的事件中：
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'以下二行代码可加入各控件的MouseDown之中
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&&
窗体在屏幕中居中代码:
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
希望对大家有所帮助~!!!
#8
保存图片到数据库，也是我的问题，看到不少网友问过这个问题（就是刚才在网易的社区里还有人发贴问呢）。谢了。
#9
可能一些人需要这个
用ADO创建Access数据库
作者: QinJia 浏览: 59 次
当我们写完一个数据库应用程序时必须作成安装盘发行，在制作安装盘时因为顾及到数据库的安装，我们一般将数据库也加到数据库中去，但我们也碰到一些问题，如果该数据库应用程序是针对某一用户而开发的话那就没有什么问题，当您开发的是一个软件时您就不可能将该数据库放到安装盘去了，必须用代码来生成该数据库。这个生成数据库的方法在DAO的年代非常的容易，但随着VB6和ACCESS2000的到来我们是不是应该用新的方法来创建呢？我们当然应该用ADO来创建数据库了，但可惜的是用ADODB来创建他根本是不可能的，因为ADODB中根本没有DATABASE这个对象，不用说创建DATABASE了，就连创建TABLE都难，原因是一样的因为ADODB不支持FIELD对象，创建TABLE还可以用SQL语句和ADODB中的Excute创建，但创建数据库就难了，以下我就介绍一下用ADO创建数据库的方法.
一、用VB6新建一工程，然后引用 ADOX,（ADOX是ACCESS2000自带的，可以在VB6的引用中找到Microsoft ADO2.1 Ext For DLL and Security,引用它）关于ADX的对象、属性以及方法你可以到ACCESS2000的帮助中找到。
二、打开工程，创建数据库的代码如下：
Sub CreateDatabase()
'Reference Microsoft ADO Extensions for DDL and Security (Install by Access2000)
Dim cat As New ADOX.Catalog
cat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\new.mdb"
End Sub
你可以在主程序中调用该程序用以创建数据库,程序中的红色部分即为数据库的路径以及名称。
以上程序在VB6英文企业版SP3中调试通过。
用ADO创建Access数据库
作者: QinJia 浏览: 59 次
当我们写完一个数据库应用程序时必须作成安装盘发行，在制作安装盘时因为顾及到数据库的安装，我们一般将数据库也加到数据库中去，但我们也碰到一些问题，如果该数据库应用程序是针对某一用户而开发的话那就没有什么问题，当您开发的是一个软件时您就不可能将该数据库放到安装盘去了，必须用代码来生成该数据库。这个生成数据库的方法在DAO的年代非常的容易，但随着VB6和ACCESS2000的到来我们是不是应该用新的方法来创建呢？我们当然应该用ADO来创建数据库了，但可惜的是用ADODB来创建他根本是不可能的，因为ADODB中根本没有DATABASE这个对象，不用说创建DATABASE了，就连创建TABLE都难，原因是一样的因为ADODB不支持FIELD对象，创建TABLE还可以用SQL语句和ADODB中的Excute创建，但创建数据库就难了，以下我就介绍一下用ADO创建数据库的方法.
一、用VB6新建一工程，然后引用 ADOX,（ADOX是ACCESS2000自带的，可以在VB6的引用中找到Microsoft ADO2.1 Ext For DLL and Security,引用它）关于ADX的对象、属性以及方法你可以到ACCESS2000的帮助中找到。
二、打开工程，创建数据库的代码如下：
Sub CreateDatabase()
'Reference Microsoft ADO Extensions for DDL and Security (Install by Access2000)
Dim cat As New ADOX.Catalog
cat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\new.mdb"
End Sub
你可以在主程序中调用该程序用以创建数据库,程序中的红色部分即为数据库的路径以及名称。
以上程序在VB6英文企业版SP3中调试通过。
#10
在发一个
如何使用 ADO 來压缩或修复 Microsoft Access 文件
以前使用 DAO 時，Microsoft 有提供 CompactDatabase Method 來压缩 Microsoft Access 文件，RepairDatabase Method 來修复损坏的 Microsoft Access 文件，。可是自从 ADO 出來之后，好像忘了提供相对的压缩及修复 Microsoft Access 文件的功能。
現在 Microsoft 发现了这个问题了，也提供了解決方法，不过有版本上的限制！限制說明如下：
ActiveX Data Objects (ADO), version 2.1
Microsoft OLE DB Provider for Jet, version 4.0
這是 Microsoft 提出的 ADO 的延伸功能：Microsoft Jet OLE DB Provider and Replication Objects (JRO)
这个功能在 JET OLE DB Provider version 4.0 (Msjetoledb40.dll) 及 JRO version 2.1 (Msjro.dll) 中第一次被提出！
這些必要的 DLL 文件在您安裝了 MDAC 2.1 之后就有了，您可以在以下的网页中下载 MDAC 的最新版本！
Universal Data Access Web Site
在下载之前先到 VB6 中檢查一下，【控件】【設定引用項目】中的 Microsoft Jet and Replication Objects X.X library 如果已经是 2.1 以上的版本，您就可以不用下载了！
在您安裝了 MDAC 2.1 或以上的版本之后，您就可以使用 ADO 來压缩或修复 Microsoft Access 文件，下面的步骤告訴您如何使用 CompactDatabase Method 來压缩 Microsoft Access 文件：
1、新建一個新表单，选择功能表中的【控件】【設定引用項目】。
2、加入 Microsoft Jet and Replication Objects X.X library，其中 ( X.X 大于或等于 2.1 )。
3、在适当的地方加入以下的程序代码，記得要修改 data source 的內容及目地文件的路径：
Dim jro As jro.JetEngine
Set jro = New jro.JetEngine
jro.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d:\\nwind2.mdb", _ '來源文件
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d:\\abbc2.mdb;Jet OLEDB:Engine Type=4" '目的文件
在 DAO 3.60 之后，RepairDatabase Method 已经无法使用了，以上的程序代码显示了 ADO CompactDatabase Method 的用法，而它也取代了 DAO 3.5 時的 RepairDatabase method！
如何使用 ADO 來压缩或修复 Microsoft Access 文件
以前使用 DAO 時，Microsoft 有提供 CompactDatabase Method 來压缩 Microsoft Access 文件，RepairDatabase Method 來修复损坏的 Microsoft Access 文件，。可是自从 ADO 出來之后，好像忘了提供相对的压缩及修复 Microsoft Access 文件的功能。
現在 Microsoft 发现了这个问题了，也提供了解決方法，不过有版本上的限制！限制說明如下：
ActiveX Data Objects (ADO), version 2.1
Microsoft OLE DB Provider for Jet, version 4.0
這是 Microsoft 提出的 ADO 的延伸功能：Microsoft Jet OLE DB Provider and Replication Objects (JRO)
这个功能在 JET OLE DB Provider version 4.0 (Msjetoledb40.dll) 及 JRO version 2.1 (Msjro.dll) 中第一次被提出！
這些必要的 DLL 文件在您安裝了 MDAC 2.1 之后就有了，您可以在以下的网页中下载 MDAC 的最新版本！
Universal Data Access Web Site
在下载之前先到 VB6 中檢查一下，【控件】【設定引用項目】中的 Microsoft Jet and Replication Objects X.X library 如果已经是 2.1 以上的版本，您就可以不用下载了！
在您安裝了 MDAC 2.1 或以上的版本之后，您就可以使用 ADO 來压缩或修复 Microsoft Access 文件，下面的步骤告訴您如何使用 CompactDatabase Method 來压缩 Microsoft Access 文件：
1、新建一個新表单，选择功能表中的【控件】【設定引用項目】。
2、加入 Microsoft Jet and Replication Objects X.X library，其中 ( X.X 大于或等于 2.1 )。
3、在适当的地方加入以下的程序代码，記得要修改 data source 的內容及目地文件的路径：
Dim jro As jro.JetEngine
Set jro = New jro.JetEngine
jro.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d:\\nwind2.mdb", _ '來源文件
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d:\\abbc2.mdb;Jet OLEDB:Engine Type=4" '目的文件
在 DAO 3.60 之后，RepairDatabase Method 已经无法使用了，以上的程序代码显示了 ADO CompactDatabase Method 的用法，而它也取代了 DAO 3.5 時的 RepairDatabase method！
#11
12个了。哈哈。
#12
up
#13
mark
#14
hi~!
#15
字符集 (0–127)
0 ?/FONT> 32 [space] 64 @ 96 `
1 · 33 ! 65 A 97 a
2 · 34 " 66 B 98 b
3 · 35 # 67 C 99 c
4 · 36 $ 68 D 100 d
5 · 37 % 69 E 101 e
6 · 38 & 70 F 102 f
7 · 39 ' 71 G 103 g
8 * * 40 ( 72 H 104 h
9 * * 41 ) 73 I 105 i
10 * * 42 * 74 J 106 j
11 · 43 + 75 K 107 k
12 · 44 , 76 L 108 l
13 * * 45 - 77 M 109 m
14 · 46 . 78 N 110 n
15 · 47 / 79 O 111 o
16 · 48 0 80 P 112 p
17 · 49 1 81 Q 113 q
18 · 50 2 82 R 114 r
19 · 51 3 83 S 115 s
20 · 52 4 84 T 116 t
21 · 53 5 85 U 117 u
22 · 54 6 86 V 118 v
23 · 55 7 87 W 119 w
24 · 56 8 88 X 120 x
25 · 57 9 89 Y 121 y
26 · 58 : 90 Z 122 z
27 · 59 ; 91 [ 123 {
28 · 60 < 92 \ 124 |
29 · 61 = 93 ] 125 }
30 · 62 > 94 ^ 126 ~
31 · 63 ? 95 _ 127 ·
*·Microsoft Windows.不支持这些字符。
* *值 8、9、10 和 13 分别转换为退格、制表、换行和回车字符。它们并没有特定的图形显示，但会依不同的应用程序，而对文本显示有不同的影响。
字符运用示例：
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then'用户按下Enter键
Command1.SetFocus
End If
If KeyAscii >= 65 And KeyAscii <= 90 Then 'A~Z
KeyAscii = Asc(UCase(Chr(KeyAscii)))
ElseIf KeyAscii >= 97 And KeyAscii <= 122 Then 'a~z
KeyAscii = Asc(UCase(Chr(KeyAscii)))
ElseIf KeyAscii >= 48 And KeyAscii <= 57 Then '0~9
ElseIf KeyAscii = 8 Then
Else
KeyAscii = 0
End If
End Sub
0 ?/FONT> 32 [space] 64 @ 96 `
1 · 33 ! 65 A 97 a
2 · 34 " 66 B 98 b
3 · 35 # 67 C 99 c
4 · 36 $ 68 D 100 d
5 · 37 % 69 E 101 e
6 · 38 & 70 F 102 f
7 · 39 ' 71 G 103 g
8 * * 40 ( 72 H 104 h
9 * * 41 ) 73 I 105 i
10 * * 42 * 74 J 106 j
11 · 43 + 75 K 107 k
12 · 44 , 76 L 108 l
13 * * 45 - 77 M 109 m
14 · 46 . 78 N 110 n
15 · 47 / 79 O 111 o
16 · 48 0 80 P 112 p
17 · 49 1 81 Q 113 q
18 · 50 2 82 R 114 r
19 · 51 3 83 S 115 s
20 · 52 4 84 T 116 t
21 · 53 5 85 U 117 u
22 · 54 6 86 V 118 v
23 · 55 7 87 W 119 w
24 · 56 8 88 X 120 x
25 · 57 9 89 Y 121 y
26 · 58 : 90 Z 122 z
27 · 59 ; 91 [ 123 {
28 · 60 < 92 \ 124 |
29 · 61 = 93 ] 125 }
30 · 62 > 94 ^ 126 ~
31 · 63 ? 95 _ 127 ·
*·Microsoft Windows.不支持这些字符。
* *值 8、9、10 和 13 分别转换为退格、制表、换行和回车字符。它们并没有特定的图形显示，但会依不同的应用程序，而对文本显示有不同的影响。
字符运用示例：
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then'用户按下Enter键
Command1.SetFocus
End If
If KeyAscii >= 65 And KeyAscii <= 90 Then 'A~Z
KeyAscii = Asc(UCase(Chr(KeyAscii)))
ElseIf KeyAscii >= 97 And KeyAscii <= 122 Then 'a~z
KeyAscii = Asc(UCase(Chr(KeyAscii)))
ElseIf KeyAscii >= 48 And KeyAscii <= 57 Then '0~9
ElseIf KeyAscii = 8 Then
Else
KeyAscii = 0
End If
End Sub
#16
在凑个热闹...
'===============================
'URLEncode算法
'===============================
Const a As String = "http://www.microsoft.com"
Private Sub Command1_Click()
Dim c, d As String
Dim i As Long
For i = 1 To Len(a)
If Asc(Mid(a, i, 1)) < 0 Then
d = "%" & Right(CStr(Hex(Asc(Mid(a, i, 1)))), 2)
d = "%" & Left(CStr(Hex(Asc(Mid(a, i, 1)))), Len(CStr(Hex(Asc(Mid(a, i, 1))))) - 2) & d
c = c & d
ElseIf (Asc(Mid(a, i, 1)) >= 65 And Asc(Mid(a, i, 1)) <= 90) Or (Asc(Mid(a, i, 1)) >= 97 And Asc(Mid(a, i, 1)) <= 122) Then
c = c & Mid(a, i, 1)
Else
c = c & "%" & Hex(Asc(Mid(a, i, 1)))
End If
Next
MsgBox c
End Sub
'===============================
'URLEncode算法
'===============================
Const a As String = "http://www.microsoft.com"
Private Sub Command1_Click()
Dim c, d As String
Dim i As Long
For i = 1 To Len(a)
If Asc(Mid(a, i, 1)) < 0 Then
d = "%" & Right(CStr(Hex(Asc(Mid(a, i, 1)))), 2)
d = "%" & Left(CStr(Hex(Asc(Mid(a, i, 1)))), Len(CStr(Hex(Asc(Mid(a, i, 1))))) - 2) & d
c = c & d
ElseIf (Asc(Mid(a, i, 1)) >= 65 And Asc(Mid(a, i, 1)) <= 90) Or (Asc(Mid(a, i, 1)) >= 97 And Asc(Mid(a, i, 1)) <= 122) Then
c = c & Mid(a, i, 1)
Else
c = c & "%" & Hex(Asc(Mid(a, i, 1)))
End If
Next
MsgBox c
End Sub
#17
各位dx贴的时候说一下做什么用的，不然看的一头雾水。可能我水平低
#18
'####################################################################
'##get all index of multiline item in listbox ##
'##hWnd required,handle of listbox ##
'##ItemsIndex required,export array ##
'## save all index of multiline selection item ##
'##Length Optional,point to size of array ##
'## default value is zero, ##
'## namely its length is equal to 256 ##
'## elsewise use appointed value of customer ##
'##Return value: ##
'## -1 means is execution fail ##
'## elsewise return a count of selected item ##
'####################################################################
Public Function GetSelItems(ByVal hWnd As Long, ByRef ItemsIndex() As Long, Optional Length As Integer = 0) As Long
Dim Rtn&
Dim ItemNo() As Long
Dim Upper As Long
On Error GoTo Items_Error
Upper = IIf(Length <= 0, 256, Length)
ReDim ItemNo(0 To Upper)
'call api function
Rtn = SendMessage(hWnd, LB_GETSELITEMS, Upper, ItemNo(0))
If Rtn < 0 Then GoTo Items_Error
ItemsIndex = ItemNo
GetSelItems = Rtn
Exit Function
Items_Error:
GetSelItems = -1
End Function
得到listbox中所有多选条目的index
'##get all index of multiline item in listbox ##
'##hWnd required,handle of listbox ##
'##ItemsIndex required,export array ##
'## save all index of multiline selection item ##
'##Length Optional,point to size of array ##
'## default value is zero, ##
'## namely its length is equal to 256 ##
'## elsewise use appointed value of customer ##
'##Return value: ##
'## -1 means is execution fail ##
'## elsewise return a count of selected item ##
'####################################################################
Public Function GetSelItems(ByVal hWnd As Long, ByRef ItemsIndex() As Long, Optional Length As Integer = 0) As Long
Dim Rtn&
Dim ItemNo() As Long
Dim Upper As Long
On Error GoTo Items_Error
Upper = IIf(Length <= 0, 256, Length)
ReDim ItemNo(0 To Upper)
'call api function
Rtn = SendMessage(hWnd, LB_GETSELITEMS, Upper, ItemNo(0))
If Rtn < 0 Then GoTo Items_Error
ItemsIndex = ItemNo
GetSelItems = Rtn
Exit Function
Items_Error:
GetSelItems = -1
End Function
得到listbox中所有多选条目的index
#19
Private Const LB_GETSELITEMS = &H191 'get number of multiline item
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
忘写消息和api定义了
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
忘写消息和api定义了
#20
' 压缩 Access 数据库
Public Sub CompactJetDatabase(SourceFile As String, Optional Password As String, Optional BackupOriginal As Boolean = True)
On Error GoTo CompactErr
Dim strBackupFile As String
Dim strTempFile As String
' 判断来源文件是否存在
If Dir(SourceFile) <> "" Then
' 如果需要备份原文件
If BackupOriginal = True Then
strBackupFile = GetSourceFilePath(SourceFile) & "Backup.mdb"
If Dir(strBackupFile) <> "" Then
Kill strBackupFile
End If
FileCopy SourceFile, strBackupFile
End If
' 建立压缩文件名
strTempFile = GetSourceFilePath(SourceFile) & "Temp.mdb"
If Dir(strTempFile) <> "" Then
Kill strTempFile
End If
' 通过 DBEngine 压缩文件，注意，您必须引用 Microsoft DAO 3.xx Object Library
DBEngine.CompactDatabase SourceFile, strTempFile, , , ";Pwd=" & Password & ";"
' 删除旧文件
Kill SourceFile
' 重新命名新文件名
Name strTempFile As SourceFile
Else
MsgBox SourceFile & "File not fond！", vbExclamation
End If
CompactErr:
If Err.Number <> 0 Then
MsgBox Err.Description & Err.Number, vbCritical, "error"
End If
On Error GoTo 0
Exit Sub
End Sub
Public Function GetSourceFilePath(SourceFile As String) As String
Dim n As Integer
n = InStrRev(SourceFile, "\")
GetSourceFilePath = Left(SourceFile, n)
End Function
Public Function fBrowseForFolder(hWndOwner As Long, sPrompt As String) As String
Dim iNull As Integer
Dim lpIDList As Long
Dim lResult As Long
Dim sPath As String
Dim udtBI As BrowseInfo
With udtBI
.hWndOwner = hWndOwner
.lpszTitle = lstrcat(sPrompt, "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
lResult = SHGetPathFromIDList(lpIDList, sPath)
Call CoTaskMemFree(lpIDList)
iNull = InStr(sPath, vbNullChar)
If iNull Then sPath = Left$(sPath, iNull - 1)
End If
fBrowseForFolder = sPath
End Function
' 备份这个数据库
Public Function BackupDB(ByVal SourceFile As String, ByVal BackupFolderName As String) As Boolean
On Error Resume Next
Dim lFileOp As Long
Dim lResult As Long
Dim lFlags As Long
Dim SHFileOp As SHFILEOPSTRUCT
Dim strSourceDir As String
Dim strDestinationDir As String
Screen.MousePointer = vbHourglass
If Right(BackupFolderName, 1) <> "\" Then
BackupFolderName = BackupFolderName & "\"
End If
lFileOp = FO_COPY
lFlags = lFlags And Not FOF_SILENT
lFlags = lFlags Or FOF_NOCONFIRMATION
lFlags = lFlags Or FOF_NOCONFIRMMKDIR
lFlags = lFlags Or FOF_FILESONLY
With SHFileOp
.wFunc = lFileOp
.pFrom = SourceFile & vbNullChar
.pTo = BackupFolderName & "PMBackup" & Format(Date, "mmdd") & ".pmb"
.fFlags = lFlags
End With
lResult = SHFileOperation(SHFileOp)
BackupDB = (lResult = 0)
Screen.MousePointer = vbDefault
End Function
' 还原这个数据库
Public Function RestoreDB(ByVal SourceFile As String, ToFile As String) As Boolean
On Error Resume Next
Dim lFileOp As Long
Dim lResult As Long
Dim lFlags As Long
Dim SHFileOp As SHFILEOPSTRUCT
Screen.MousePointer = vbHourglass
lFileOp = FO_COPY
lFlags = lFlags And Not FOF_SILENT
lFlags = lFlags Or FOF_NOCONFIRMATION
lFlags = lFlags Or FOF_NOCONFIRMMKDIR
lFlags = lFlags Or FOF_FILESONLY
With SHFileOp
.wFunc = lFileOp
.pFrom = SourceFile & vbNullChar
.pTo = ToFile & vbNullChar
.fFlags = lFlags
End With
lResult = SHFileOperation(SHFileOp)
RestoreDB = (lResult = 0)
Screen.MousePointer = vbDefault
End Function
Public Sub CompactJetDatabase(SourceFile As String, Optional Password As String, Optional BackupOriginal As Boolean = True)
On Error GoTo CompactErr
Dim strBackupFile As String
Dim strTempFile As String
' 判断来源文件是否存在
If Dir(SourceFile) <> "" Then
' 如果需要备份原文件
If BackupOriginal = True Then
strBackupFile = GetSourceFilePath(SourceFile) & "Backup.mdb"
If Dir(strBackupFile) <> "" Then
Kill strBackupFile
End If
FileCopy SourceFile, strBackupFile
End If
' 建立压缩文件名
strTempFile = GetSourceFilePath(SourceFile) & "Temp.mdb"
If Dir(strTempFile) <> "" Then
Kill strTempFile
End If
' 通过 DBEngine 压缩文件，注意，您必须引用 Microsoft DAO 3.xx Object Library
DBEngine.CompactDatabase SourceFile, strTempFile, , , ";Pwd=" & Password & ";"
' 删除旧文件
Kill SourceFile
' 重新命名新文件名
Name strTempFile As SourceFile
Else
MsgBox SourceFile & "File not fond！", vbExclamation
End If
CompactErr:
If Err.Number <> 0 Then
MsgBox Err.Description & Err.Number, vbCritical, "error"
End If
On Error GoTo 0
Exit Sub
End Sub
Public Function GetSourceFilePath(SourceFile As String) As String
Dim n As Integer
n = InStrRev(SourceFile, "\")
GetSourceFilePath = Left(SourceFile, n)
End Function
Public Function fBrowseForFolder(hWndOwner As Long, sPrompt As String) As String
Dim iNull As Integer
Dim lpIDList As Long
Dim lResult As Long
Dim sPath As String
Dim udtBI As BrowseInfo
With udtBI
.hWndOwner = hWndOwner
.lpszTitle = lstrcat(sPrompt, "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
lResult = SHGetPathFromIDList(lpIDList, sPath)
Call CoTaskMemFree(lpIDList)
iNull = InStr(sPath, vbNullChar)
If iNull Then sPath = Left$(sPath, iNull - 1)
End If
fBrowseForFolder = sPath
End Function
' 备份这个数据库
Public Function BackupDB(ByVal SourceFile As String, ByVal BackupFolderName As String) As Boolean
On Error Resume Next
Dim lFileOp As Long
Dim lResult As Long
Dim lFlags As Long
Dim SHFileOp As SHFILEOPSTRUCT
Dim strSourceDir As String
Dim strDestinationDir As String
Screen.MousePointer = vbHourglass
If Right(BackupFolderName, 1) <> "\" Then
BackupFolderName = BackupFolderName & "\"
End If
lFileOp = FO_COPY
lFlags = lFlags And Not FOF_SILENT
lFlags = lFlags Or FOF_NOCONFIRMATION
lFlags = lFlags Or FOF_NOCONFIRMMKDIR
lFlags = lFlags Or FOF_FILESONLY
With SHFileOp
.wFunc = lFileOp
.pFrom = SourceFile & vbNullChar
.pTo = BackupFolderName & "PMBackup" & Format(Date, "mmdd") & ".pmb"
.fFlags = lFlags
End With
lResult = SHFileOperation(SHFileOp)
BackupDB = (lResult = 0)
Screen.MousePointer = vbDefault
End Function
' 还原这个数据库
Public Function RestoreDB(ByVal SourceFile As String, ToFile As String) As Boolean
On Error Resume Next
Dim lFileOp As Long
Dim lResult As Long
Dim lFlags As Long
Dim SHFileOp As SHFILEOPSTRUCT
Screen.MousePointer = vbHourglass
lFileOp = FO_COPY
lFlags = lFlags And Not FOF_SILENT
lFlags = lFlags Or FOF_NOCONFIRMATION
lFlags = lFlags Or FOF_NOCONFIRMMKDIR
lFlags = lFlags Or FOF_FILESONLY
With SHFileOp
.wFunc = lFileOp
.pFrom = SourceFile & vbNullChar
.pTo = ToFile & vbNullChar
.fFlags = lFlags
End With
lResult = SHFileOperation(SHFileOp)
RestoreDB = (lResult = 0)
Screen.MousePointer = vbDefault
End Function
#21
http://expert.csdn.net/Expert/topic/1480/1480469.xml?temp=.1952021
#22
顺便把泰山的专栏也贴上：
http://www.sijiqing.com/vbgood/taishan/index.html
http://www.sijiqing.com/vbgood/taishan/index.html
#23
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
#24
hao
#25
好
#26
再来两三个就够数了。
菜鸟看到别忘了UP一下，高手看到别忘了有什么得意的小段子奉献一下哟。
菜鸟看到别忘了UP一下，高手看到别忘了有什么得意的小段子奉献一下哟。
#27
有人总问为什么在使用webbrowser.document.links.length时候会有错误91
这是因为你在webbrowser 还没有完整的下载页面，就使用的document 对象
尽管你是使用 webbrowser.documentcomplete 事件，但是..会出现对象未设置错误91
解决办法就是 Private Sub Form_Load()
WebBrowser1.Navigate2 (url) 你先给个默认的地址 上来就naviage2 就可以了
End Sub
这是因为你在webbrowser 还没有完整的下载页面，就使用的document 对象
尽管你是使用 webbrowser.documentcomplete 事件，但是..会出现对象未设置错误91
解决办法就是 Private Sub Form_Load()
WebBrowser1.Navigate2 (url) 你先给个默认的地址 上来就naviage2 就可以了
End Sub
#28
有人问如何使用webbrowser 去navigate2 一个列表里面的所有urllist
因为他们经常的出现错误是只浏览最后一个list..是因为webbrowers没有足够的时间去挨个去浏览，解决如下：
Private Sub Go_Click()
Dim URL_Index As Integer, CurrentURL As String
For URL_Index = 0 To List3.ListCount - 1
CurrentURL = List3.List(URL_Index)
If CurrentURL <> "" Then
WebBrowser1.Navigate2 CurrentURL, 4
While Not (WebBrowser1.ReadyState = READYSTATE_COMPLETE)
DoEvents
Wend
End If
Next URL_Index
End Sub
因为他们经常的出现错误是只浏览最后一个list..是因为webbrowers没有足够的时间去挨个去浏览，解决如下：
Private Sub Go_Click()
Dim URL_Index As Integer, CurrentURL As String
For URL_Index = 0 To List3.ListCount - 1
CurrentURL = List3.List(URL_Index)
If CurrentURL <> "" Then
WebBrowser1.Navigate2 CurrentURL, 4
While Not (WebBrowser1.ReadyState = READYSTATE_COMPLETE)
DoEvents
Wend
End If
Next URL_Index
End Sub
#29
这是个不用 webbrowser 抓links 的办法：
用的是html object library
=========
Private Sub cmdGo_Click()
Dim objLink As HTMLLinkElement
Dim objMSHTML As New MSHTML.HTMLDocument
Dim objDocument As MSHTML.HTMLDocument
lblStatus.Caption = "Gettting document via HTTP"
Set objDocument = objMSHTML.createDocumentFromUrl(txtURL.Text, vbNullString)
lblStatus.Caption = "Getting and parsing HTML document"
While objDocument.readyState <> "complete"
DoEvents
Wend
lblStatus.Caption = "Document completed"
txtSource.Text = objDocument.documentElement.outerHTML
DoEvents
lblTitle.Caption = "Title : " & objDocument.Title
DoEvents
lblStatus.Caption = "Extracting links"
For Each objLink In objDocument.links
lstLinks.AddItem objLink
lblStatus.Caption = "Extracted " & objLink
DoEvents
Next
lblStatus.Caption = "Done"
Beep
End Sub
用的是html object library
=========
Private Sub cmdGo_Click()
Dim objLink As HTMLLinkElement
Dim objMSHTML As New MSHTML.HTMLDocument
Dim objDocument As MSHTML.HTMLDocument
lblStatus.Caption = "Gettting document via HTTP"
Set objDocument = objMSHTML.createDocumentFromUrl(txtURL.Text, vbNullString)
lblStatus.Caption = "Getting and parsing HTML document"
While objDocument.readyState <> "complete"
DoEvents
Wend
lblStatus.Caption = "Document completed"
txtSource.Text = objDocument.documentElement.outerHTML
DoEvents
lblTitle.Caption = "Title : " & objDocument.Title
DoEvents
lblStatus.Caption = "Extracting links"
For Each objLink In objDocument.links
lstLinks.AddItem objLink
lblStatus.Caption = "Extracted " & objLink
DoEvents
Next
lblStatus.Caption = "Done"
Beep
End Sub
#30
我是菜鸟，我顶！
#31
我說一個最簡單的：
時間插入法：
sql="insert into tablename(a,b) values('1',getdate())" //函數
sql="insert into tablename(a,b) values('1','"&date&"')" //變量
時間插入法：
sql="insert into tablename(a,b) values('1',getdate())" //函數
sql="insert into tablename(a,b) values('1','"&date&"')" //變量
#32
sql="insert into tablename(a,b) values('1','"&date&"')" //變量
这句如果是用的Access，可能要这样改一下：
sql="insert into tablename(a,b) values('1',#" & date & "#)" '變量
这句如果是用的Access，可能要这样改一下：
sql="insert into tablename(a,b) values('1',#" & date & "#)" '變量
#33
SQL Server
sql="insert into tablename(a,b) values('1',convert(datetime," & date & ",121))" '變量
sql="insert into tablename(a,b) values('1',convert(datetime," & date & ",121))" '變量
#34
sql="insert into tablename(a,b) values('1',convert(datetime," & date & ",121))" '變量
為啥執行結果是1900/3/4呢？
為啥執行結果是1900/3/4呢？
#35
'本次有一段拖动无标题框窗体的代码，已经写成了最为通用的代码。自以为很舒畅，请大家共享。
''这段代码可以像实体一样拖动窗体，而且拖不出屏幕边框；不象普通API函数的拖动，它们先是在目标区划一虚框，再在目标位置重画窗体，我认为这种处理不好。请朋友们抬爱试试!
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If (Button = vbLeftButton) And (Me.WindowState = 0) Then
MousePointer = vbSizeAll
mX = X
mY = Y
End If
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim H As Long
Dim V As Long
On Error Resume Next
If (Button = vbLeftButton) And (Me.WindowState = 0) Then
'如果鼠标位置没有变化，表示没有移动。此时当退出过程，提高程序运行效果。
If (X = mY) And (Y = mY) Then Exit Sub
H = Me.Left + X - mX
V = Me.Top + Y - mY
If H <= 0 Then
H = 0
ElseIf H >= (Screen.Width - Me.Width) Then
H = Screen.Width - Me.Width
End If
If V <= 0 Then
V = 0
ElseIf V >= (Screen.Height - Me.Height) Then
V = Screen.Height - Me.Height
End If
Me.Move H, V
End If
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
MousePointer = vbDefault
'如果设置得有鼠标右键菜单，弹出该菜单。
If Button = vbRightButton Then
Call PopupMenu(mnuRight)
End If
End Sub
''这段代码可以像实体一样拖动窗体，而且拖不出屏幕边框；不象普通API函数的拖动，它们先是在目标区划一虚框，再在目标位置重画窗体，我认为这种处理不好。请朋友们抬爱试试!
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If (Button = vbLeftButton) And (Me.WindowState = 0) Then
MousePointer = vbSizeAll
mX = X
mY = Y
End If
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim H As Long
Dim V As Long
On Error Resume Next
If (Button = vbLeftButton) And (Me.WindowState = 0) Then
'如果鼠标位置没有变化，表示没有移动。此时当退出过程，提高程序运行效果。
If (X = mY) And (Y = mY) Then Exit Sub
H = Me.Left + X - mX
V = Me.Top + Y - mY
If H <= 0 Then
H = 0
ElseIf H >= (Screen.Width - Me.Width) Then
H = Screen.Width - Me.Width
End If
If V <= 0 Then
V = 0
ElseIf V >= (Screen.Height - Me.Height) Then
V = Screen.Height - Me.Height
End If
Me.Move H, V
End If
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
MousePointer = vbDefault
'如果设置得有鼠标右键菜单，弹出该菜单。
If Button = vbRightButton Then
Call PopupMenu(mnuRight)
End If
End Sub
#36
多多益善
#37
TO xianghua(小黑) :
数据库中字段必须是Datetime型
数据库中字段必须是Datetime型
#38
哈，我是初學，所以說的都是簡單的，請不要見笑。
ado連接sql2000資料庫方法：
dim conn as new adodb.connection
dim rs as new adodb.recordset
dim sql as string
conn.open"driver={sql server};server=服務器名;database=數據庫名;uid=sa;pwd=密碼“
set rs.cursorlocation=aduseclient //對於datagrid控件來說要待別注意
sql="select * from table "
rs.open sql,conn,1,1
set datagrid1.datasource=rs //後期綁定
ado連接sql2000資料庫方法：
dim conn as new adodb.connection
dim rs as new adodb.recordset
dim sql as string
conn.open"driver={sql server};server=服務器名;database=數據庫名;uid=sa;pwd=密碼“
set rs.cursorlocation=aduseclient //對於datagrid控件來說要待別注意
sql="select * from table "
rs.open sql,conn,1,1
set datagrid1.datasource=rs //後期綁定
#39
to:Cooly(☆回答问题不要分儿☆)
前輩請不要笑我，我的類型是為datatime 型的啊！是sql2000+vb6.0的。
代碼如下：Private Sub Command1_Click()
Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
conn.Open "driver={sql server};database=capital;uid=sa;pwd=zasan;server=hsan_sql2"
sql = "insert into test (a,b) values ('16',convert(datetime," & Date & ",121))"
conn.Execute sql
End Sub
真是不好意思了。
前輩請不要笑我，我的類型是為datatime 型的啊！是sql2000+vb6.0的。
代碼如下：Private Sub Command1_Click()
Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
conn.Open "driver={sql server};database=capital;uid=sa;pwd=zasan;server=hsan_sql2"
sql = "insert into test (a,b) values ('16',convert(datetime," & Date & ",121))"
conn.Execute sql
End Sub
真是不好意思了。
#40
当然，上述代码得先定义模块级变量
dim mX as long
dim mY as long
dim mX as long
dim mY as long
#41
TO xianghua(小黑) :
你的字段类型是DateTime还是SmallDateTime?
你的字段类型是DateTime还是SmallDateTime?
#42
to: Cooly(☆回答问题不要分儿☆)
是datatime型的。
是datatime型的。
#43
呵呵，本贴上了非技术类版顶端的红点导读贴子了。看来版主比较支持我。up一下。
#44
偶是菜鸟,但是偶靠下面的代码在技术区多穿了个三角裤.现加了进来.拙文见笑了!
'模块里内容
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
Sub DisableCtrlAltDelete(bDisabled As Boolean)
' Disables Control Alt Delete Breaking as well as Ctrl-Escape
Dim X As Long
X = SystemParametersInfo(97, bDisabled, CStr(1), 0)
End Sub
'窗体代码
Private Sub Command1_Click()
DisableCtrlAltDelete (False)
End Sub
Private Sub Command2_Click()
DisableCtrlAltDelete (True)
End Sub
强烈建议多些此类的文章!
()000o oO00()
( $ ) ( ￥ )
) / \ (
(__/ \__)
'模块里内容
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
Sub DisableCtrlAltDelete(bDisabled As Boolean)
' Disables Control Alt Delete Breaking as well as Ctrl-Escape
Dim X As Long
X = SystemParametersInfo(97, bDisabled, CStr(1), 0)
End Sub
'窗体代码
Private Sub Command1_Click()
DisableCtrlAltDelete (False)
End Sub
Private Sub Command2_Click()
DisableCtrlAltDelete (True)
End Sub
强烈建议多些此类的文章!
()000o oO00()
( $ ) ( ￥ )
) / \ (
(__/ \__)
#45
支持楼主.助人为乐
#46
忘了说，这段程序是操作Ctrl+Alt+Del的
#1
我带个头~~~~ 分儿就不用给了~~~~
下面是昨天帮别人改的一段Quoted Printable编码转换函数。
Public Function QpDecode(inString As String) As String
Dim myB As Byte
Dim myByte1 As Byte, myByte2 As Byte
Dim convStr() As Byte
Dim mOutByte As Byte
Dim FinishPercent As Long
Dim TotalB, k As Long
Dim tmpByte As Byte
convStr = StrConv(inString, vbFromUnicode)
TotalB = UBound(convStr)
For k = 0 To TotalB
myB = convStr(k)
If myB = Asc("=") Then
k = k + 1
myByte1 = convStr(k)
If myByte1 = &HA Then
'如果是回车,继续
Else
'取第二个字节
k = k + 1
myByte2 = convStr(k)
Call DecodeByte(myByte1, myByte2, mOutByte)
If mOutByte >= 127 Then
If tmpByte <> 0 Then
QpDecode = QpDecode & Chr(Val("&H" & Hex(tmpByte) & Hex(mOutByte)))
tmpByte = 0
Else
tmpByte = mOutByte
End If
Else
QpDecode = QpDecode & Chr(mOutByte)
tmpByte = 0
End If
End If
Else
mOutByte = myB
QpDecode = QpDecode & Chr(mOutByte)
End If
Next
End Function
Private Sub DecodeByte(mInByte1 As Byte, mInByte2 As Byte, mOutByte As Byte)
Dim tbyte1 As Integer, tbyte2 As Integer
If mInByte1 > Asc("9") Then
tbyte1 = mInByte1 - Asc("A") + 10
Else
tbyte1 = mInByte1 - Asc("0")
End If
If mInByte2 > Asc("9") Then
tbyte2 = mInByte2 - Asc("A") + 10
Else
tbyte2 = mInByte2 - Asc("0")
End If
mOutByte = tbyte1 * 16 + tbyte2
End Sub
Private Sub EncodeByte(mInByte As Byte, mOutStr As String)
If (mInByte >= 33 And mInByte <= 60) Or (mInByte >= 62 And mInByte <= 126) Then
mOutStr = Chr(mInByte)
Else
If mInByte <= &HF Then
mOutStr = "=0" & Hex(mInByte)
Else
mOutStr = "=" & Hex(mInByte)
End If
End If
End Sub
Public Function QpEncode(inString As String) As String
Dim myB As Byte
Dim convByte() As Byte
Dim mOutStr As String
Dim FinishPercent As Long
Dim TotalB, k As Long
convByte = StrConv(inString, vbFromUnicode)
TotalB = UBound(convByte)
For k = 0 To TotalB
myB = convByte(k)
EncodeByte myB, mOutStr
QpEncode = QpEncode & mOutStr
Next
End Function
Private Sub Command1_Click()
MsgBox QpDecode("=B2=E2=CA=D4=D2=BB")
End Sub
Private Sub Command2_Click()
MsgBox QpEncode("测试一")
End Sub
下面是昨天帮别人改的一段Quoted Printable编码转换函数。
Public Function QpDecode(inString As String) As String
Dim myB As Byte
Dim myByte1 As Byte, myByte2 As Byte
Dim convStr() As Byte
Dim mOutByte As Byte
Dim FinishPercent As Long
Dim TotalB, k As Long
Dim tmpByte As Byte
convStr = StrConv(inString, vbFromUnicode)
TotalB = UBound(convStr)
For k = 0 To TotalB
myB = convStr(k)
If myB = Asc("=") Then
k = k + 1
myByte1 = convStr(k)
If myByte1 = &HA Then
'如果是回车,继续
Else
'取第二个字节
k = k + 1
myByte2 = convStr(k)
Call DecodeByte(myByte1, myByte2, mOutByte)
If mOutByte >= 127 Then
If tmpByte <> 0 Then
QpDecode = QpDecode & Chr(Val("&H" & Hex(tmpByte) & Hex(mOutByte)))
tmpByte = 0
Else
tmpByte = mOutByte
End If
Else
QpDecode = QpDecode & Chr(mOutByte)
tmpByte = 0
End If
End If
Else
mOutByte = myB
QpDecode = QpDecode & Chr(mOutByte)
End If
Next
End Function
Private Sub DecodeByte(mInByte1 As Byte, mInByte2 As Byte, mOutByte As Byte)
Dim tbyte1 As Integer, tbyte2 As Integer
If mInByte1 > Asc("9") Then
tbyte1 = mInByte1 - Asc("A") + 10
Else
tbyte1 = mInByte1 - Asc("0")
End If
If mInByte2 > Asc("9") Then
tbyte2 = mInByte2 - Asc("A") + 10
Else
tbyte2 = mInByte2 - Asc("0")
End If
mOutByte = tbyte1 * 16 + tbyte2
End Sub
Private Sub EncodeByte(mInByte As Byte, mOutStr As String)
If (mInByte >= 33 And mInByte <= 60) Or (mInByte >= 62 And mInByte <= 126) Then
mOutStr = Chr(mInByte)
Else
If mInByte <= &HF Then
mOutStr = "=0" & Hex(mInByte)
Else
mOutStr = "=" & Hex(mInByte)
End If
End If
End Sub
Public Function QpEncode(inString As String) As String
Dim myB As Byte
Dim convByte() As Byte
Dim mOutStr As String
Dim FinishPercent As Long
Dim TotalB, k As Long
convByte = StrConv(inString, vbFromUnicode)
TotalB = UBound(convByte)
For k = 0 To TotalB
myB = convByte(k)
EncodeByte myB, mOutStr
QpEncode = QpEncode & mOutStr
Next
End Function
Private Sub Command1_Click()
MsgBox QpDecode("=B2=E2=CA=D4=D2=BB")
End Sub
Private Sub Command2_Click()
MsgBox QpEncode("测试一")
End Sub
#2
Rem ===============API Function Define==============================
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
Rem ===============API Constant Define =============================
Private Const GWL_STYLE = (-16) 'Window field offset
Rem ===============The below constant is not exist in win32api.txt==
Private Const BS_BITMAP& = &H80& 'show bitmap in button
Private Const BS_BOTTOM& = &H800& 'button caption seted bottom
Private Const BS_CENTER& = &H300& 'button caption seted center
Private Const BS_ICON& = &H40& 'show icon in button
Private Const BS_LEFT& = &H100& 'button caption seted left
Private Const BS_RIGHT& = &H200& 'button caption seted RIGHT
Private Const BS_MULTILINE& = &H2000& 'button caption seted multiline
Private Const BS_NOTIFY& = &H4000& '
Private Const BS_PUSHLIKE& = &H1000& 'make style of checkbox and optionbox same with button
Private Const BS_TOP& = &H400& 'button caption seted TOP
Private Const BS_VCENTER& = &HC00& 'button caption seted vertical and center
Rem ===============Custom Define Variable============================
Rem -----------------------------------------------------------------
Rem this argument used to CaptionAlignment function
Private Const ca_HorizontalCenter = 0
Private Const ca_VerticalCenter = 1
Private Const ca_Left = 2
Private Const ca_Right = 3
Private Const ca_Top = 4
Private Const ca_Bottom = 5
Private Const ca_Default = 6
Rem ----------------------------------------------------------------
Private oldBtnStyle As Long
Private SetFlg As Boolean
Private AlignmentStyle&
'Alignment button caption
'Argument :
' btnhWnd button handle
' AlignmentStyle 0 default) Horizontal center
' 1) Vertical center
' 2) Alignment left
' 3) Alignment Right
' 4) Alignment top
' 5) Alignment bottom
' 6) restore original style
'@Note : only use to button text
Public Function CaptionAlignment(ByVal btnhWnd As Long, Optional AlignmentStyle As Integer = 0) As Boolean
Dim lngStyle As Long
Dim lngAlignment As Long
Dim Rtn&
On Error GoTo Alignment_Error
If btnhWnd = 0 Then GoTo Alignment_Error
CaptionAlignment = True
If Not SetFlg Then
SetFlg = True
oldBtnStyle = GetWindowLong(btnhWnd, GWL_STYLE) 'get original style
End If
Select Case AlignmentStyle
Case ca_HorizontalCenter 'horizontal center
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not (BS_LEFT Or BS_RIGHT)
lngAlignment = BS_CENTER
Case ca_VerticalCenter 'vertical center
lngAlignment = BS_CENTER
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not (BS_TOP Or BS_BOTTOM)
Case ca_Left 'left
lngAlignment = BS_LEFT
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not BS_RIGHT
Case ca_Right 'right
lngAlignment = BS_RIGHT
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not BS_LEFT
Case ca_Top 'top
lngAlignment = BS_TOP
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not BS_BOTTOM
Case ca_Bottom 'bottom
lngAlignment = BS_BOTTOM
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not BS_TOP
Case ca_Default 'restore original style
lngAlignment = oldBtnStyle
If lngAlignment = 0 Then Exit Function
Rtn = SetWindowLong(btnhWnd, GWL_STYLE, lngAlignment)
Exit Function
End Select
'set position
Rtn = SetWindowLong(btnhWnd, GWL_STYLE, lngStyle Or lngAlignment)
Exit Function
Alignment_Error:
CaptionAlignment = False
End Function
这是command控件caption德对齐方式。
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
Rem ===============API Constant Define =============================
Private Const GWL_STYLE = (-16) 'Window field offset
Rem ===============The below constant is not exist in win32api.txt==
Private Const BS_BITMAP& = &H80& 'show bitmap in button
Private Const BS_BOTTOM& = &H800& 'button caption seted bottom
Private Const BS_CENTER& = &H300& 'button caption seted center
Private Const BS_ICON& = &H40& 'show icon in button
Private Const BS_LEFT& = &H100& 'button caption seted left
Private Const BS_RIGHT& = &H200& 'button caption seted RIGHT
Private Const BS_MULTILINE& = &H2000& 'button caption seted multiline
Private Const BS_NOTIFY& = &H4000& '
Private Const BS_PUSHLIKE& = &H1000& 'make style of checkbox and optionbox same with button
Private Const BS_TOP& = &H400& 'button caption seted TOP
Private Const BS_VCENTER& = &HC00& 'button caption seted vertical and center
Rem ===============Custom Define Variable============================
Rem -----------------------------------------------------------------
Rem this argument used to CaptionAlignment function
Private Const ca_HorizontalCenter = 0
Private Const ca_VerticalCenter = 1
Private Const ca_Left = 2
Private Const ca_Right = 3
Private Const ca_Top = 4
Private Const ca_Bottom = 5
Private Const ca_Default = 6
Rem ----------------------------------------------------------------
Private oldBtnStyle As Long
Private SetFlg As Boolean
Private AlignmentStyle&
'Alignment button caption
'Argument :
' btnhWnd button handle
' AlignmentStyle 0 default) Horizontal center
' 1) Vertical center
' 2) Alignment left
' 3) Alignment Right
' 4) Alignment top
' 5) Alignment bottom
' 6) restore original style
'@Note : only use to button text
Public Function CaptionAlignment(ByVal btnhWnd As Long, Optional AlignmentStyle As Integer = 0) As Boolean
Dim lngStyle As Long
Dim lngAlignment As Long
Dim Rtn&
On Error GoTo Alignment_Error
If btnhWnd = 0 Then GoTo Alignment_Error
CaptionAlignment = True
If Not SetFlg Then
SetFlg = True
oldBtnStyle = GetWindowLong(btnhWnd, GWL_STYLE) 'get original style
End If
Select Case AlignmentStyle
Case ca_HorizontalCenter 'horizontal center
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not (BS_LEFT Or BS_RIGHT)
lngAlignment = BS_CENTER
Case ca_VerticalCenter 'vertical center
lngAlignment = BS_CENTER
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not (BS_TOP Or BS_BOTTOM)
Case ca_Left 'left
lngAlignment = BS_LEFT
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not BS_RIGHT
Case ca_Right 'right
lngAlignment = BS_RIGHT
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not BS_LEFT
Case ca_Top 'top
lngAlignment = BS_TOP
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not BS_BOTTOM
Case ca_Bottom 'bottom
lngAlignment = BS_BOTTOM
lngStyle = GetWindowLong(btnhWnd, GWL_STYLE) And Not BS_TOP
Case ca_Default 'restore original style
lngAlignment = oldBtnStyle
If lngAlignment = 0 Then Exit Function
Rtn = SetWindowLong(btnhWnd, GWL_STYLE, lngAlignment)
Exit Function
End Select
'set position
Rtn = SetWindowLong(btnhWnd, GWL_STYLE, lngStyle Or lngAlignment)
Exit Function
Alignment_Error:
CaptionAlignment = False
End Function
这是command控件caption德对齐方式。
#3
Rem =====================API Function Define=========================================================================
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 GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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 Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Rem =====================API Constant Define=========================================================================
Private Const HWND_BOTTOM = 1 'set to bottom of Z ordering
Private Const HWND_NOTOPMOST = -2 'not topmost
Private Const HWND_TOPMOST = -1 'set to top of all window
Private Const HWND_TOP = 0 'Set to Top of Z ordering
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'below constant is used to GetWindowLong function
Private Const GWL_STYLE = (-16) 'Window field offset
Private Const GWL_EXSTYLE = (-20)
Private Const GWL_HINSTANCE = (-6)
Private Const GWL_HWNDPARENT = (-8)
Private Const GWL_ID = (-12)
Private Const GWL_USERDATA = (-21)
Private Const GWL_WNDPROC = (-4)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const WS_CAPTION = &HC00000 ' WS_BORDER Or WS_DLGFRAME
Private Const WS_BORDER = &H800000
Private Const WS_CHILD = &H40000000
Private Const WS_CHILDWINDOW = (WS_CHILD)
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_DISABLED = &H8000000
Private Const WS_DLGFRAME = &H400000
Private Const WS_EX_ACCEPTFILES = &H10&
Private Const WS_EX_DLGMODALFRAME = &H1&
Private Const WS_EX_NOPARENTNOTIFY = &H4&
Private Const WS_EX_TOPMOST = &H8&
Private Const WS_EX_TRANSPARENT = &H20&
Private Const WS_GROUP = &H20000
Private Const WS_HSCROLL = &H100000
Private Const WS_MAXIMIZE = &H1000000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_ICONIC = WS_MINIMIZE
Private Const WS_OVERLAPPED = &H0&
Private Const WS_POPUP = &H80000000
Private Const WS_SYSMENU = &H80000
Private Const WS_POPUPWINDOW = (WS_POPUP Or WS_BORDER Or WS_SYSMENU)
Private Const WS_TABSTOP = &H10000
Private Const WS_THICKFRAME = &H40000
Private Const WS_TILED = WS_OVERLAPPED
Private Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
Private Const WS_TILEDWINDOW = WS_OVERLAPPEDWINDOW
Private Const WS_SIZEBOX = WS_THICKFRAME
Private Const WS_VISIBLE = &H10000000
Private Const WS_VSCROLL = &H200000
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const WM_USER = &H400
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_MBUTTONDOWN = &H207
Private Const WM_MBUTTONUP = &H208
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Rem =====================API Type Define=============================================================================
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'this enumerable type is used to SetWindowPos function
Private Enum WndPosStyle
SWP_FRAMECHANGED = &H20 ' The frame changed: send WM_NCCALCSIZE
SWP_DRAWFRAME = SWP_FRAMECHANGED
SWP_HIDEWINDOW = &H80
SWP_NOACTIVATE = &H10
SWP_NOCOPYBITS = &H100
SWP_NOMOVE = &H2
SWP_NOOWNERZORDER = &H200 ' Don't do owner Z ordering
SWP_NOREDRAW = &H8
SWP_NOREPOSITION = SWP_NOOWNERZORDER
SWP_NOSIZE = &H1
SWP_NOZORDER = &H4
SWP_SHOWWINDOW = &H40
End Enum
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Rem =====================Custom Define Variable======================================================================
Private mWndRect As RECT
Private mWndCaption As String
'--------------------------------------------------------------------------------------------------------------------
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'$$ set ordering for window $$
'$$ hWnd handle of window $$
'$$ orderflg ordering style $$
'$$ 0) set to bottom of $$
'$$ Z ordering $$
'$$ 1) not topmost $$
'$$ 2) Set to Top of Z ordering$$
'$$ 3) set to top of all window$$
'$$ ReturnValue $$
'$$ true success $$
'$$ false fail $$
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
Public Function SetWindowOrder(ByVal hwnd As Long, Optional OrderFlg As Integer = 0) As Boolean
Dim Style As Long
Dim Rtn&
Dim X As Long
Dim Y As Long
Dim WndWidth As Long
Dim WndHeight As Long
Dim wFlag As Long
'first get rectangle of window
Rtn = GetWindowRect(hwnd, mWndRect)
If Rtn Then
'success
wFlag = SWP_SHOWWINDOW
With mWndRect
X = .Left
Y = .Top
WndWidth = .Right - .Left
WndHeight = .Bottom - .Top
End With
Else
'fail,ingore (X,Y,CX,CY) argument
wFlag = SWP_NOMOVE Or SWP_NOSIZE
End If
Select Case OrderFlg
Case 0 'set to bottom of Z ordering
Style = HWND_BOTTOM
Case 1 'not topmost
Style = HWND_NOTOPMOST
Case 2 'Set to Top of Z ordering
Style = HWND_TOP
Case 3 'set to top of all window
Style = HWND_TOPMOST
End Select
SetWindowOrder = SetWindowPos(hwnd, Style, X, Y, WndWidth, WndHeight, wFlag)
End Function
这是改变窗体z-order顺的函数
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 GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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 Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Rem =====================API Constant Define=========================================================================
Private Const HWND_BOTTOM = 1 'set to bottom of Z ordering
Private Const HWND_NOTOPMOST = -2 'not topmost
Private Const HWND_TOPMOST = -1 'set to top of all window
Private Const HWND_TOP = 0 'Set to Top of Z ordering
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'below constant is used to GetWindowLong function
Private Const GWL_STYLE = (-16) 'Window field offset
Private Const GWL_EXSTYLE = (-20)
Private Const GWL_HINSTANCE = (-6)
Private Const GWL_HWNDPARENT = (-8)
Private Const GWL_ID = (-12)
Private Const GWL_USERDATA = (-21)
Private Const GWL_WNDPROC = (-4)
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const WS_CAPTION = &HC00000 ' WS_BORDER Or WS_DLGFRAME
Private Const WS_BORDER = &H800000
Private Const WS_CHILD = &H40000000
Private Const WS_CHILDWINDOW = (WS_CHILD)
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CLIPSIBLINGS = &H4000000
Private Const WS_DISABLED = &H8000000
Private Const WS_DLGFRAME = &H400000
Private Const WS_EX_ACCEPTFILES = &H10&
Private Const WS_EX_DLGMODALFRAME = &H1&
Private Const WS_EX_NOPARENTNOTIFY = &H4&
Private Const WS_EX_TOPMOST = &H8&
Private Const WS_EX_TRANSPARENT = &H20&
Private Const WS_GROUP = &H20000
Private Const WS_HSCROLL = &H100000
Private Const WS_MAXIMIZE = &H1000000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_ICONIC = WS_MINIMIZE
Private Const WS_OVERLAPPED = &H0&
Private Const WS_POPUP = &H80000000
Private Const WS_SYSMENU = &H80000
Private Const WS_POPUPWINDOW = (WS_POPUP Or WS_BORDER Or WS_SYSMENU)
Private Const WS_TABSTOP = &H10000
Private Const WS_THICKFRAME = &H40000
Private Const WS_TILED = WS_OVERLAPPED
Private Const WS_OVERLAPPEDWINDOW = (WS_OVERLAPPED Or WS_CAPTION Or WS_SYSMENU Or WS_THICKFRAME Or WS_MINIMIZEBOX Or WS_MAXIMIZEBOX)
Private Const WS_TILEDWINDOW = WS_OVERLAPPEDWINDOW
Private Const WS_SIZEBOX = WS_THICKFRAME
Private Const WS_VISIBLE = &H10000000
Private Const WS_VSCROLL = &H200000
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Const WM_USER = &H400
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_LBUTTONUP = &H202
Private Const WM_MBUTTONDOWN = &H207
Private Const WM_MBUTTONUP = &H208
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_RBUTTONUP = &H205
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Rem =====================API Type Define=============================================================================
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'this enumerable type is used to SetWindowPos function
Private Enum WndPosStyle
SWP_FRAMECHANGED = &H20 ' The frame changed: send WM_NCCALCSIZE
SWP_DRAWFRAME = SWP_FRAMECHANGED
SWP_HIDEWINDOW = &H80
SWP_NOACTIVATE = &H10
SWP_NOCOPYBITS = &H100
SWP_NOMOVE = &H2
SWP_NOOWNERZORDER = &H200 ' Don't do owner Z ordering
SWP_NOREDRAW = &H8
SWP_NOREPOSITION = SWP_NOOWNERZORDER
SWP_NOSIZE = &H1
SWP_NOZORDER = &H4
SWP_SHOWWINDOW = &H40
End Enum
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Rem =====================Custom Define Variable======================================================================
Private mWndRect As RECT
Private mWndCaption As String
'--------------------------------------------------------------------------------------------------------------------
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'$$ set ordering for window $$
'$$ hWnd handle of window $$
'$$ orderflg ordering style $$
'$$ 0) set to bottom of $$
'$$ Z ordering $$
'$$ 1) not topmost $$
'$$ 2) Set to Top of Z ordering$$
'$$ 3) set to top of all window$$
'$$ ReturnValue $$
'$$ true success $$
'$$ false fail $$
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
Public Function SetWindowOrder(ByVal hwnd As Long, Optional OrderFlg As Integer = 0) As Boolean
Dim Style As Long
Dim Rtn&
Dim X As Long
Dim Y As Long
Dim WndWidth As Long
Dim WndHeight As Long
Dim wFlag As Long
'first get rectangle of window
Rtn = GetWindowRect(hwnd, mWndRect)
If Rtn Then
'success
wFlag = SWP_SHOWWINDOW
With mWndRect
X = .Left
Y = .Top
WndWidth = .Right - .Left
WndHeight = .Bottom - .Top
End With
Else
'fail,ingore (X,Y,CX,CY) argument
wFlag = SWP_NOMOVE Or SWP_NOSIZE
End If
Select Case OrderFlg
Case 0 'set to bottom of Z ordering
Style = HWND_BOTTOM
Case 1 'not topmost
Style = HWND_NOTOPMOST
Case 2 'Set to Top of Z ordering
Style = HWND_TOP
Case 3 'set to top of all window
Style = HWND_TOPMOST
End Select
SetWindowOrder = SetWindowPos(hwnd, Style, X, Y, WndWidth, WndHeight, wFlag)
End Function
这是改变窗体z-order顺的函数
#4
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
'$$ take out the caption bar of window $$
'$$ hWnd handle of form $$
'$$ ThrowOffFlg:optional argument $$
'$$ true god rid of the caption $$
'$$ false restore original caption $$
'$$ ReturnValue $$
'$$ True success $$
'$$ False fail $$
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
Public Function ThrowOffWndCaption(ByVal hwnd As Long, Optional ThrowOffFlg As Boolean = True) As Boolean
Dim lStyle As Long
Dim Rtn&
Dim wFlags As Long
ThrowOffWndCaption = True
'set new style for window
wFlags = SWP_NOMOVE Or SWP_NOSIZE Or SWP_FRAMECHANGED Or SWP_NOREPOSITION Or SWP_NOZORDER
mWndCaption = String(255, 0)
'first get caption or window
Rtn = GetWindowText(hwnd, mWndCaption, Len(mWndCaption))
If Rtn >= 0 Then mWndCaption = Left(mWndCaption, Rtn)
'get original style of window
lStyle = GetWindowLong(hwnd, GWL_STYLE)
If (ThrowOffFlg) Then 'god rid of the caption
lStyle = lStyle And Not WS_CAPTION
lStyle = lStyle And Not WS_MAXIMIZEBOX
lStyle = lStyle And Not WS_MINIMIZEBOX
lStyle = lStyle And Not WS_SYSMENU
Else 'restore original caption
lStyle = lStyle Or WS_CAPTION
lStyle = lStyle Or WS_MAXIMIZEBOX
lStyle = lStyle Or WS_MINIMIZEBOX
lStyle = lStyle Or WS_SYSMENU
'set original caption of window
If mWndCaption <> "" Then Rtn = SetWindowText(hwnd, mWndCaption)
End If
'set new style for window
Rtn = SetWindowLong(hwnd, GWL_STYLE, lStyle)
If Rtn < 0 Then GoTo ThrowOff_Error
'set position for window
Rtn = SetWindowPos(hwnd, 0&, 0, 0, 0, 0, wFlags)
If Rtn < 0 Then GoTo ThrowOff_Error
Exit Function
ThrowOff_Error:
ThrowOffWndCaption = False
End Function
这是去掉或恢复窗体标题的函数。
'$$ take out the caption bar of window $$
'$$ hWnd handle of form $$
'$$ ThrowOffFlg:optional argument $$
'$$ true god rid of the caption $$
'$$ false restore original caption $$
'$$ ReturnValue $$
'$$ True success $$
'$$ False fail $$
'$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
Public Function ThrowOffWndCaption(ByVal hwnd As Long, Optional ThrowOffFlg As Boolean = True) As Boolean
Dim lStyle As Long
Dim Rtn&
Dim wFlags As Long
ThrowOffWndCaption = True
'set new style for window
wFlags = SWP_NOMOVE Or SWP_NOSIZE Or SWP_FRAMECHANGED Or SWP_NOREPOSITION Or SWP_NOZORDER
mWndCaption = String(255, 0)
'first get caption or window
Rtn = GetWindowText(hwnd, mWndCaption, Len(mWndCaption))
If Rtn >= 0 Then mWndCaption = Left(mWndCaption, Rtn)
'get original style of window
lStyle = GetWindowLong(hwnd, GWL_STYLE)
If (ThrowOffFlg) Then 'god rid of the caption
lStyle = lStyle And Not WS_CAPTION
lStyle = lStyle And Not WS_MAXIMIZEBOX
lStyle = lStyle And Not WS_MINIMIZEBOX
lStyle = lStyle And Not WS_SYSMENU
Else 'restore original caption
lStyle = lStyle Or WS_CAPTION
lStyle = lStyle Or WS_MAXIMIZEBOX
lStyle = lStyle Or WS_MINIMIZEBOX
lStyle = lStyle Or WS_SYSMENU
'set original caption of window
If mWndCaption <> "" Then Rtn = SetWindowText(hwnd, mWndCaption)
End If
'set new style for window
Rtn = SetWindowLong(hwnd, GWL_STYLE, lStyle)
If Rtn < 0 Then GoTo ThrowOff_Error
'set position for window
Rtn = SetWindowPos(hwnd, 0&, 0, 0, 0, 0, wFlags)
If Rtn < 0 Then GoTo ThrowOff_Error
Exit Function
ThrowOff_Error:
ThrowOffWndCaption = False
End Function
这是去掉或恢复窗体标题的函数。
#5
保存图片到数据库
private sub save()
Dim Chunk() As Byte
Filename="a.jpg"
Chunk() = Image2Chunk(Filename)
rs.Fields("thumb").AppendChunk Chunk()
rs.Update
end sub
Private Function Image2Chunk(Filename As String) As Variant
On Error GoTo ProcErr
Dim Datafile As Integer
Dim FileLength As Long
Dim Chunk() As Byte
Datafile = FreeFile
Open Filename For Binary Access Read As Datafile
FileLength = LOF(Datafile)
If FileLength = 0 Then GoTo ProcErr
ReDim Chunk(FileLength)
Get Datafile, , Chunk()
Close Datafile
ProcExit:
Image2Chunk = Chunk()
Exit Function
ProcErr:
Image2Chunk = 0
End Function
private sub save()
Dim Chunk() As Byte
Filename="a.jpg"
Chunk() = Image2Chunk(Filename)
rs.Fields("thumb").AppendChunk Chunk()
rs.Update
end sub
Private Function Image2Chunk(Filename As String) As Variant
On Error GoTo ProcErr
Dim Datafile As Integer
Dim FileLength As Long
Dim Chunk() As Byte
Datafile = FreeFile
Open Filename For Binary Access Read As Datafile
FileLength = LOF(Datafile)
If FileLength = 0 Then GoTo ProcErr
ReDim Chunk(FileLength)
Get Datafile, , Chunk()
Close Datafile
ProcExit:
Image2Chunk = Chunk()
Exit Function
ProcErr:
Image2Chunk = 0
End Function
#6
有两位高手捧场了，真是荣幸，还是这样散分的效果好。大侠们慢慢整理啊，不急，我先离开一段时间，等20个好东西收齐。
#7
下面以问答方式给出一些简单常用问题：
问：如何让VB应用程序中的连接具有超级链接效果？
答：我们以一个网址链接为例，讲解实现的方法。
首先我们新建一表单,在表单中加入一标签,Caption属性为http://ses518.8u8.com/，MouseIcon值为操作系统下Curors目录里的Hand.ico文件，MousePointer值为99。
在标签的MouseMove事件中加入如下代码:
Label1.ForeColor=&&HFF
在表单的MouseMove事件中加入如下代码:
Label1.ForeColor=&&HFF0000
在标签的Click事件中加入如下代码:
Dim a As String
a=Shell("Explorer.exe http://ses518.8u8.com/",3)
问：在VB应用程序中，如何取消窗体右上角的关闭功能？
答：如果你不想别人使用程序时直接用右上角的关闭功能来关闭程序,可用以下代码来实现该功能。
在Form_Unload事件中加入代码:Cancel=True即可。
即:Private Sub Form_Unload(Cancel As Integer)
Cancel=True
End Sub
如果你想在关闭程序时提示是否关闭,可在Form_Unload事件中加入一个判断语句：
Private Sub Form_Unload(Cancel As Integer)
Cancel=True
Select Case msgbox ("您真的想关闭吗?" ,VbOkCancel) '应加上括号，要用到返回值，所以以函数格式调用
Case VbOk
Cancel=False
Case Else
Cancel=True
End Select
End Sub
问：如何在VB应用程序下关闭其它运行的Windows程序？
答：如果你想用自己的程序关闭正在运行的Windows其它程序,可用以下代码来实现。
首先声明两个函数:
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function PostMessage Lib "user32" Alias "PostMessageA"(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
例如要检测“计算器”程序是否正在运行，如果是则关闭它，可以使用如下代码来实现:
Dim winHwnd As Long
Dim RetVal As Long
winHwnd=FindWindow(vbNullString,"计算器")
If winHwnd〈〉0 Then
RetVal = PostMessage(winHwnd, &&H10, 0&&, 0&&)
If RetVal = 0 Then
MsgBox "关闭计算器出错!"
End If
Else
MsgBox "计算器程序没有运行。"
End If
问：在应用程序中如何编程实现禁用热键(包括Ctrl+Alt+Delete和所有功能键)？
答：如果你想做个屏保或禁止别人使用热键(包括Ctrl+Alt+Delete),以下代码可以实现：
首先定义一常量：
Private Const SPI_SCREENSAVERRUNNING = 97&&
进行函数声明：
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long,lpvParam As Any,ByVal fuWinIni As Long) As Long
再定义一个子过程：
Public Sub AllowKeys(bParam As Boolean)
Dim lRetVal As Long, bOld As Boolean
lRetVal = SystemParametersInfo(SPI_SCREENSAVERRUNNING, bParam, bOld, 0&&)
End Sub
最后，在任意事件中加入AllowKeys(True/False),当AllowKeys为真时会禁止所有热键。
问：在VB应用程序中，如何实现窗体的简易移动？
答：如果你的窗体不需要标题栏,又希望能移动它,像WinAmp一样,有个简易移动,我们可以利用以下代码实现：
Declare Function ReleaseCapture Lib "user32" () As Long
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 Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &&HA1
下面是将功能加入窗体的MouseDowm事件中,你也可将其加入其它控件的事件中：
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'以下二行代码可加入各控件的MouseDown之中
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&&
窗体在屏幕中居中代码:
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
希望对大家有所帮助~!!!
问：如何让VB应用程序中的连接具有超级链接效果？
答：我们以一个网址链接为例，讲解实现的方法。
首先我们新建一表单,在表单中加入一标签,Caption属性为http://ses518.8u8.com/，MouseIcon值为操作系统下Curors目录里的Hand.ico文件，MousePointer值为99。
在标签的MouseMove事件中加入如下代码:
Label1.ForeColor=&&HFF
在表单的MouseMove事件中加入如下代码:
Label1.ForeColor=&&HFF0000
在标签的Click事件中加入如下代码:
Dim a As String
a=Shell("Explorer.exe http://ses518.8u8.com/",3)
问：在VB应用程序中，如何取消窗体右上角的关闭功能？
答：如果你不想别人使用程序时直接用右上角的关闭功能来关闭程序,可用以下代码来实现该功能。
在Form_Unload事件中加入代码:Cancel=True即可。
即:Private Sub Form_Unload(Cancel As Integer)
Cancel=True
End Sub
如果你想在关闭程序时提示是否关闭,可在Form_Unload事件中加入一个判断语句：
Private Sub Form_Unload(Cancel As Integer)
Cancel=True
Select Case msgbox ("您真的想关闭吗?" ,VbOkCancel) '应加上括号，要用到返回值，所以以函数格式调用
Case VbOk
Cancel=False
Case Else
Cancel=True
End Select
End Sub
问：如何在VB应用程序下关闭其它运行的Windows程序？
答：如果你想用自己的程序关闭正在运行的Windows其它程序,可用以下代码来实现。
首先声明两个函数:
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function PostMessage Lib "user32" Alias "PostMessageA"(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
例如要检测“计算器”程序是否正在运行，如果是则关闭它，可以使用如下代码来实现:
Dim winHwnd As Long
Dim RetVal As Long
winHwnd=FindWindow(vbNullString,"计算器")
If winHwnd〈〉0 Then
RetVal = PostMessage(winHwnd, &&H10, 0&&, 0&&)
If RetVal = 0 Then
MsgBox "关闭计算器出错!"
End If
Else
MsgBox "计算器程序没有运行。"
End If
问：在应用程序中如何编程实现禁用热键(包括Ctrl+Alt+Delete和所有功能键)？
答：如果你想做个屏保或禁止别人使用热键(包括Ctrl+Alt+Delete),以下代码可以实现：
首先定义一常量：
Private Const SPI_SCREENSAVERRUNNING = 97&&
进行函数声明：
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long,lpvParam As Any,ByVal fuWinIni As Long) As Long
再定义一个子过程：
Public Sub AllowKeys(bParam As Boolean)
Dim lRetVal As Long, bOld As Boolean
lRetVal = SystemParametersInfo(SPI_SCREENSAVERRUNNING, bParam, bOld, 0&&)
End Sub
最后，在任意事件中加入AllowKeys(True/False),当AllowKeys为真时会禁止所有热键。
问：在VB应用程序中，如何实现窗体的简易移动？
答：如果你的窗体不需要标题栏,又希望能移动它,像WinAmp一样,有个简易移动,我们可以利用以下代码实现：
Declare Function ReleaseCapture Lib "user32" () As Long
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 Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &&HA1
下面是将功能加入窗体的MouseDowm事件中,你也可将其加入其它控件的事件中：
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'以下二行代码可加入各控件的MouseDown之中
ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&&
窗体在屏幕中居中代码:
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
希望对大家有所帮助~!!!
#8
保存图片到数据库，也是我的问题，看到不少网友问过这个问题（就是刚才在网易的社区里还有人发贴问呢）。谢了。
#9
可能一些人需要这个
用ADO创建Access数据库
作者: QinJia 浏览: 59 次
当我们写完一个数据库应用程序时必须作成安装盘发行，在制作安装盘时因为顾及到数据库的安装，我们一般将数据库也加到数据库中去，但我们也碰到一些问题，如果该数据库应用程序是针对某一用户而开发的话那就没有什么问题，当您开发的是一个软件时您就不可能将该数据库放到安装盘去了，必须用代码来生成该数据库。这个生成数据库的方法在DAO的年代非常的容易，但随着VB6和ACCESS2000的到来我们是不是应该用新的方法来创建呢？我们当然应该用ADO来创建数据库了，但可惜的是用ADODB来创建他根本是不可能的，因为ADODB中根本没有DATABASE这个对象，不用说创建DATABASE了，就连创建TABLE都难，原因是一样的因为ADODB不支持FIELD对象，创建TABLE还可以用SQL语句和ADODB中的Excute创建，但创建数据库就难了，以下我就介绍一下用ADO创建数据库的方法.
一、用VB6新建一工程，然后引用 ADOX,（ADOX是ACCESS2000自带的，可以在VB6的引用中找到Microsoft ADO2.1 Ext For DLL and Security,引用它）关于ADX的对象、属性以及方法你可以到ACCESS2000的帮助中找到。
二、打开工程，创建数据库的代码如下：
Sub CreateDatabase()
'Reference Microsoft ADO Extensions for DDL and Security (Install by Access2000)
Dim cat As New ADOX.Catalog
cat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\new.mdb"
End Sub
你可以在主程序中调用该程序用以创建数据库,程序中的红色部分即为数据库的路径以及名称。
以上程序在VB6英文企业版SP3中调试通过。
用ADO创建Access数据库
作者: QinJia 浏览: 59 次
当我们写完一个数据库应用程序时必须作成安装盘发行，在制作安装盘时因为顾及到数据库的安装，我们一般将数据库也加到数据库中去，但我们也碰到一些问题，如果该数据库应用程序是针对某一用户而开发的话那就没有什么问题，当您开发的是一个软件时您就不可能将该数据库放到安装盘去了，必须用代码来生成该数据库。这个生成数据库的方法在DAO的年代非常的容易，但随着VB6和ACCESS2000的到来我们是不是应该用新的方法来创建呢？我们当然应该用ADO来创建数据库了，但可惜的是用ADODB来创建他根本是不可能的，因为ADODB中根本没有DATABASE这个对象，不用说创建DATABASE了，就连创建TABLE都难，原因是一样的因为ADODB不支持FIELD对象，创建TABLE还可以用SQL语句和ADODB中的Excute创建，但创建数据库就难了，以下我就介绍一下用ADO创建数据库的方法.
一、用VB6新建一工程，然后引用 ADOX,（ADOX是ACCESS2000自带的，可以在VB6的引用中找到Microsoft ADO2.1 Ext For DLL and Security,引用它）关于ADX的对象、属性以及方法你可以到ACCESS2000的帮助中找到。
二、打开工程，创建数据库的代码如下：
Sub CreateDatabase()
'Reference Microsoft ADO Extensions for DDL and Security (Install by Access2000)
Dim cat As New ADOX.Catalog
cat.Create "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\new.mdb"
End Sub
你可以在主程序中调用该程序用以创建数据库,程序中的红色部分即为数据库的路径以及名称。
以上程序在VB6英文企业版SP3中调试通过。
#10
在发一个
如何使用 ADO 來压缩或修复 Microsoft Access 文件
以前使用 DAO 時，Microsoft 有提供 CompactDatabase Method 來压缩 Microsoft Access 文件，RepairDatabase Method 來修复损坏的 Microsoft Access 文件，。可是自从 ADO 出來之后，好像忘了提供相对的压缩及修复 Microsoft Access 文件的功能。
現在 Microsoft 发现了这个问题了，也提供了解決方法，不过有版本上的限制！限制說明如下：
ActiveX Data Objects (ADO), version 2.1
Microsoft OLE DB Provider for Jet, version 4.0
這是 Microsoft 提出的 ADO 的延伸功能：Microsoft Jet OLE DB Provider and Replication Objects (JRO)
这个功能在 JET OLE DB Provider version 4.0 (Msjetoledb40.dll) 及 JRO version 2.1 (Msjro.dll) 中第一次被提出！
這些必要的 DLL 文件在您安裝了 MDAC 2.1 之后就有了，您可以在以下的网页中下载 MDAC 的最新版本！
Universal Data Access Web Site
在下载之前先到 VB6 中檢查一下，【控件】【設定引用項目】中的 Microsoft Jet and Replication Objects X.X library 如果已经是 2.1 以上的版本，您就可以不用下载了！
在您安裝了 MDAC 2.1 或以上的版本之后，您就可以使用 ADO 來压缩或修复 Microsoft Access 文件，下面的步骤告訴您如何使用 CompactDatabase Method 來压缩 Microsoft Access 文件：
1、新建一個新表单，选择功能表中的【控件】【設定引用項目】。
2、加入 Microsoft Jet and Replication Objects X.X library，其中 ( X.X 大于或等于 2.1 )。
3、在适当的地方加入以下的程序代码，記得要修改 data source 的內容及目地文件的路径：
Dim jro As jro.JetEngine
Set jro = New jro.JetEngine
jro.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d:\\nwind2.mdb", _ '來源文件
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d:\\abbc2.mdb;Jet OLEDB:Engine Type=4" '目的文件
在 DAO 3.60 之后，RepairDatabase Method 已经无法使用了，以上的程序代码显示了 ADO CompactDatabase Method 的用法，而它也取代了 DAO 3.5 時的 RepairDatabase method！
如何使用 ADO 來压缩或修复 Microsoft Access 文件
以前使用 DAO 時，Microsoft 有提供 CompactDatabase Method 來压缩 Microsoft Access 文件，RepairDatabase Method 來修复损坏的 Microsoft Access 文件，。可是自从 ADO 出來之后，好像忘了提供相对的压缩及修复 Microsoft Access 文件的功能。
現在 Microsoft 发现了这个问题了，也提供了解決方法，不过有版本上的限制！限制說明如下：
ActiveX Data Objects (ADO), version 2.1
Microsoft OLE DB Provider for Jet, version 4.0
這是 Microsoft 提出的 ADO 的延伸功能：Microsoft Jet OLE DB Provider and Replication Objects (JRO)
这个功能在 JET OLE DB Provider version 4.0 (Msjetoledb40.dll) 及 JRO version 2.1 (Msjro.dll) 中第一次被提出！
這些必要的 DLL 文件在您安裝了 MDAC 2.1 之后就有了，您可以在以下的网页中下载 MDAC 的最新版本！
Universal Data Access Web Site
在下载之前先到 VB6 中檢查一下，【控件】【設定引用項目】中的 Microsoft Jet and Replication Objects X.X library 如果已经是 2.1 以上的版本，您就可以不用下载了！
在您安裝了 MDAC 2.1 或以上的版本之后，您就可以使用 ADO 來压缩或修复 Microsoft Access 文件，下面的步骤告訴您如何使用 CompactDatabase Method 來压缩 Microsoft Access 文件：
1、新建一個新表单，选择功能表中的【控件】【設定引用項目】。
2、加入 Microsoft Jet and Replication Objects X.X library，其中 ( X.X 大于或等于 2.1 )。
3、在适当的地方加入以下的程序代码，記得要修改 data source 的內容及目地文件的路径：
Dim jro As jro.JetEngine
Set jro = New jro.JetEngine
jro.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d:\\nwind2.mdb", _ '來源文件
"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=d:\\abbc2.mdb;Jet OLEDB:Engine Type=4" '目的文件
在 DAO 3.60 之后，RepairDatabase Method 已经无法使用了，以上的程序代码显示了 ADO CompactDatabase Method 的用法，而它也取代了 DAO 3.5 時的 RepairDatabase method！
#11
12个了。哈哈。
#12
up
#13
mark
#14
hi~!
#15
字符集 (0–127)
0 ?/FONT> 32 [space] 64 @ 96 `
1 · 33 ! 65 A 97 a
2 · 34 " 66 B 98 b
3 · 35 # 67 C 99 c
4 · 36 $ 68 D 100 d
5 · 37 % 69 E 101 e
6 · 38 & 70 F 102 f
7 · 39 ' 71 G 103 g
8 * * 40 ( 72 H 104 h
9 * * 41 ) 73 I 105 i
10 * * 42 * 74 J 106 j
11 · 43 + 75 K 107 k
12 · 44 , 76 L 108 l
13 * * 45 - 77 M 109 m
14 · 46 . 78 N 110 n
15 · 47 / 79 O 111 o
16 · 48 0 80 P 112 p
17 · 49 1 81 Q 113 q
18 · 50 2 82 R 114 r
19 · 51 3 83 S 115 s
20 · 52 4 84 T 116 t
21 · 53 5 85 U 117 u
22 · 54 6 86 V 118 v
23 · 55 7 87 W 119 w
24 · 56 8 88 X 120 x
25 · 57 9 89 Y 121 y
26 · 58 : 90 Z 122 z
27 · 59 ; 91 [ 123 {
28 · 60 < 92 \ 124 |
29 · 61 = 93 ] 125 }
30 · 62 > 94 ^ 126 ~
31 · 63 ? 95 _ 127 ·
*·Microsoft Windows.不支持这些字符。
* *值 8、9、10 和 13 分别转换为退格、制表、换行和回车字符。它们并没有特定的图形显示，但会依不同的应用程序，而对文本显示有不同的影响。
字符运用示例：
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then'用户按下Enter键
Command1.SetFocus
End If
If KeyAscii >= 65 And KeyAscii <= 90 Then 'A~Z
KeyAscii = Asc(UCase(Chr(KeyAscii)))
ElseIf KeyAscii >= 97 And KeyAscii <= 122 Then 'a~z
KeyAscii = Asc(UCase(Chr(KeyAscii)))
ElseIf KeyAscii >= 48 And KeyAscii <= 57 Then '0~9
ElseIf KeyAscii = 8 Then
Else
KeyAscii = 0
End If
End Sub
0 ?/FONT> 32 [space] 64 @ 96 `
1 · 33 ! 65 A 97 a
2 · 34 " 66 B 98 b
3 · 35 # 67 C 99 c
4 · 36 $ 68 D 100 d
5 · 37 % 69 E 101 e
6 · 38 & 70 F 102 f
7 · 39 ' 71 G 103 g
8 * * 40 ( 72 H 104 h
9 * * 41 ) 73 I 105 i
10 * * 42 * 74 J 106 j
11 · 43 + 75 K 107 k
12 · 44 , 76 L 108 l
13 * * 45 - 77 M 109 m
14 · 46 . 78 N 110 n
15 · 47 / 79 O 111 o
16 · 48 0 80 P 112 p
17 · 49 1 81 Q 113 q
18 · 50 2 82 R 114 r
19 · 51 3 83 S 115 s
20 · 52 4 84 T 116 t
21 · 53 5 85 U 117 u
22 · 54 6 86 V 118 v
23 · 55 7 87 W 119 w
24 · 56 8 88 X 120 x
25 · 57 9 89 Y 121 y
26 · 58 : 90 Z 122 z
27 · 59 ; 91 [ 123 {
28 · 60 < 92 \ 124 |
29 · 61 = 93 ] 125 }
30 · 62 > 94 ^ 126 ~
31 · 63 ? 95 _ 127 ·
*·Microsoft Windows.不支持这些字符。
* *值 8、9、10 和 13 分别转换为退格、制表、换行和回车字符。它们并没有特定的图形显示，但会依不同的应用程序，而对文本显示有不同的影响。
字符运用示例：
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then'用户按下Enter键
Command1.SetFocus
End If
If KeyAscii >= 65 And KeyAscii <= 90 Then 'A~Z
KeyAscii = Asc(UCase(Chr(KeyAscii)))
ElseIf KeyAscii >= 97 And KeyAscii <= 122 Then 'a~z
KeyAscii = Asc(UCase(Chr(KeyAscii)))
ElseIf KeyAscii >= 48 And KeyAscii <= 57 Then '0~9
ElseIf KeyAscii = 8 Then
Else
KeyAscii = 0
End If
End Sub
#16
在凑个热闹...
'===============================
'URLEncode算法
'===============================
Const a As String = "http://www.microsoft.com"
Private Sub Command1_Click()
Dim c, d As String
Dim i As Long
For i = 1 To Len(a)
If Asc(Mid(a, i, 1)) < 0 Then
d = "%" & Right(CStr(Hex(Asc(Mid(a, i, 1)))), 2)
d = "%" & Left(CStr(Hex(Asc(Mid(a, i, 1)))), Len(CStr(Hex(Asc(Mid(a, i, 1))))) - 2) & d
c = c & d
ElseIf (Asc(Mid(a, i, 1)) >= 65 And Asc(Mid(a, i, 1)) <= 90) Or (Asc(Mid(a, i, 1)) >= 97 And Asc(Mid(a, i, 1)) <= 122) Then
c = c & Mid(a, i, 1)
Else
c = c & "%" & Hex(Asc(Mid(a, i, 1)))
End If
Next
MsgBox c
End Sub
'===============================
'URLEncode算法
'===============================
Const a As String = "http://www.microsoft.com"
Private Sub Command1_Click()
Dim c, d As String
Dim i As Long
For i = 1 To Len(a)
If Asc(Mid(a, i, 1)) < 0 Then
d = "%" & Right(CStr(Hex(Asc(Mid(a, i, 1)))), 2)
d = "%" & Left(CStr(Hex(Asc(Mid(a, i, 1)))), Len(CStr(Hex(Asc(Mid(a, i, 1))))) - 2) & d
c = c & d
ElseIf (Asc(Mid(a, i, 1)) >= 65 And Asc(Mid(a, i, 1)) <= 90) Or (Asc(Mid(a, i, 1)) >= 97 And Asc(Mid(a, i, 1)) <= 122) Then
c = c & Mid(a, i, 1)
Else
c = c & "%" & Hex(Asc(Mid(a, i, 1)))
End If
Next
MsgBox c
End Sub
#17
各位dx贴的时候说一下做什么用的，不然看的一头雾水。可能我水平低
#18
'####################################################################
'##get all index of multiline item in listbox ##
'##hWnd required,handle of listbox ##
'##ItemsIndex required,export array ##
'## save all index of multiline selection item ##
'##Length Optional,point to size of array ##
'## default value is zero, ##
'## namely its length is equal to 256 ##
'## elsewise use appointed value of customer ##
'##Return value: ##
'## -1 means is execution fail ##
'## elsewise return a count of selected item ##
'####################################################################
Public Function GetSelItems(ByVal hWnd As Long, ByRef ItemsIndex() As Long, Optional Length As Integer = 0) As Long
Dim Rtn&
Dim ItemNo() As Long
Dim Upper As Long
On Error GoTo Items_Error
Upper = IIf(Length <= 0, 256, Length)
ReDim ItemNo(0 To Upper)
'call api function
Rtn = SendMessage(hWnd, LB_GETSELITEMS, Upper, ItemNo(0))
If Rtn < 0 Then GoTo Items_Error
ItemsIndex = ItemNo
GetSelItems = Rtn
Exit Function
Items_Error:
GetSelItems = -1
End Function
得到listbox中所有多选条目的index
'##get all index of multiline item in listbox ##
'##hWnd required,handle of listbox ##
'##ItemsIndex required,export array ##
'## save all index of multiline selection item ##
'##Length Optional,point to size of array ##
'## default value is zero, ##
'## namely its length is equal to 256 ##
'## elsewise use appointed value of customer ##
'##Return value: ##
'## -1 means is execution fail ##
'## elsewise return a count of selected item ##
'####################################################################
Public Function GetSelItems(ByVal hWnd As Long, ByRef ItemsIndex() As Long, Optional Length As Integer = 0) As Long
Dim Rtn&
Dim ItemNo() As Long
Dim Upper As Long
On Error GoTo Items_Error
Upper = IIf(Length <= 0, 256, Length)
ReDim ItemNo(0 To Upper)
'call api function
Rtn = SendMessage(hWnd, LB_GETSELITEMS, Upper, ItemNo(0))
If Rtn < 0 Then GoTo Items_Error
ItemsIndex = ItemNo
GetSelItems = Rtn
Exit Function
Items_Error:
GetSelItems = -1
End Function
得到listbox中所有多选条目的index
#19
Private Const LB_GETSELITEMS = &H191 'get number of multiline item
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
忘写消息和api定义了
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
忘写消息和api定义了
#20
' 压缩 Access 数据库
Public Sub CompactJetDatabase(SourceFile As String, Optional Password As String, Optional BackupOriginal As Boolean = True)
On Error GoTo CompactErr
Dim strBackupFile As String
Dim strTempFile As String
' 判断来源文件是否存在
If Dir(SourceFile) <> "" Then
' 如果需要备份原文件
If BackupOriginal = True Then
strBackupFile = GetSourceFilePath(SourceFile) & "Backup.mdb"
If Dir(strBackupFile) <> "" Then
Kill strBackupFile
End If
FileCopy SourceFile, strBackupFile
End If
' 建立压缩文件名
strTempFile = GetSourceFilePath(SourceFile) & "Temp.mdb"
If Dir(strTempFile) <> "" Then
Kill strTempFile
End If
' 通过 DBEngine 压缩文件，注意，您必须引用 Microsoft DAO 3.xx Object Library
DBEngine.CompactDatabase SourceFile, strTempFile, , , ";Pwd=" & Password & ";"
' 删除旧文件
Kill SourceFile
' 重新命名新文件名
Name strTempFile As SourceFile
Else
MsgBox SourceFile & "File not fond！", vbExclamation
End If
CompactErr:
If Err.Number <> 0 Then
MsgBox Err.Description & Err.Number, vbCritical, "error"
End If
On Error GoTo 0
Exit Sub
End Sub
Public Function GetSourceFilePath(SourceFile As String) As String
Dim n As Integer
n = InStrRev(SourceFile, "\")
GetSourceFilePath = Left(SourceFile, n)
End Function
Public Function fBrowseForFolder(hWndOwner As Long, sPrompt As String) As String
Dim iNull As Integer
Dim lpIDList As Long
Dim lResult As Long
Dim sPath As String
Dim udtBI As BrowseInfo
With udtBI
.hWndOwner = hWndOwner
.lpszTitle = lstrcat(sPrompt, "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
lResult = SHGetPathFromIDList(lpIDList, sPath)
Call CoTaskMemFree(lpIDList)
iNull = InStr(sPath, vbNullChar)
If iNull Then sPath = Left$(sPath, iNull - 1)
End If
fBrowseForFolder = sPath
End Function
' 备份这个数据库
Public Function BackupDB(ByVal SourceFile As String, ByVal BackupFolderName As String) As Boolean
On Error Resume Next
Dim lFileOp As Long
Dim lResult As Long
Dim lFlags As Long
Dim SHFileOp As SHFILEOPSTRUCT
Dim strSourceDir As String
Dim strDestinationDir As String
Screen.MousePointer = vbHourglass
If Right(BackupFolderName, 1) <> "\" Then
BackupFolderName = BackupFolderName & "\"
End If
lFileOp = FO_COPY
lFlags = lFlags And Not FOF_SILENT
lFlags = lFlags Or FOF_NOCONFIRMATION
lFlags = lFlags Or FOF_NOCONFIRMMKDIR
lFlags = lFlags Or FOF_FILESONLY
With SHFileOp
.wFunc = lFileOp
.pFrom = SourceFile & vbNullChar
.pTo = BackupFolderName & "PMBackup" & Format(Date, "mmdd") & ".pmb"
.fFlags = lFlags
End With
lResult = SHFileOperation(SHFileOp)
BackupDB = (lResult = 0)
Screen.MousePointer = vbDefault
End Function
' 还原这个数据库
Public Function RestoreDB(ByVal SourceFile As String, ToFile As String) As Boolean
On Error Resume Next
Dim lFileOp As Long
Dim lResult As Long
Dim lFlags As Long
Dim SHFileOp As SHFILEOPSTRUCT
Screen.MousePointer = vbHourglass
lFileOp = FO_COPY
lFlags = lFlags And Not FOF_SILENT
lFlags = lFlags Or FOF_NOCONFIRMATION
lFlags = lFlags Or FOF_NOCONFIRMMKDIR
lFlags = lFlags Or FOF_FILESONLY
With SHFileOp
.wFunc = lFileOp
.pFrom = SourceFile & vbNullChar
.pTo = ToFile & vbNullChar
.fFlags = lFlags
End With
lResult = SHFileOperation(SHFileOp)
RestoreDB = (lResult = 0)
Screen.MousePointer = vbDefault
End Function
Public Sub CompactJetDatabase(SourceFile As String, Optional Password As String, Optional BackupOriginal As Boolean = True)
On Error GoTo CompactErr
Dim strBackupFile As String
Dim strTempFile As String
' 判断来源文件是否存在
If Dir(SourceFile) <> "" Then
' 如果需要备份原文件
If BackupOriginal = True Then
strBackupFile = GetSourceFilePath(SourceFile) & "Backup.mdb"
If Dir(strBackupFile) <> "" Then
Kill strBackupFile
End If
FileCopy SourceFile, strBackupFile
End If
' 建立压缩文件名
strTempFile = GetSourceFilePath(SourceFile) & "Temp.mdb"
If Dir(strTempFile) <> "" Then
Kill strTempFile
End If
' 通过 DBEngine 压缩文件，注意，您必须引用 Microsoft DAO 3.xx Object Library
DBEngine.CompactDatabase SourceFile, strTempFile, , , ";Pwd=" & Password & ";"
' 删除旧文件
Kill SourceFile
' 重新命名新文件名
Name strTempFile As SourceFile
Else
MsgBox SourceFile & "File not fond！", vbExclamation
End If
CompactErr:
If Err.Number <> 0 Then
MsgBox Err.Description & Err.Number, vbCritical, "error"
End If
On Error GoTo 0
Exit Sub
End Sub
Public Function GetSourceFilePath(SourceFile As String) As String
Dim n As Integer
n = InStrRev(SourceFile, "\")
GetSourceFilePath = Left(SourceFile, n)
End Function
Public Function fBrowseForFolder(hWndOwner As Long, sPrompt As String) As String
Dim iNull As Integer
Dim lpIDList As Long
Dim lResult As Long
Dim sPath As String
Dim udtBI As BrowseInfo
With udtBI
.hWndOwner = hWndOwner
.lpszTitle = lstrcat(sPrompt, "")
.ulFlags = BIF_RETURNONLYFSDIRS
End With
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
lResult = SHGetPathFromIDList(lpIDList, sPath)
Call CoTaskMemFree(lpIDList)
iNull = InStr(sPath, vbNullChar)
If iNull Then sPath = Left$(sPath, iNull - 1)
End If
fBrowseForFolder = sPath
End Function
' 备份这个数据库
Public Function BackupDB(ByVal SourceFile As String, ByVal BackupFolderName As String) As Boolean
On Error Resume Next
Dim lFileOp As Long
Dim lResult As Long
Dim lFlags As Long
Dim SHFileOp As SHFILEOPSTRUCT
Dim strSourceDir As String
Dim strDestinationDir As String
Screen.MousePointer = vbHourglass
If Right(BackupFolderName, 1) <> "\" Then
BackupFolderName = BackupFolderName & "\"
End If
lFileOp = FO_COPY
lFlags = lFlags And Not FOF_SILENT
lFlags = lFlags Or FOF_NOCONFIRMATION
lFlags = lFlags Or FOF_NOCONFIRMMKDIR
lFlags = lFlags Or FOF_FILESONLY
With SHFileOp
.wFunc = lFileOp
.pFrom = SourceFile & vbNullChar
.pTo = BackupFolderName & "PMBackup" & Format(Date, "mmdd") & ".pmb"
.fFlags = lFlags
End With
lResult = SHFileOperation(SHFileOp)
BackupDB = (lResult = 0)
Screen.MousePointer = vbDefault
End Function
' 还原这个数据库
Public Function RestoreDB(ByVal SourceFile As String, ToFile As String) As Boolean
On Error Resume Next
Dim lFileOp As Long
Dim lResult As Long
Dim lFlags As Long
Dim SHFileOp As SHFILEOPSTRUCT
Screen.MousePointer = vbHourglass
lFileOp = FO_COPY
lFlags = lFlags And Not FOF_SILENT
lFlags = lFlags Or FOF_NOCONFIRMATION
lFlags = lFlags Or FOF_NOCONFIRMMKDIR
lFlags = lFlags Or FOF_FILESONLY
With SHFileOp
.wFunc = lFileOp
.pFrom = SourceFile & vbNullChar
.pTo = ToFile & vbNullChar
.fFlags = lFlags
End With
lResult = SHFileOperation(SHFileOp)
RestoreDB = (lResult = 0)
Screen.MousePointer = vbDefault
End Function
#21
http://expert.csdn.net/Expert/topic/1480/1480469.xml?temp=.1952021
#22
顺便把泰山的专栏也贴上：
http://www.sijiqing.com/vbgood/taishan/index.html
http://www.sijiqing.com/vbgood/taishan/index.html
#23
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
支持散分！！！！！！！！！！！！！！！！！！！！！！！！！！！！
#24
hao
#25
好
#26
再来两三个就够数了。
菜鸟看到别忘了UP一下，高手看到别忘了有什么得意的小段子奉献一下哟。
菜鸟看到别忘了UP一下，高手看到别忘了有什么得意的小段子奉献一下哟。
#27
有人总问为什么在使用webbrowser.document.links.length时候会有错误91
这是因为你在webbrowser 还没有完整的下载页面，就使用的document 对象
尽管你是使用 webbrowser.documentcomplete 事件，但是..会出现对象未设置错误91
解决办法就是 Private Sub Form_Load()
WebBrowser1.Navigate2 (url) 你先给个默认的地址 上来就naviage2 就可以了
End Sub
这是因为你在webbrowser 还没有完整的下载页面，就使用的document 对象
尽管你是使用 webbrowser.documentcomplete 事件，但是..会出现对象未设置错误91
解决办法就是 Private Sub Form_Load()
WebBrowser1.Navigate2 (url) 你先给个默认的地址 上来就naviage2 就可以了
End Sub
#28
有人问如何使用webbrowser 去navigate2 一个列表里面的所有urllist
因为他们经常的出现错误是只浏览最后一个list..是因为webbrowers没有足够的时间去挨个去浏览，解决如下：
Private Sub Go_Click()
Dim URL_Index As Integer, CurrentURL As String
For URL_Index = 0 To List3.ListCount - 1
CurrentURL = List3.List(URL_Index)
If CurrentURL <> "" Then
WebBrowser1.Navigate2 CurrentURL, 4
While Not (WebBrowser1.ReadyState = READYSTATE_COMPLETE)
DoEvents
Wend
End If
Next URL_Index
End Sub
因为他们经常的出现错误是只浏览最后一个list..是因为webbrowers没有足够的时间去挨个去浏览，解决如下：
Private Sub Go_Click()
Dim URL_Index As Integer, CurrentURL As String
For URL_Index = 0 To List3.ListCount - 1
CurrentURL = List3.List(URL_Index)
If CurrentURL <> "" Then
WebBrowser1.Navigate2 CurrentURL, 4
While Not (WebBrowser1.ReadyState = READYSTATE_COMPLETE)
DoEvents
Wend
End If
Next URL_Index
End Sub
#29
这是个不用 webbrowser 抓links 的办法：
用的是html object library
=========
Private Sub cmdGo_Click()
Dim objLink As HTMLLinkElement
Dim objMSHTML As New MSHTML.HTMLDocument
Dim objDocument As MSHTML.HTMLDocument
lblStatus.Caption = "Gettting document via HTTP"
Set objDocument = objMSHTML.createDocumentFromUrl(txtURL.Text, vbNullString)
lblStatus.Caption = "Getting and parsing HTML document"
While objDocument.readyState <> "complete"
DoEvents
Wend
lblStatus.Caption = "Document completed"
txtSource.Text = objDocument.documentElement.outerHTML
DoEvents
lblTitle.Caption = "Title : " & objDocument.Title
DoEvents
lblStatus.Caption = "Extracting links"
For Each objLink In objDocument.links
lstLinks.AddItem objLink
lblStatus.Caption = "Extracted " & objLink
DoEvents
Next
lblStatus.Caption = "Done"
Beep
End Sub
用的是html object library
=========
Private Sub cmdGo_Click()
Dim objLink As HTMLLinkElement
Dim objMSHTML As New MSHTML.HTMLDocument
Dim objDocument As MSHTML.HTMLDocument
lblStatus.Caption = "Gettting document via HTTP"
Set objDocument = objMSHTML.createDocumentFromUrl(txtURL.Text, vbNullString)
lblStatus.Caption = "Getting and parsing HTML document"
While objDocument.readyState <> "complete"
DoEvents
Wend
lblStatus.Caption = "Document completed"
txtSource.Text = objDocument.documentElement.outerHTML
DoEvents
lblTitle.Caption = "Title : " & objDocument.Title
DoEvents
lblStatus.Caption = "Extracting links"
For Each objLink In objDocument.links
lstLinks.AddItem objLink
lblStatus.Caption = "Extracted " & objLink
DoEvents
Next
lblStatus.Caption = "Done"
Beep
End Sub
#30
我是菜鸟，我顶！
#31
我說一個最簡單的：
時間插入法：
sql="insert into tablename(a,b) values('1',getdate())" //函數
sql="insert into tablename(a,b) values('1','"&date&"')" //變量
時間插入法：
sql="insert into tablename(a,b) values('1',getdate())" //函數
sql="insert into tablename(a,b) values('1','"&date&"')" //變量
#32
sql="insert into tablename(a,b) values('1','"&date&"')" //變量
这句如果是用的Access，可能要这样改一下：
sql="insert into tablename(a,b) values('1',#" & date & "#)" '變量
这句如果是用的Access，可能要这样改一下：
sql="insert into tablename(a,b) values('1',#" & date & "#)" '變量
#33
SQL Server
sql="insert into tablename(a,b) values('1',convert(datetime," & date & ",121))" '變量
sql="insert into tablename(a,b) values('1',convert(datetime," & date & ",121))" '變量
#34
sql="insert into tablename(a,b) values('1',convert(datetime," & date & ",121))" '變量
為啥執行結果是1900/3/4呢？
為啥執行結果是1900/3/4呢？
#35
'本次有一段拖动无标题框窗体的代码，已经写成了最为通用的代码。自以为很舒畅，请大家共享。
''这段代码可以像实体一样拖动窗体，而且拖不出屏幕边框；不象普通API函数的拖动，它们先是在目标区划一虚框，再在目标位置重画窗体，我认为这种处理不好。请朋友们抬爱试试!
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If (Button = vbLeftButton) And (Me.WindowState = 0) Then
MousePointer = vbSizeAll
mX = X
mY = Y
End If
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim H As Long
Dim V As Long
On Error Resume Next
If (Button = vbLeftButton) And (Me.WindowState = 0) Then
'如果鼠标位置没有变化，表示没有移动。此时当退出过程，提高程序运行效果。
If (X = mY) And (Y = mY) Then Exit Sub
H = Me.Left + X - mX
V = Me.Top + Y - mY
If H <= 0 Then
H = 0
ElseIf H >= (Screen.Width - Me.Width) Then
H = Screen.Width - Me.Width
End If
If V <= 0 Then
V = 0
ElseIf V >= (Screen.Height - Me.Height) Then
V = Screen.Height - Me.Height
End If
Me.Move H, V
End If
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
MousePointer = vbDefault
'如果设置得有鼠标右键菜单，弹出该菜单。
If Button = vbRightButton Then
Call PopupMenu(mnuRight)
End If
End Sub
''这段代码可以像实体一样拖动窗体，而且拖不出屏幕边框；不象普通API函数的拖动，它们先是在目标区划一虚框，再在目标位置重画窗体，我认为这种处理不好。请朋友们抬爱试试!
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If (Button = vbLeftButton) And (Me.WindowState = 0) Then
MousePointer = vbSizeAll
mX = X
mY = Y
End If
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim H As Long
Dim V As Long
On Error Resume Next
If (Button = vbLeftButton) And (Me.WindowState = 0) Then
'如果鼠标位置没有变化，表示没有移动。此时当退出过程，提高程序运行效果。
If (X = mY) And (Y = mY) Then Exit Sub
H = Me.Left + X - mX
V = Me.Top + Y - mY
If H <= 0 Then
H = 0
ElseIf H >= (Screen.Width - Me.Width) Then
H = Screen.Width - Me.Width
End If
If V <= 0 Then
V = 0
ElseIf V >= (Screen.Height - Me.Height) Then
V = Screen.Height - Me.Height
End If
Me.Move H, V
End If
End Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
MousePointer = vbDefault
'如果设置得有鼠标右键菜单，弹出该菜单。
If Button = vbRightButton Then
Call PopupMenu(mnuRight)
End If
End Sub
#36
多多益善
#37
TO xianghua(小黑) :
数据库中字段必须是Datetime型
数据库中字段必须是Datetime型
#38
哈，我是初學，所以說的都是簡單的，請不要見笑。
ado連接sql2000資料庫方法：
dim conn as new adodb.connection
dim rs as new adodb.recordset
dim sql as string
conn.open"driver={sql server};server=服務器名;database=數據庫名;uid=sa;pwd=密碼“
set rs.cursorlocation=aduseclient //對於datagrid控件來說要待別注意
sql="select * from table "
rs.open sql,conn,1,1
set datagrid1.datasource=rs //後期綁定
ado連接sql2000資料庫方法：
dim conn as new adodb.connection
dim rs as new adodb.recordset
dim sql as string
conn.open"driver={sql server};server=服務器名;database=數據庫名;uid=sa;pwd=密碼“
set rs.cursorlocation=aduseclient //對於datagrid控件來說要待別注意
sql="select * from table "
rs.open sql,conn,1,1
set datagrid1.datasource=rs //後期綁定
#39
to:Cooly(☆回答问题不要分儿☆)
前輩請不要笑我，我的類型是為datatime 型的啊！是sql2000+vb6.0的。
代碼如下：Private Sub Command1_Click()
Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
conn.Open "driver={sql server};database=capital;uid=sa;pwd=zasan;server=hsan_sql2"
sql = "insert into test (a,b) values ('16',convert(datetime," & Date & ",121))"
conn.Execute sql
End Sub
真是不好意思了。
前輩請不要笑我，我的類型是為datatime 型的啊！是sql2000+vb6.0的。
代碼如下：Private Sub Command1_Click()
Dim conn As New ADODB.Connection
Dim rs As New ADODB.Recordset
conn.Open "driver={sql server};database=capital;uid=sa;pwd=zasan;server=hsan_sql2"
sql = "insert into test (a,b) values ('16',convert(datetime," & Date & ",121))"
conn.Execute sql
End Sub
真是不好意思了。
#40
当然，上述代码得先定义模块级变量
dim mX as long
dim mY as long
dim mX as long
dim mY as long
#41
TO xianghua(小黑) :
你的字段类型是DateTime还是SmallDateTime?
你的字段类型是DateTime还是SmallDateTime?
#42
to: Cooly(☆回答问题不要分儿☆)
是datatime型的。
是datatime型的。
#43
呵呵，本贴上了非技术类版顶端的红点导读贴子了。看来版主比较支持我。up一下。
#44
偶是菜鸟,但是偶靠下面的代码在技术区多穿了个三角裤.现加了进来.拙文见笑了!
'模块里内容
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
Sub DisableCtrlAltDelete(bDisabled As Boolean)
' Disables Control Alt Delete Breaking as well as Ctrl-Escape
Dim X As Long
X = SystemParametersInfo(97, bDisabled, CStr(1), 0)
End Sub
'窗体代码
Private Sub Command1_Click()
DisableCtrlAltDelete (False)
End Sub
Private Sub Command2_Click()
DisableCtrlAltDelete (True)
End Sub
强烈建议多些此类的文章!
()000o oO00()
( $ ) ( ￥ )
) / \ (
(__/ \__)
'模块里内容
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
Sub DisableCtrlAltDelete(bDisabled As Boolean)
' Disables Control Alt Delete Breaking as well as Ctrl-Escape
Dim X As Long
X = SystemParametersInfo(97, bDisabled, CStr(1), 0)
End Sub
'窗体代码
Private Sub Command1_Click()
DisableCtrlAltDelete (False)
End Sub
Private Sub Command2_Click()
DisableCtrlAltDelete (True)
End Sub
强烈建议多些此类的文章!
()000o oO00()
( $ ) ( ￥ )
) / \ (
(__/ \__)
#45
支持楼主.助人为乐
#46
忘了说，这段程序是操作Ctrl+Alt+Del的