急切求知：用VB画菱形并填充的方法
最好把程序写一下，小弟菜鸟一个！：） 问题点数：20、回复次数：6Top
1 楼hycao（海草）回复于 2002-06-06 13:53:25 得分 10
不算什么好方法，但很有趣：
Private Sub Form_Load()
Dim x As Integer, y As Integer
Dim i As Integer
i = 0
Form1.AutoRedraw = True
Form1.ForeColor = vbGreen
Form1.ScaleHeight = 300
Form1.ScaleWidth = 500
For y = 51 To 150
For x = 1 To 2 * i + 1
Form1.PSet (250 - i + x, y)
Next x
i = i + 2
Next y
i = i - 2
For y = 151 To 250
For x = 1 To 2 * i + 1
Form1.PSet (250 - i + x, y)
Next x
i = i - 2
Next y
End Sub
Top
2 楼czztk（星光）回复于 2002-06-06 14:47:28 得分 0
反上面的PSet改为Line，速度会快很多。Top
3 楼litong33_61（李童）回复于 2002-06-06 18:57:19 得分 0
菱形的角度是给定的怎么画！快帮帮我：）Top
4 楼lgd211（lgd211）回复于 2002-06-06 19:00:38 得分 10
Option Explicit
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Type size
cx As Long
cy As Long
End Type
Private Declare Function CreatePen& Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long)
Private Declare Function CreateSolidBrush& Lib "gdi32" (ByVal crColor As Long)
Private Declare Function SelectObject& Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject As Long)
Private Declare Function Polyline& Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long)
Private Declare Function Polygon& Lib "gdi32" (ByVal hdc As Long, lpPoint As POINTAPI, ByVal nCount As Long)
Private Declare Function SetViewportOrgEx Lib "gdi32" (ByVal hdc As Long, ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI) As Long
Private Declare Function SetViewportExtEx Lib "gdi32" (ByVal hdc As Long, ByVal nX As Long, ByVal nY As Long, lpSize As size) As Long
Private Declare Function SetMapMode Lib "gdi32" (ByVal hdc As Long, ByVal nMapMode As Long) As Long
Private Declare Function PlayMetaFile Lib "gdi32" (ByVal hdc As Long, ByVal hMF As Long) As Long
Private Declare Function RestoreDC Lib "gdi32" (ByVal hdc As Long, ByVal nSavedDC As Long) As Long
Private Declare Function SaveDC 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 Const PS_SOLID = 0
Private Const PS_DASH = 1
Private Const PS_DASHDOT = 3
Private Const PS_DASHDOTDOT = 4
Private Const MM_ANISOTROPIC = 8
Private Const MM_TEXT = 1
Dim dcPicSM As Long, saved As Long, usewmf As Long '图片框的句柄
Dim di As Long 'API函数返回值
Dim PointArray(4) As POINTAPI
Dim lngPointNum As Long
Private Sub Pic_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim Direction As Single
dcPicSM = pic.hdc
saved = SaveDC(dcPicSM)
pic.DrawMode = vbXorPen
' pic.ForeColor = &HFFFFC0
pic.ScaleMode = 2
'画图
pic.AutoRedraw = True
Dim angle As Single '角度
lngPointNum = 4
Direction = 0
angle = (90 - Direction) * 0.01745329252
PointArray(0).X = X + 13 * Cos(angle)
PointArray(0).Y = Y - 13 * Sin(angle)
angle = angle + 148 * 0.01745329252
PointArray(1).X = X + 13 * Cos(angle)
PointArray(1).Y = Y - 13 * Sin(angle)
angle = angle + 32 * 0.01745329252
PointArray(2).X = X + 13 * Cos(angle) / 2
PointArray(2).Y = Y - 13 * Sin(angle) / 2
angle = angle + 32 * 0.01745329252
PointArray(3).X = X + 13 * Cos(angle)
PointArray(3).Y = Y - 13 * Sin(angle)
Call DrawFill(PS_SOLID, 0, &HFF00C0, &HFFC0) '画箭头
di = RestoreDC(dcPicSM, saved)
pic.Refresh
pic.DrawMode = vbCopyPen '恢复笔状态
End Sub
Private Sub DrawFill(ByVal LineStyle As Long, ByVal LineWidth As Long, ByVal LineColor As Long, ByVal FillColor As Long)
'给出线段的线形,宽度,颜色画填充
Dim oldPen As Long, newPen As Long
Dim oldBrush As Long, newBrush As Long
newPen = CreatePen(LineStyle, LineWidth, LineColor) '设置新笔
If newPen <> 0 Then oldPen = SelectObject(dcPicSM, newPen) '选择新笔,保存旧笔
newBrush = CreateSolidBrush(FillColor) '设置新刷子
If newBrush <> 0 Then oldBrush = SelectObject(dcPicSM, newBrush) '选择新刷子,保存旧刷子
di = Polygon(dcPicSM, PointArray(0), lngPointNum) '填充图形
If oldPen <> 0 Then di = SelectObject(dcPicSM, oldPen) '恢复旧笔
If newPen <> 0 Then di = DeleteObject(newPen) '删除新笔
If oldBrush <> 0 Then di = SelectObject(dcPicSM, oldBrush) '恢复旧刷子
If newBrush <> 0 Then di = DeleteObject(newBrush) '删除新刷子
End Sub
可以用。
Top
5 楼litong33_61（李童）回复于 2002-06-06 19:18:25 得分 0
怎么实现不了？
多点注释好吗：）Top
6 楼lgd211（lgd211）回复于 2002-06-06 19:24:09 得分 0
可以阿。我用的蛮好的。
你在form上加一个名为pic的pictuerbox控件。这个方法是可以填充pictuerbox的
我做的东西就是用这个方法。给你的是另写的。Top
相关问题
关键词
得分解答快速导航
相关链接
广告也精彩
反馈
