7、注册问题
'*************************************************************************
'**函 数 名：getSeriorNumber
'**输 入：sRoot(String) -
'**输 出：(Long) -
'**功能描述：返回磁盘的序列号
'*************************************************************************
Public Function getSeriorNumber(sRoot As String) As Long
Dim lSerialNum As Long
Dim R As Long
Dim strLabel As String, strType As String
strLabel = String$(255, Chr$(0)) '磁盘卷标
strType = String$(255, Chr$(0)) '文件系统类型 一般为 FAT
R = GetVolumeInformation(sRoot, strLabel, Len(strLabel), lSerialNum, 0, 0, strType, Len(strType))
getSeriorNumber = lSerialNum '在 strLabel 中为 磁盘卷标 '在 strType 中为 文件系统类型
End Function
12、金山词霸界面效果的实现
'用了几个pic、Text、lab
Public Sub AddBar(intNum As Integer, strTitle() As String, strData() As String)
'打开错误处理陷阱
On Error GoTo ErrGoto
'----------------------------------------------------
'代码正文
Dim bFlag As Boolean
Dim i As Integer, j As Integer
Dim intHeight As Long
'-------------------------------
' imgFlag(0).Top = 225
' lblFlag(0).Top = imgFlag(0).Top + 60
' imgLine(0).Top = imgFlag(0).Top + 270
' imgPoint(0).Top = imgFlag(0).Top + 395
' txtFlag(0).Top = imgFlag(0).Top + 360
'-------------------------------
txtFlag(0).Width = Me.Width - 2955
imgLine(0).Width = Me.Width - 2655
lblFlag(0).ZOrder
Begin:
intTotalHeight = 0
intHeight = 0
For i = 1 To intDataNum - 1
imgFlag(i).Visible = False
lblFlag(i).Visible = False
imgLine(i).Visible = False
imgPoint(i).Visible = False
txtFlag(i).Visible = False
txtFlag(i).Text = ""
Next
For i = 0 To intNum - 1
'----------------------------------------
If i > 0 Then
imgFlag(i).Visible = True
lblFlag(i).Visible = True
imgLine(i).Visible = True
imgPoint(i).Visible = True
txtFlag(i).Visible = True
imgFlag(i).Top = imgFlag(i - 1).Top + intHeight
lblFlag(i).Top = lblFlag(i - 1).Top + intHeight
imgLine(i).Top = imgLine(i - 1).Top + intHeight
imgPoint(i).Top = imgPoint(i - 1).Top + intHeight
txtFlag(i).Top = txtFlag(i - 1).Top + intHeight
txtFlag(i).Width = txtFlag(0).Width
imgLine(i).Width = Me.Width - 2655
lblFlag(i).ZOrder
End If
'------------------------------------------
lblFlag(i).Caption = strTitle(i)
txtFlag(i).Text = strData(i)
'txtFlag(i).Height = GetTextLines(txtFlag(i).hwnd) * 180
'-----------------------------------------------
With txtFlag(i)
Dim dc As Long, tm As TEXTMETRIC, oft As Long, rct As RECT
dc = GetDC(.hwnd)
oft = SelectObject(dc, SendMessage(.hwnd, WM_GETFONT, 0&, ByVal 0&))
GetTextMetrics dc, tm
SelectObject dc, oft: ReleaseDC .hwnd, dc
SendMessageAny .hwnd, EM_GETRECT, 0&, rct
.Height = Me.ScaleY((tm.tmHeight) * SendMessage(.hwnd, EM_GETLINECOUNT, 0&, ByVal 0&) + 6, vbPixels, Me.ScaleMode)
End With
'------------------------------------------------
intHeight = txtFlag(i).Height + imgFlag(i).Height + 80
intTotalHeight = intTotalHeight + intHeight
Next
'------------------------------------------
If intTotalHeight + 285 > picBar.Height Then
If bFlag = False Then
bFlag = True
intDataNum = intNum
txtFlag(0).Width = Me.Width - 2955 - vscBar.Width
GoTo Begin
Else
vscBar.Visible = True
vscBar.Max = (intTotalHeight - picBar.Height + 300) / 150
vscBar.SmallChange = 1
vscBar.LargeChange = 4
For j = 0 To intDataNum - 1
intTop(j) = imgFlag(j).Top
Next j
vscBar.Value = 0
End If
Else
txtFlag(0).Width = Me.Width - 2955
vscBar.Visible = False
End If
'---------------------------------------------
intDataNum = intNum
'----------------------------------------------------
Exit Sub
'-----------------------------
ErrGoto:
Resume Next
End Sub
4，SPY－－－－－－－－－－－－
Private Sub picDrag_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
'打开错误处理陷阱
On Error GoTo ErrGoto
'----------------------------------------------------
Dim hwnd As Long
Dim strClass As String * 255
Dim strTitle As String * 255
Dim len1 As Long
Dim len2 As Long
Dim pt As POINTAPI
If InformationNow = True Then
GetCursorPos pt
hwnd = WindowFromPoint(pt.X, pt.Y)
If hwnd > 0 Then
len1 = GetWindowText(hwnd, strTitle, 250)
len2 = GetClassName(hwnd, strClass, 250)
txtSPY.Text = "(" + Format(pt.X, "0") + "," + Format(pt.Y, "0") + ")+[" + Left(strClass, len2) + "]-<" + Format(hwnd, "0") + ">-{" + Left(strTitle, len1) + "}"
End If
End If
Exit Sub
'-----------------------------
ErrGoto:
End Sub
‘－－－－－－－－－－－－－－－－－－－－－－－－－－－
确实是，改变窗体大小没有必要添加其他控件。（一下代码由IKEY提供）
Option Explicit
'用于计时
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long
'用于发送消息
Private Declare Function SendMessage& Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any)
Private Declare Function SendMessageBynum& Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
Private Declare Function SendMessageByString& Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String)
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private Const HTBOTTOM = 15
Private Const HTBOTTOMLEFT = 16
Private Const HTBOTTOMRIGHT = 17
Private Const HTTOP = 12
Private Const HTTOPLEFT = 13
Private Const HTTOPRIGHT = 14
Private Const HTLEFT = 10
Private Const HTRIGHT = 11
'为当前的应用程序释放鼠标捕获
Private Declare Function ReleaseCapture Lib "user32" () As Long
'取得窗体位置的函数
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'取得鼠标位置的函数
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
'用于如何操纵窗体大小及其位置
Dim Action As String
'停止计时
Private ExitApp As Boolean
Private Sub Form_Load()
Me.Show
GetTime
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'按下鼠标左键
If Button = vbLeftButton Then
ReleaseCapture
Select Case Action
Case "Left"
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTLEFT, 0&
Case "Right"
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTRIGHT, 0&
Case "Up"
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTTOP, 0&
Case "LeftUp"
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTTOPLEFT, 0&
Case "RightUp"
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTTOPRIGHT, 0&
Case "Down"
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTBOTTOM, 0&
Case "LeftDown"
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTBOTTOMLEFT, 0&
Case "RightDown"
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTBOTTOMRIGHT, 0&
Case "Move"
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Select
End If
End Sub
Private Sub frmSize()
Dim MyRect As RECT
Dim MyPoint As POINTAPI
' MyRect返回当前窗口位置
Call GetWindowRect(Me.hwnd, MyRect)
' MyPoint返回当前鼠标位置
Call GetCursorPos(MyPoint)
Select Case True
Case MyPoint.X < MyRect.Left + 5 And MyPoint.Y < MyRect.Top + 5
Screen.MousePointer = vbSizeNWSE
Action = "LeftUp"
Case MyPoint.X > MyRect.Right - 5 And MyPoint.Y > MyRect.Bottom - 5
Screen.MousePointer = vbSizeNWSE
Action = "RightDown"
Case MyPoint.X > MyRect.Right - 5 And MyPoint.Y < MyRect.Top + 5
Screen.MousePointer = vbSizeNESW
Action = "RightUp"
Case MyPoint.X < MyRect.Left + 5 And MyPoint.Y > MyRect.Bottom - 5
Screen.MousePointer = vbSizeNESW
Action = "LeftDown"
Case MyPoint.X < MyRect.Left + 5
Screen.MousePointer = vbSizeWE
Action = "Left"
Case MyPoint.X > MyRect.Right - 5
Screen.MousePointer = vbSizeWE
Action = "Right"
Case MyPoint.Y < MyRect.Top + 5
Screen.MousePointer = vbSizeNS
Action = "Up"
Case MyPoint.Y > MyRect.Bottom - 5
Screen.MousePointer = vbSizeNS
Action = "Down"
Case Else
Screen.MousePointer = 0
Action = "Move"
End Select
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
ExitApp = True
End Sub
Public Sub GetTime()
Dim NextTick As Long
Do Until ExitApp
DoEvents
Do Until GetTickCount > NextTick
DoEvents
Loop: NextTick = GetTickCount + 50
frmSize
Loop
End
End Sub
扫一扫
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
