xpm.ctl

会员管理系统 功能自己扩展把！ 如果有改进给我发一份[e-mail] 这个比较适合初学者``` Q：151693707 msn:[e-mail]

VERSION 5.00
Begin VB.UserControl XPM 
   BackColor       =   &H00800000&
   ClientHeight    =   285
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   300
   InvisibleAtRuntime=   -1  'True
   ScaleHeight     =   285
   ScaleWidth      =   300
   Begin VB.Timer Timer1 
      Left            =   480
      Top             =   480
   End
End
Attribute VB_Name = "XPM"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Public ClickIndex As Long
Public Mytop As Long
Public MaxWidth
Dim MyF As New FMenu
'事件声明:
Event Click(index As Long)  'MappingInfo=LL,LL,-1,Click
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function SetActiveWindow Lib "user32" (ByVal hWnd As Long) As Long

Private Declare Function SetWindowPos& Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Function SetFocusAPI& Lib "user32" Alias "SetFocus" (ByVal hWnd As Long)
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Const HTCAPTION = 2
Private Const WM_NCLBUTTONDOWN = &HA1
Private Type POINTAPI
        X As Long
        Y As Long
End Type


Public Sub Add(caption, pic As Picture)
On Error Resume Next
If Mytop = 0 Then
Mytop = 20
End If

With MyF
k = .PP.count
Load .PP(k)
'.PP(k).BackColor = .PP(0).BackColor
.PP(k).Visible = True
.PP(k).Top = Mytop
.PP(k).Left = 360
.PP(k).Tag = caption
Mytop = Mytop + 360
.PP(k).CurrentX = (360 - .TextHeight(caption)) / 2
.PP(k).CurrentY = 100
.PP(k).Print caption
If .TextWidth(caption) + 660 > MaxWidth Then MaxWidth = .TextWidth(caption) + 660

If pic <> LoadPicture() Then .PaintPicture pic, 60, .PP(k).Top + 60, 240, 240, 0, 0, 240, 240

End With


End Sub

Public Sub ShowMenu(auto As Boolean, X, Y)
On Error Resume Next

With MyF

Dim pos As POINTAPI
GetCursorPos pos


MyF.Line (.Width - 10, 0)-(.Width - 10, .Height), MyF.BackColor
MyF.Line (0, .Height - 10)-(.Width, .Height - 10), MyF.BackColor

.Width = MaxWidth
.Height = Mytop + 10

For i = 1 To .PP.count - 1
.PP(i).Width = .Width - 380
Next

'位置
If auto = False Then
.Move X, Y
Else

w = pos.X * 15
h = pos.Y * 15
If w + .Width > Screen.Width Then w = w - .Width
If h + .Height > Screen.Height Then h = h - .Height
If h < 0 Then h = 0
.Move w, h


End If

.Show
.Form_Load
Timer1.Interval = 100

MyF.Line (0, 0)-(MyF.Width - 10, MyF.Height - 10), 6710886, B

End With


End Sub


Public Sub AddLine()
Mytop = Mytop + 30
End Sub

Public Sub UnLoadMenu()
On Error Resume Next
Unload MyF
Mytop = 0
MaxWidth = 0
ClickIndex = 0
End Sub

Public Function GetCaption(index)
On Error Resume Next
GetCaption = MyF.PP(index).Tag
End Function

Public Function SetCaption(index, caption)
On Error Resume Next
 MyF.PP(index).Tag = caption
 PrintChange index
 If MyF.TextWidth(caption) + 660 > MaxWidth Then MaxWidth = MyF.TextWidth(caption) + 660
 
End Function

Public Sub SetEnabled(index, mode)
On Error Resume Next
MyF.PP(index).Enabled = mode
If mode = True Then
MyF.PP(index).ForeColor = MyF.PP(0).ForeColor
PrintChange index
Else
MyF.PP(index).Cls
MyF.PP(index).ForeColor = vbWhite
MyF.PP(index).CurrentX = ((360 - MyF.TextHeight("a")) / 2) + 10
MyF.PP(index).CurrentY = 120
MyF.PP(index).Print MyF.PP(index).Tag
MyF.PP(index).ForeColor = vbGrayText
MyF.PP(index).CurrentX = (360 - MyF.TextHeight("a")) / 2
MyF.PP(index).CurrentY = 100
MyF.PP(index).Print MyF.PP(index).Tag
End If
End Sub

Public Function GetEnabled(index)
On Error Resume Next
GetEnabled = MyF.PP(index).Enabled
End Function


Public Function GetCheck(index)
On Error Resume Next
GetCheck = MyF.PP(index).AutoSize
End Function

Public Function GetCount()
On Error Resume Next
GetCount = MyF.PP.count - 1
End Function

Public Sub SetPicture(index, pic As Picture)
On Error Resume Next
If pic <> LoadPicture() Then
MyF.Line (60, MyF.PP(index).Top + 60)-(300, MyF.PP(index).Top + 240), MyF.BackColor
MyF.PaintPicture pic, 60, MyF.PP(index).Top + 60, 240, 240, 0, 0, 240, 240
End If

End Sub



Public Sub SetCheck(index, mode)
On Error Resume Next
With MyF
k = .PP(index).Top
.PP(index).AutoSize = mode
If mode = True Then
.PaintPicture .p1.Picture, 60, k + 60, 240, 240, 0, 0, 240, 240
Else
MyF.Line (60, k + 60)-(300, k + 300), MyF.BackColor, BF
End If
End With
End Sub

Public Sub ForeColor(index, color As Long)
On Error Resume Next
MyF.PP(index).ForeColor = color
PrintChange index
End Sub

Public Sub FontBold(index, mode As Boolean)
On Error Resume Next
MyF.PP(index).FontBold = mode
PrintChange index
End Sub

Public Sub FontItalic(index, mode As Boolean)
On Error Resume Next
MyF.PP(index).FontItalic = mode
PrintChange index
End Sub

Public Sub FontStrikethru(index, mode As Boolean)
On Error Resume Next
MyF.PP(index).FontStrikethru = mode
PrintChange index
End Sub



Public Sub FontUnderline(index, mode As Boolean)
On Error Resume Next
MyF.PP(index).FontUnderline = mode
PrintChange index
End Sub
Private Sub Timer1_Timer()

If GetActiveWindow = MyF.hWnd Then Exit Sub
'MsgBox GetFocus
If MyF.Tag <> 0 Then
ClickIndex = MyF.Tag
RaiseEvent Click(ClickIndex)
MyF.Tag = 0
End If

MyF.Visible = False
Timer1.Interval = 0


End Sub

Public Sub HideMenu()
MyF.Visible = False
Timer1.Interval = 0
End Sub


Public Sub PrintChange(index)
On Error Resume Next

MyF.PP(index).Cls
MyF.PP(index).CurrentX = (360 - MyF.TextHeight("a")) / 2
MyF.PP(index).CurrentY = 100
MyF.PP(index).Print MyF.PP(index).Tag


End Sub