7,764
社区成员
发帖
与我相关
我的任务
分享
VERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmControls
Caption = "Form2"
ClientHeight = 5640
ClientLeft = 60
ClientTop = 435
ClientWidth = 9000
LinkTopic = "Form2"
ScaleHeight = 5640
ScaleWidth = 9000
StartUpPosition = 3 '窗口缺省
Begin MSComctlLib.TabStrip TabStrip1
Height = 2175
Left = 2640
TabIndex = 4
Top = 2640
Width = 5415
_ExtentX = 9551
_ExtentY = 3836
_Version = 393216
BeginProperty Tabs {1EFB6598-857C-11D1-B16A-00C0F0283628}
NumTabs = 1
BeginProperty Tab1 {1EFB659A-857C-11D1-B16A-00C0F0283628}
Caption = "标准"
ImageVarType = 2
EndProperty
EndProperty
End
Begin VB.CommandButton cmdChangeFont
Caption = "Change Font"
Height = 375
Left = 3480
TabIndex = 3
Top = 600
Width = 1095
End
Begin VB.CommandButton cmdLogin
Caption = "Login"
Height = 375
Left = 960
TabIndex = 2
Top = 1800
Width = 1095
End
Begin VB.TextBox txtUserPwd
Height = 375
Left = 600
TabIndex = 1
Text = "pass"
Top = 1080
Width = 1935
End
Begin VB.Label lblUserName
Caption = "用户名:"
Height = 375
Left = 600
TabIndex = 0
Top = 480
Width = 1335
End
End
Attribute VB_Name = "frmControls"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Sub cmdChangeFont_Click()
Me.Font.Size = 20
End Sub
'---------------------------------------------------------------------------------------
' 过程名 : InitControlsFont
' 时间 : 2012-12-19 10:03
' 作者 : 杨过.网狐.cn(csdn bcrun)
' 功能 :
' 说明 :
' 备注 :
'---------------------------------------------------------------------------------------
'
Private Sub InitControlsFont()
Dim vNewFont As New StdFont
vNewFont.Size = 9
On Error Resume Next
Set Me.Font = vNewFont
'注意,不加set赋值的话,不会报错,但不会有什么效果
Set lblUserName.Font = vNewFont
Set txtUserPwd.Font = vNewFont
Set cmdLogin.Font = vNewFont
Set TabStrip1.Font = vNewFont
If (Err.Number <> 0) Then
MsgBox Err.Description
End If
End Sub
Private Sub Form_Load()
InitControlsFont
End Sub
Private Sub InitFont()
Dim f As New StdFont
With f
.Name = "仿宋体"
.Size = 12
End With
Dim Ctrl As Control
On Error Resume Next
For Each Ctrl In Controls
Set Ctrl.Font = f
Next
End Sub
'标准模块
Option Explicit
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Const GWL_WNDPROC As Long = -4
Public Const WM_RBUTTONDOWN As Long = &H204&
Public PicBoxprevWndProc As Long
'自定义窗口处理程序(子类化图片框,拦截图片框消息)
Public Function PictureBoxWndProc(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Select Case Msg
Case WM_RBUTTONDOWN '弹出右键菜单
MsgBox ("单击了鼠标右键") '测试用
'用于弹出鼠标右键菜单
Case Else '操作系统预定义窗口处理程序
PictureBoxWndProc = CallWindowProc(PicBoxprevWndProc, hwnd, Msg, wParam, lParam)
End Select
End Function
'Form1窗体模块
ption Explicit
Private Sub Command1_Click()
Dim i As Long
'卸载子类化图片框数组
For i = 0 To Picture1.UBound
SetWindowLong Picture1(i).hwnd, GWL_WNDPROC, PicBoxprevWndProc
PicBoxprevWndProc = 0
Next
Unload Me
End Sub
Private Sub Form_Load()
Dim i As Long
Me.ScaleMode = 3
Picture1(0).ScaleMode = 3
'动态创建图片框数组
For i = 1 To 4
Load Picture1(i)
Picture1(i).Visible = True
Picture1(i).Left = 0
Picture1(i).Top = Picture1(0).ScaleHeight * i
Next
'子类化图片框数组
For i = 0 To Picture1.UBound
PicBoxprevWndProc = GetWindowLong(Picture1(i).hwnd, GWL_WNDPROC)
SetWindowLong Picture1(i).hwnd, GWL_WNDPROC, AddressOf PictureBoxWndProc
Next
End Sub
Private Sub Form_Unload(Cancel As Integer)
Call Command1_Click
End Sub
Private Sub Picture1_Click(Index As Integer)
MsgBox ("单击了鼠标左键")
End Sub