pagbitmaps.pag
来自「非常漂亮的VB控件」· PAG 代码 · 共 578 行 · 第 1/2 页
PAG
578 行
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Begin VB.PropertyPage pagBitmaps
Caption = "设置菜单图标"
ClientHeight = 5130
ClientLeft = 0
ClientTop = 0
ClientWidth = 5475
PaletteMode = 0 'Halftone
ScaleHeight = 5130
ScaleWidth = 5475
Begin VB.CommandButton cmdClear
Caption = "清除(&C)"
Height = 288
Left = 4425
Picture = "pagBitmaps.pgx":0000
TabIndex = 17
Top = 84
Width = 960
End
Begin MSComDlg.CommonDialog comDlg
Left = 2856
Top = 1932
_ExtentX = 688
_ExtentY = 688
_Version = 393216
CancelError = -1 'True
Filter = "Icons And Graphics (*.ico;*.bmp;*.gif;*.jpg)|*.ico;*.bmp;*.gif;*.jpg|All files (*.*)|*.*"
Flags = 4
FontBold = -1 'True
FontItalic = -1 'True
FontStrikeThru = -1 'True
FontUnderLine = -1 'True
End
Begin VB.Frame fraControls
Caption = "菜单图标"
Height = 1944
Left = 84
TabIndex = 8
Top = 3108
Width = 3000
Begin VB.ComboBox cobMaskColor
Height = 288
ItemData = "pagBitmaps.pgx":014A
Left = 1092
List = "pagBitmaps.pgx":014C
TabIndex = 12
Top = 1512
Width = 1860
End
Begin VB.ComboBox cobMenus
Height = 288
Left = 1092
TabIndex = 11
Top = 336
Width = 1860
End
Begin VB.PictureBox picBmp
Height = 684
Left = 1092
ScaleHeight = 630
ScaleWidth = 1215
TabIndex = 10
Top = 756
Width = 1272
Begin VB.Image imgBmp
Height = 348
Left = 168
MousePointer = 15 'Size All
Top = 84
Width = 348
End
End
Begin VB.CommandButton cmdOpen
Height = 285
Left = 2436
Picture = "pagBitmaps.pgx":014E
Style = 1 'Graphical
TabIndex = 9
Top = 756
Width = 300
End
Begin VB.Label Label4
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "菜单项:"
Height = 180
Left = 165
TabIndex = 15
Top = 330
Width = 630
End
Begin VB.Label Label3
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "透明颜色:"
Height = 180
Left = 120
TabIndex = 14
Top = 1560
Width = 810
End
Begin VB.Label Label2
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "图象:"
Height = 180
Left = 165
TabIndex = 13
Top = 750
Width = 450
End
End
Begin VB.Frame fraCommon
Caption = "选项"
BeginProperty Font
Name = "Arial"
Size = 9
Charset = 204
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1944
Left = 3120
TabIndex = 3
Top = 3108
Width = 2265
Begin VB.CheckBox chkSystemFont
Caption = "使用系统字体"
Height = 348
Left = 168
TabIndex = 19
Top = 840
Width = 1692
End
Begin VB.ComboBox cobSize
Height = 288
Left = 168
TabIndex = 6
Top = 1512
Width = 1356
End
Begin VB.CheckBox chkDisabled
Caption = "可以选择无效菜单项"
Height = 432
Left = 168
TabIndex = 4
Top = 336
Width = 2055
End
Begin VB.Label Label6
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "px"
Height = 180
Left = 1680
TabIndex = 7
Top = 1515
Width = 180
End
Begin VB.Label Label5
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "图像大小:"
Height = 180
Left = 165
TabIndex = 5
Top = 1260
Width = 810
End
End
Begin VB.CommandButton cmdAdd
Height = 285
Left = 3750
Picture = "pagBitmaps.pgx":0298
Style = 1 'Graphical
TabIndex = 2
Top = 84
Width = 300
End
Begin VB.ListBox lstMenus
Height = 2640
IntegralHeight = 0 'False
Left = 84
TabIndex = 1
Top = 420
Width = 5304
End
Begin VB.CommandButton cmdRemove
Height = 285
Left = 4095
Picture = "pagBitmaps.pgx":03E2
Style = 1 'Graphical
TabIndex = 0
Top = 84
Width = 300
End
Begin VB.Label labNum
AutoSize = -1 'True
BackStyle = 0 'Transparent
Height = 180
Left = 960
TabIndex = 18
Top = 90
Width = 90
End
Begin VB.Label labMenu
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "菜单项:"
Height = 180
Left = 90
TabIndex = 16
Top = 120
Width = 630
End
End
Attribute VB_Name = "pagBitmaps"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'==============================================================================
' pagBitmaps.pag
'
' Subclassing Thunk (SuperClass V2) Project Samples
' Copyright (c) 2002 by Vlad Vissoultchev <wqweto@myrealbox.com>
'
' Office XP menus control property page
'
' Modifications:
'
' 2002-10-28 WQW Initial implementation
'
'==============================================================================
Option Explicit
'==============================================================================
' API
'==============================================================================
Private Const LB_SETTABSTOPS As Long = &H192
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
'==============================================================================
' Constants and member variables
'==============================================================================
Private m_oControl As XPMenu
Private m_cBmps As Collection
Private m_lLoaded As Long
Private m_bInSet As Boolean
Private m_bDrag As Boolean
Private m_sX As Single
Private m_sY As Single
Private m_bModified As Boolean
Private m_bChanged As Boolean
'==============================================================================
' Methods
'==============================================================================
Private Sub pvFillControls()
Dim oCtl As Object
Dim vElem As Variant
Dim lIdx As Long
Dim lTop As Long
Dim lI As Long
Dim sText As String
Dim lItemData As Long
m_bInSet = True
lIdx = lstMenus.ListIndex
lTop = lstMenus.TopIndex
lstMenus.Visible = False
lstMenus.Clear
For Each oCtl In m_oControl.frContainerMenus
sText = vbTab & Replace(oCtl.Caption, vbTab, "\t") & vbTab & pvGetCtlName(oCtl)
lItemData = 0
For lI = 1 To m_cBmps.Count
vElem = m_cBmps(lI)
If vElem(2) = "#" & pvGetCtlName(oCtl) Then
sText = "*" & sText
lItemData = lI
End If
Next
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?