- 积分
- 26288
- 贡献
-
- 精华
- 在线时间
- 小时
- 注册时间
- 2011-11-7
- 最后登录
- 1970-1-1
|
登录后查看更多精彩内容~
您需要 登录 才可以下载或查看，没有帐号？立即注册
x
本帖最后由 山水美不美 于 2019-1-13 09:20 编辑
窗体上添加2个Command，1个Picture，麻烦各位老师指点。代码如下：
Dim mj As Long, mi As Long, Xmin As Single, Ymin As Single, Xmax As Single, Ymax As Single, dxx As Single, dyy As Single
Dim cLineFile As String, bList As Boolean
Dim X() As Double
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 Pt() As POINTAPI
Dim lngPointNum As Long
Private Sub Command1_Click()
Pic.MousePointer = 2
Dim cFile As String, Fid As Long, i As Long, j As Long
Me.MousePointer = 11
Fid = FreeFile
cFile = App.Path & "\Grid.dat"
Open cFile For Input As Fid
Input #Fid, mj, mi
ReDim X(1 To mj, 1 To mi)
For j = 1 To mj
For i = 1 To mi
Input #Fid, X(j, i)
Next
Next
Close (Fid)
Call Draw
For j = 0 To mj - 1
For i = 0 To mi - 1
Pic.CurrentX = i
Pic.CurrentY = j
Pic.Print Format(X(j + 1, i + 1), "##0") '标注极值数据
Next
Next
'Call Com5
Me.MousePointer = 0
End Sub
Private Sub Draw() '画自定义坐标
Pic.Cls
Dim x1 As Integer, x2 As Integer, y1 As Integer, y2 As Integer
Dim i As Integer, j As Integer
Pic.Scale (-1, mj)-(mi, -1)
Pic.ForeColor = vbBlack
For i = 0 To mi - 1
Pic.Line (i, mj - 1)-(i, 0)
Next
For i = 0 To mj - 1
Pic.Line (0, i)-(mi - 1, i)
Next
End Sub
Private Sub Com5() '读取任意闭合多边形的控制点数据
Dim i As Long, j As Long, Fid As Long, k As Long, n As Long, m As Long, VMin As Double, VMax As Double
Dim x1 As Double, y1 As Double, s As String, LorH As Integer
Dim x2 As Double, y2 As Double, dxx As Single, dyy As Single
On Error GoTo Nodat:
cLineFile = App.Path & "\outPolygon.Txt"
If cLineFile <> "" Then
Pic.ForeColor = vbRed
Fid = FreeFile
Open cLineFile For Input As #Fid
Input #Fid, n '读取多边形的总数目
For k = 1 To n
Input #Fid, VMin, VMax, m '每个组每个多边形的控制点数
Input #Fid, x1, y1
dxx = 0: dyy = 0
If x1 <= 0 Then dxx = -0.8 '标注点在起点上增加一点偏移量,以下类同
If x1 >= mi - 1 Then dxx = 0.3
If y1 <= 0 Then dyy = -0.3
If y1 >= mj - 1 Then dyy = 0.4
Pic.ForeColor = vbScrollBars
Pic.CurrentX = x1 + dxx
Pic.CurrentY = y1 + dyy
Pic.Print Format(VMin, "##0") & "-"; Format(VMax, "##0") '标注极值数据
Pic.ForeColor = vbRed - (k - 1) * 30 '给出颜色差异
Pic.DrawWidth = 1 + k \ 5
For i = 1 To m - 1
Input #Fid, x2, y2
Pic.Line (x1, y1)-(x2, y2) '这个能画出闭合多边形的边界效果
x1 = x2: y1 = y2
Next
Next
End If
Nodat:
Close (Fid)
End Sub
Private Sub Command2_Click() '用指定颜色填充任意多边形
Dim x1 As Double, y1 As Double, s As String, LorH As Integer, m As Long, n As Integer, k As Integer, i As Integer
Dim x2 As Double, y2 As Double, dxx As Single, dyy As Single, Fid As Long, VMin As Single, VMax As Single
On Error GoTo Nodat:
cLineFile = App.Path & "\outPolygon.Txt"
If cLineFile <> "" Then
Pic.ForeColor = vbRed
Fid = FreeFile
Open cLineFile For Input As #Fid
Input #Fid, n '读取边界等值面的总数目
For k = 1 To n
Input #Fid, VMin, VMax, m '每个组成等值面的控制点数
Input #Fid, x1, y1
dxx = 0: dyy = 0
If x1 <= 0 Then dxx = -0.8
If x1 >= mi - 1 Then dxx = 0.3
If y1 <= 0 Then dyy = -0.3
If y1 >= mj - 1 Then dyy = 0.4
Pic.ForeColor = vbBlue
Pic.CurrentX = x1 + dxx
Pic.CurrentY = y1 + dyy
Pic.Print Format(VMin, "##0") & "-"; Format(VMax, "##0") '标注极值数据
Pic.ForeColor = vbRed - k + 10
ReDim Pt(0 To m - 1)
Pt(0).X = x1: Pt(0).Y = y1
For i = 1 To m - 1
Input #Fid, x2, y2
Pt(i).X = x2: Pt(i).Y = y2
Next
Call DrawFill(Pt, m - 1, PS_SOLID, 0, vbRed, &HFFC0) ''用指定颜色填充任意多边形,无效果
Next
End If
Nodat:
Close (Fid)
End Sub
Private Sub DrawFill(ByRef PointArray() As POINTAPI, ByVal lngPointNum As Long, 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
附件上传文件有问题，只好在下面开窗粘贴数据了。
|
|
窥视卡
雷达卡
发表于 2019-1-13 09:16:20
提升卡
置顶卡
沉默卡
喧嚣卡
变色卡
抢沙发
千斤顶
显身卡
楼主