📄 frmshapes.frm
字号:
VERSION 5.00
Object = "{B25498A2-5592-11D3-8644-DA5FB01D9D37}#1.1#0"; "ExRainButton.ocx"
Begin VB.Form frmShapes
BorderStyle = 3 'Fixed Dialog
Caption = "Excalibur RainbowButton Shapes Demo"
ClientHeight = 3840
ClientLeft = 45
ClientTop = 330
ClientWidth = 5280
BeginProperty Font
Name = "Wingdings"
Size = 99.75
Charset = 2
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "frmShapes.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 256
ScaleMode = 3 'Pixel
ScaleWidth = 352
ShowInTaskbar = 0 'False
StartUpPosition = 2 'CenterScreen
Begin VB.Frame fra
Caption = "Custom Shapes"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1935
Index = 1
Left = 120
TabIndex = 3
Top = 1800
Width = 5055
Begin VB.CommandButton cmdEllipse
Caption = "Double Ellipse"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 120
TabIndex = 7
Top = 1200
Width = 2295
End
Begin VB.CommandButton cmdStar
Caption = "Star"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 120
TabIndex = 6
Top = 720
Width = 2295
End
Begin VB.CommandButton cmdWin
Caption = "Windows Logo"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 120
TabIndex = 5
Top = 240
Width = 2295
End
Begin ExRainButton.RainButton cmdCustom
Height = 1575
Left = 2520
TabIndex = 4
Top = 240
Width = 2415
_ExtentX = 4260
_ExtentY = 2778
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Caption = "Custom"
MouseTrack = -1 'True
End
End
Begin VB.Frame fra
Caption = "Built-in Shapes"
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1455
Index = 0
Left = 120
TabIndex = 0
Top = 120
Width = 5055
Begin ExRainButton.RainButton cmdBuiltin
Height = 1095
Left = 2520
TabIndex = 2
Top = 240
Width = 2415
_ExtentX = 4260
_ExtentY = 1931
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "Times New Roman"
Size = 15.75
Charset = 0
Weight = 700
Underline = 0 'False
Italic = -1 'True
Strikethrough = 0 'False
EndProperty
Caption = "Shapes"
MouseTrack = -1 'True
End
Begin VB.ListBox lst
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1140
IntegralHeight = 0 'False
ItemData = "frmShapes.frx":000C
Left = 120
List = "frmShapes.frx":001F
TabIndex = 1
Top = 240
Width = 2295
End
End
End
Attribute VB_Name = "frmShapes"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function BeginPath Lib "gdi32" _
(ByVal hDC As Long) As Long
Private Declare Function TextOut Lib "gdi32" _
Alias "TextOutA" (ByVal hDC As Long, _
ByVal X As Long, ByVal Y As Long, _
ByVal lpString As String, _
ByVal nCount As Long) As Long
Private Declare Function EndPath Lib "gdi32" _
(ByVal hDC As Long) As Long
Private Declare Function PathToRegion Lib "gdi32" _
(ByVal hDC As Long) As Long
Private Declare Function GetRgnBox Lib "gdi32" _
(ByVal hRgn As Long, lpRect As RECT) As Long
Private Declare Function CreateRectRgnIndirect Lib "gdi32" _
(lpRect As RECT) As Long
Private Declare Function CombineRgn Lib "gdi32" _
(ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, _
ByVal hSrcRgn2 As Long, _
ByVal nCombineMode As Long) As Long
Private Const RGN_AND = 1
Private Const RGN_XOR = 3
Private Declare Function DeleteObject Lib "gdi32" _
(ByVal hObject 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 Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, _
ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" _
(ByVal X1 As Long, ByVal Y1 As Long, _
ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" _
() As Long
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
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2
Private Function GetTextRgn() As Long
Dim hRgn1 As Long, hRgn2 As Long
Dim rct As RECT
'Create a path on the form's device context...
BeginPath hDC
TextOut hDC, 0, -15, Chr$(255), 1
EndPath hDC
'... convert that path to a region for our form...
hRgn1 = PathToRegion(hDC)
GetRgnBox hRgn1, rct
hRgn2 = CreateRectRgnIndirect(rct)
'... and invert the region.
CombineRgn hRgn2, hRgn2, hRgn1, RGN_AND
DeleteObject hRgn1
GetTextRgn = hRgn2
End Function
Private Sub cmdEllipse_Click()
Dim hRgn As Long
hRgn = GetDblEllipse()
cmdCustom.SetRegion hRgn
cmdCustom.Refresh
End Sub
Private Sub cmdStar_Click()
Dim pt(0 To 7) As POINTAPI
Dim lWidth As Long
Dim lHeight As Long
Dim hRgn As Long
lWidth = cmdCustom.Width \ Screen.TwipsPerPixelX
lHeight = cmdCustom.Height \ Screen.TwipsPerPixelY
'Left point
pt(0).X = 0
pt(0).Y = lHeight \ 2
pt(1).X = (lWidth \ 2) - 10
pt(1).Y = (lHeight \ 2) - 10
'Top point
pt(2).X = lWidth \ 2
pt(2).Y = 0
pt(3).X = (lWidth \ 2) + 10
pt(3).Y = (lHeight \ 2) - 10
'Right point
pt(4).X = lWidth
pt(4).Y = lHeight \ 2
pt(5).X = (lWidth \ 2) + 10
pt(5).Y = (lHeight \ 2) + 10
'Bottom point
pt(6).X = lWidth \ 2
pt(6).Y = lHeight
pt(7).X = (lWidth \ 2) - 10
pt(7).Y = (lHeight \ 2) + 10
hRgn = CreatePolygonRgn(pt(0), 8, 1)
cmdCustom.SetRegion hRgn
cmdCustom.Refresh
End Sub
Private Sub cmdWin_Click()
'Change the shape of our form!
Dim hRgn As Long
hRgn = GetTextRgn()
cmdCustom.SetRegion hRgn
cmdCustom.Refresh
End Sub
Private Sub lst_Click()
cmdBuiltin.SetShape lst.ListIndex
cmdBuiltin.Refresh
End Sub
Private Function GetDblEllipse() As Long
Dim hRgn1 As Long, hRgn2 As Long
Dim lWidth As Long
Dim lHeight As Long
lWidth = cmdCustom.Width \ Screen.TwipsPerPixelX
lHeight = cmdCustom.Height \ Screen.TwipsPerPixelY
'Create two side-by-side elliptic regions
hRgn1 = CreateEllipticRgn(0, 0, (lWidth \ 2) + 15, lHeight)
hRgn2 = CreateEllipticRgn((lWidth \ 2) - 15, 0, lWidth, lHeight)
'... and combine the regions.
CombineRgn hRgn2, hRgn2, hRgn1, RGN_XOR
DeleteObject hRgn1
GetDblEllipse = hRgn2
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -