|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Option Explicit
创建笔刷的API函数
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
API指针类型
Private Type POINTAPI
X As Long
Y As Long
End Type
创建多边形区域的函数
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As Any, _
ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
创建多边形
Private Declare Function Polygon Lib "gdi32" (ByVal hdc As Long, _
lpPoint As Any, ByVal nCount As Long) As Long
填充多边形区域
Private Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, _
ByVal hRgn As Long, ByVal hBrush As Long) As Long
删除对象
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
查找窗口
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String _
) As Long
获取窗口DC
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Const ALTERNATE = 1 ' ALTERNATE and WINDING are
Const WINDING = 2 ' constants for FillMode.
Const BLACKBRUSH = 1.6
Dim i As Long
Dim NumCoords, bool, hBrush, hRgn, Trash
Dim sX, sY
Dim Poly() As POINTAPI
鼠标在窗体上移动，收集多边形边界点
Private Sub UserForm_MouseMove(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
If Button = 1 Then
i = i + 1
ReDim Preserve Poly(1 To i) ‘这些是将来要绘制的点集合
Poly(i).X = X * 1.33 ‘1.33是象素和磅之间的换算，基于电脑设置为96DPI。
Poly(i).Y = Y * 1.33
End If
End Sub
鼠标抬起时绘制多边形区域并填充
Private Sub UserForm_MouseUp(ByVal Button As Integer, _
ByVal Shift As Integer, _
ByVal X As Single, _
ByVal Y As Single)
Dim hwnd As Long
Dim hdc As Long
On Error Resume Next
If Button = 2 Then Me.Repaint ‘右键清除图画
hwnd = FindWindow(vbNullString, Me.Caption) ‘查找当前窗体窗口句柄
hdc = GetDC(hwnd) ‘获取当前窗口的DC
bool = Polygon(hdc, Poly(1), i) ‘绘制多边形边界（如果没有本句，绘制的图画就没有边界）
hBrush = CreateSolidBrush(vbGreen) ‘创建填充笔刷
hRgn = CreatePolygonRgn(Poly(1), i, ALTERNATE) ‘创建多边形区域
If hRgn Then bool = FillRgn(hdc, hRgn, hBrush) ‘填充多边形区域（如果没有本句，则只有多边形边界，而不会填充）
Erase Poly: i = 0 ‘清除数组，并从头开始绘图 （去掉i＝0试试看）
Trash = DeleteObject(hRgn) ‘删除创建的对象，这是个编程的好习惯
End Sub
NNnxzvPL.zip
(11.03 KB, 下载次数: 319)
|
|
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2006-4-5 11:50
发表于 2006-4-5 12:32
楼主
