www.pudn.com > VBkongjian.rar > NiceForm.ctl
VERSION 5.00
Begin VB.UserControl NiceForm
ClientHeight = 1500
ClientLeft = 0
ClientTop = 0
ClientWidth = 10500
InvisibleAtRuntime= -1 'True
PropertyPages = "NiceForm.ctx":0000
ScaleHeight = 1500
ScaleWidth = 10500
ToolboxBitmap = "NiceForm.ctx":001F
Begin VB.Timer Tim
Enabled = 0 'False
Interval = 1000
Left = 120
Top = 3000
End
Begin VB.PictureBox Picture1
Appearance = 0 'Flat
AutoRedraw = -1 'True
AutoSize = -1 'True
BackColor = &H80000005&
BorderStyle = 0 'None
ForeColor = &H80000008&
Height = 480
Left = 0
Picture = "NiceForm.ctx":0331
ScaleHeight = 480
ScaleWidth = 480
TabIndex = 2
Top = 0
Width = 480
End
Begin VB.PictureBox Pc
AutoRedraw = -1 'True
AutoSize = -1 'True
BorderStyle = 0 'None
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 720
Left = 600
Picture = "NiceForm.ctx":0F73
ScaleHeight = 720
ScaleWidth = 9600
TabIndex = 0
TabStop = 0 'False
Top = 120
Visible = 0 'False
Width = 9600
Begin VB.PictureBox Pb
AutoRedraw = -1 'True
AutoSize = -1 'True
BorderStyle = 0 'None
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 150
Left = 480
Picture = "NiceForm.ctx":177B5
ScaleHeight = 150
ScaleWidth = 1050
TabIndex = 1
TabStop = 0 'False
Top = 240
Visible = 0 'False
Width = 1050
End
End
End
Attribute VB_Name = "NiceForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "PropPageWizardRun" ,"Yes"
Private m_cN As cNeoCaption
Private m_Mnu As cMenuBar
'缺省属性值:
Const m_def_MnuStyleIdx = 0
'属性变量:
Public Enum MnuStyle
[蓝色经典1] = 0
[时尚世界] = 1
[蓝色魅力1] = 2
[幽蓝世界] = 3
[流线造型1] = 4
[流线造型2] = 5
[深海幽蓝] = 6
[金属时代] = 7
[蓝色魅力2] = 8
[电子时尚1] = 9
[发光金属] = 10
[缤纷世界] = 11
[蓝色经典2] = 12
[电子时尚2] = 13
[电子时尚3] = 14
[条纹之美] = 15
[天蓝光泽] = 16
[蓝色超平] = 17
[时尚蓝色] = 18
[Mac] = 19
[红色管道] = 20
[XP时代] = 21
[微型世界] = 22
[水晶巧克力] = 23
End Enum
Dim m_MnuStyleIdx As Integer
Private fW As Long
Private fH As Long
Private MnuIns As Boolean
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Private Declare Function GetMenu Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function AppendMenu Lib "user32" Alias "AppendMenuA" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As String) As Long
Private Declare Function InsertMenu Lib "user32" Alias "InsertMenuA" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpNewItem As Any) As Long
Private Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
Private Declare Function SetMenuItemInfo Lib "user32" Alias "SetMenuItemInfoA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, lpcMenuItemInfo As MnuInfo) As Long
Private Declare Function GetMenuCheckMarkDimensions Lib "user32" () As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDC As Long, ByVal nBkMode As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private mSMenu As Long
Private Const GWL_WNDPROC = (-4)
Private Const MF_BITMAP = &H4&
Private Const MF_BYCOMMAND = &H0&
Private Const MF_BYPOSITION = &H400&
Private Const MF_CALLBACKS = &H8000000
Private Const MF_CHANGE = &H80&
Private Const MF_CHECKED = &H8&
Private Const MF_CONV = &H40000000
Private Const MF_DELETE = &H200&
Private Const MF_DISABLED = &H2&
Private Const MF_ENABLED = &H0&
Private Const MF_END = &H80
Private Const MF_ERRORS = &H10000000
Private Const MF_GRAYED = &H1&
Private Const MF_HELP = &H4000&
Private Const MF_HILITE = &H80&
Private Const MF_HSZ_INFO = &H1000000
Private Const MF_INSERT = &H0&
Private Const MF_LINKS = &H20000000
Private Const MF_MASK = &HFF000000
Private Const MF_MENUBARBREAK = &H20&
Private Const MF_MENUBREAK = &H40&
Private Const MF_MOUSESELECT = &H8000&
Private Const MF_OWNERDRAW = &H100& '关系弹出菜单的样式
Private Const MF_POPUP = &H10&
Private Const MF_POSTMSGS = &H4000000
Private Const MF_REMOVE = &H1000&
Private Const MF_SENDMSGS = &H2000000
Private Const MF_SEPARATOR = &H800&
Private Const MF_STRING = &H0&
Private Const MF_SYSMENU = &H10&
Private Const MF_UNCHECKED = &H0&
Private Const MF_UNHILITE = &H0&
Private Const MF_USECHECKBITMAPS = &H200&
Private Const MF_DEFAULT = &H1000&
Public TmpColor As Long
Private Type MnuInfo
cbSize As Long
fMask As Long
fType As Long
fState As Long
wID As Long
hSubMenu As Long
hbmpChecked As Long
hbmpUnchecked As Long
dwItemData As Long
dwTypeData As Long
cch As Long
End Type
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Sub Skin(F As Form, cN As cNeoCaption, indx As Integer)
Dim idx As Integer
cN.ActiveCaptionColor = &HFFFFFF
cN.InActiveCaptionColor = &HC0C0C0
cN.ActiveMenuColor = 0
cN.ActiveMenuColorOver = &H0
cN.InActiveMenuColor = &H0&
cN.MenuBackgroundColor = &HE0E0E0
cN.CaptionFont.Name = "宋体"
cN.CaptionFont.Size = 9
cN.MenuFont.Name = "宋体"
cN.MenuFont.Size = 9
F.BackColor = &HE0E0E0
If m_MnuStyleIdx <= 30 And m_MnuStyleIdx >= 0 Then
SaveSetting "NiceForm", "Skin", "idx", Str(m_MnuStyleIdx)
cN.Attach F, pc.Picture, Pb.Picture, 19, 20, 90, 140, 240, 400, m_MnuStyleIdx, indx
Else
idx = GetSetting("NiceForm", "Skin", "Idx", 0)
cN.Attach F, pc.Picture, Pb.Picture, 19, 20, 90, 140, 240, 400, idx, indx
End If
' frmAbout.Show 1
End Sub
'注意！不要删除或修改下列被注释的行！
'MemberInfo=14
Public Function LoadSkin(idx As Integer) As Variant
SkinF idx
End Function
Public Function SkinFormFile(MainPicFileName As String, BorderPicName As String) As Variant
On Error GoTo err
pc.Picture = LoadPicture(MainPicFileName)
Pb.Picture = LoadPicture(BorderPicName)
Skin UserControl.Parent, m_cN, 0
SaveSetting "NiceForm", "Skin", "Idx", "255"
Exit Function
err:
MsgBox "图片格式不正确,请设置一个正确的文件路径.", vbExclamation, "格式不正确"
End Function
Private Sub SkinF(idx As Integer)
If idx < 0 Then
idx = 0
End If
If idx = 255 Then
Exit Sub
End If
If idx <= 24 Then
pc.Picture = LoadResPicture(1100 + idx, 0)
Pb.Picture = LoadResPicture(1200 + idx, 0)
Skin UserControl.Parent, m_cN, idx
SaveSetting "NiceForm", "Skin", "Idx", idx
End If
End Sub
Private Sub ThisCheck_Click()
End Sub
Private Sub UserControl_Initialize()
Set m_cN = New cNeoCaption
Set m_Mnu = New cMenuBar
End Sub
Private Sub UserControl_Resize()
UserControl.Width = Picture1.Width
UserControl.Height = Picture1.Height
End Sub
'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get MnuStyleIdx() As MnuStyle
Attribute MnuStyleIdx.VB_Description = "设置窗口菜单的样式,请将它设置为(0-10)以内的数字"
MnuStyleIdx = m_MnuStyleIdx
End Property
Public Property Let MnuStyleIdx(ByVal New_MnuStyleIdx As MnuStyle)
m_MnuStyleIdx = New_MnuStyleIdx
PropertyChanged "MnuStyleIdx"
End Property
'为用户控件初始化属性
Private Sub UserControl_InitProperties()
m_MnuStyleIdx = m_def_MnuStyleIdx
End Sub
'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
m_MnuStyleIdx = PropBag.ReadProperty("MnuStyleIdx", m_def_MnuStyleIdx)
End Sub
'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
'---------------------------------------------------------------
RegPass
' RegYn '注册检查
'---------------------------------------------------------------
Call PropBag.WriteProperty("MnuStyleIdx", m_MnuStyleIdx, m_def_MnuStyleIdx)
End Sub
Private Sub RegPass()
Dim pass As String
pass = QueryValue(HKEY_LOCAL_MACHINE, "SOFTWARE\华盛软件工作室\NiceForm", "Userkey")
'Debug.Print pass
If Left(pass, 16) <> "llcyw13931137599" Then
FrmPass.Show 1
End If
End Sub
Private Sub RegYn()
Dim id As String, SN As String, Rsn As String
'--------------------------------------------------------------------------------
id = Int(GetSerialNumber("C:\") * 1.25) * 4
a = Abs(Val(id) / 1245 * 541 / 23 * 15)
B = Abs(Val(id) / 3 / 3 * 24 / 12)
c = Abs(Val(id) * 0.14 / 0.24)
d = Abs((Val(id) - Val(id / 2) + Val(id * 2)) / 2)
SN = Trim(Str(Int(a))) & "-" & Trim(Str(Int(B))) & "-" & Trim(Str(Int(c))) & "-" & Trim(Str(Int(d)))
Rsn = QueryValue(HKEY_LOCAL_MACHINE, "SOFTWARE\华盛软件工作室\NiceForm", "SN")
If Left(Rsn, Len(SN)) <> SN Then
frmAbout.Show 1
End If
End Sub
'注意！不要删除或修改下列被注释的行！
'MemberInfo=14
Public Function CloseSkin() As Variant
m_cN.Detach
End Function
'注意！不要删除或修改下列被注释的行！
'MemberInfo=14
Public Function MiniSize(SetMiniSize As Boolean) As Variant
If SetMiniSize = False Then
UserControl.Parent.Width = fW
UserControl.Parent.Height = fH
Else
fW = UserControl.Parent.Width
fH = UserControl.Parent.Height
UserControl.Parent.Width = 3100
UserControl.Parent.Height = 900
End If
End Function
'
Public Function AddToTry(Menu As Object, ToolTip As String) As Variant
AddToTrayIcon UserControl.Parent, Menu
SetTrayTip ToolTip
End Function
'注意！不要删除或修改下列被注释的行！
'MemberInfo=14
Public Function UnloadTryIcon() As Variant
RemoveFromTray
End Function
'注意！不要删除或修改下列被注释的行！
'MemberInfo=14
Public Function SetWindowOnTop(SetOntop As Boolean) As Variant
If SetOntop = True Then
SetWindowPos UserControl.Parent.hWnd, -1, 0, 0, 0, 0, 3
Else
SetWindowPos UserControl.Parent.hWnd, -2, 0, 0, 0, 0, 3
End If
End Function
'注意！不要删除或修改下列被注释的行！
'MemberInfo=14
Public Function DoRndForm() As Variant
' TheForm: The form you want to be rounded rectangle shape
Dim TempRegions(6) As Long
Dim FormWidthInPixels As Long
Dim FormHeightInPixels As Long
Dim a
' Convert the form's height and width from twips to pixels
FormWidthInPixels = UserControl.Parent.Width / Screen.TwipsPerPixelX
FormHeightInPixels = UserControl.Parent.Height / Screen.TwipsPerPixelY
' Make a rounded rectangle shaped region with the dimentions of the form
a = CreateRoundRectRgn(0, 0, FormWidthInPixels + 1, FormHeightInPixels + 1, 3, 3)
' Set this region as the shape for "TheForm"
a = SetWindowRgn(UserControl.Parent.hWnd, a, True)
End Function
'注意！不要删除或修改下列被注释的行！
'MemberInfo=14
Public Function AutoSkinControl() As Variant
Dim aControl As Control
Dim a, B, c, d As Integer
With UserControl.Parent
For Each aControl In UserControl.Parent.Controls
On Error GoTo err
If TypeName(aControl) = "NiceButton" Or TypeName(aControl) = "NicePressBar" Or TypeName(aControl) = "NiceCheck" Or TypeName(aControl) = "NiceOption" _
Or TypeName(aControl) = "NiceSlider" Then
aControl.Style = m_MnuStyleIdx
End If
Next
End With
Exit Function
err: MsgBox err.Number & err.Description
End Function