niceform.ctl

来自「非常漂亮的VB控件」· CTL 代码 · 共 400 行

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