首先,新建一个窗体,名称frmmain,上面加一个picturebox,名称为picpaint
加一个按钮,双击,代码如下:
Option Explicit
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private fnt As CLogFont
Private x(1 To 8) As Single
Private y(1 To 8) As Single
Private xcaption As String
Private Ycaption As String
Private n As Integer
Public Xo As Single
Public Yo As Single
Public Xlast As Single 'X 轴终点坐标
Public Ylast As Single 'Y 轴终点坐标
'***********************选坐标系子过程**************************
'说明:该程序为任何无附着点的数组选坐标系
Sub PaintAxis(XL() As Single, YL() As Single, _
n As Integer, _
Optional xcaption As String = "X_Axis", Optional Ycaption As String = "Y_Axis", _
Optional Title As String)
Dim Ox As Single 'X 最大值
Dim PX As Single 'X 最小值
Dim Qy As Single 'Y 最大值
Dim Ry As Single 'Y 最小值
Dim OP As Single 'X 值长
Dim QR As Single 'Y 值长
Dim xo1 As Single
Dim Yo1 As Single
Dim XLast1 As Single
Dim YLast1 As Single
Dim XoXL1 As Single
Dim YoYL1 As Single
Dim LscaleX As Single '左上角坐标
Dim LscaleY As Single
Dim RscaleX As Single '右下角坐标
Dim RscaleY As Single
Dim XoXL As Single 'X 轴长
Dim YoYL As Single 'Y 轴长
Dim i As Single
Dim Picobj As Object
Set Picobj = frmmain.picpaint
With Picobj
Picobj.Cls
Picobj.Scale
Picobj.FontSize = 9
'***************以下计算最大最小值**************
Ox = -10 ^ 38
PX = 10 ^ 38
Qy = Ox
Ry = PX
For i = 1 To n
If Ox < XL(i) Then Ox = XL(i)
If PX > XL(i) Then PX = XL(i)
If Qy < YL(i) Then Qy = YL(i)
If Ry > YL(i) Then Ry = YL(i)
Next i
'************以下计算方次 mx my************************
Dim mx As Single '计算 X轴方次
Dim Px2 As Single
Dim AverX, AverY As Single
AverX = 0: AverY = 0
For i = 1 To n
AverX = AverX + XL(i)
AverY = AverY + YL(i)
Next i
AverX = AverX / n
AverY = AverY / n
mx = 0
Px2 = AverX
Select Case Abs(Px2)
Case Is < 0.1
Do
Px2 = Px2 * 10
mx = mx + 1
Loop Until Abs(Px2) >= 1
Case Is >= 100
Do
Px2 = Px2 / 10
mx = mx - 1
Loop Until Abs(Px2) < 10
Case Else
mx = 0
End Select
'* * * * * * * * * * * * * * * * * * * * *
Dim my As Single '计算 Y轴方次
Dim Ry2 As Single
my = 0
Ry2 = AverY
Select Case Abs(Ry2)
Case Is < 0.1
Do
Ry2 = Ry2 * 10
my = my + 1
Loop Until Abs(Ry2) >= 1
Case Is >= 100
Do
Ry2 = Ry2 / 10
my = my - 1
Loop Until Abs(Ry2) < 10
Case Else
my = 0
End Select
'*************以下确定坐标系统*******************
xo1 = 800
Yo1 = .ScaleHeight - 600
XLast1 = .ScaleWidth - 800
YLast1 = 600 '600 越小,上框越上
XoXL1 = XLast1 - xo1
YoYL1 = Yo1 - YLast1
OP = Ox - PX
QR = Qy - Ry
Xo = Format((((PX - OP / 8)) * 10 ^ mx), "#0.00") / 10 ^ mx '20越大,点越稀
Yo = Format((((Ry - QR / 8)) * 10 ^ my), "#0.00") / 10 ^ my
Xlast = Xo + 10 * Format(OP / 8 * 10 ^ mx, "#0.00") / 10 ^ mx
Ylast = Yo + 10 * Format(QR / 8 * 10 ^ my, "#0.00") / 10 ^ my
XoXL = Xlast - Xo 'X轴长度
YoYL = Ylast - Yo 'Y轴长度
LscaleX = Xo - XoXL / XoXL1 * xo1
LscaleY = Ylast + YoYL / YoYL1 * YLast1
RscaleX = Xlast + XoXL / XoXL1 * (.ScaleWidth - XLast1)
RscaleY = Yo - YoYL / YoYL1 * (.ScaleHeight - Yo1)
'****************画轴*********************
.FontBold = False
.DrawWidth = 1
Picobj.Line (xo1, Yo1)-(XLast1, Yo1)
Picobj.Line (xo1, Yo1)-(xo1, YLast1)
'****************以下画刻度****************************************************************
For i = 1 To 10
Picobj.Line (xo1 + XoXL1 / 10 * i, Yo1)-(xo1 + XoXL1 / 10 * i, Yo1 - 80)
Picobj.Line (xo1, Yo1 - YoYL1 / 10 * i)-(xo1 + 80, Yo1 - YoYL1 / 10 * i)
Next i
'******************以下标注坐标轴*********************************
.FontSize = 9
For i = 0 To 10
Dim Ax As Single
Ax = XoXL / 10 * i + Xo '标注 X轴
.CurrentX = xo1 + XoXL1 / 10 * i
.CurrentY = Yo1
Picobj.Print Format(Ax * (10 ^ mx), "#0.00")
Dim Ay As Single
Ay = YoYL / 10 * i + Yo '标注 Y轴
.CurrentX = xo1 - 500 '500越大,Y轴坐标离Y轴越远
.CurrentY = Yo1 - YoYL1 / 10 * i
Picobj.Print Format(Ay * (10 ^ my), "#0.00")
Next i
'**************打印坐标轴名称*************************************
'* * * *打印 X轴名称
.FontSize = 12
.FontBold = True
.CurrentX = xo1 + XoXL1 / 2 '定在中间
.CurrentY = Yo1 + 150 '300越大,距轴越远
Select Case mx
Case Is >= 2
Picobj.Print xcaption & "(" & "×E-" & mx & ")"
Case Is <= -2
Picobj.Print xcaption & "(" & "×E+" & Abs(mx) & ")"
Case Else
Picobj.Print xcaption
End Select
'* * * * * 打印 Y轴名称 * * * *
' .CurrentX = xo1 - 500 '500越大,越往左
' .CurrentY = YLast1 - 300 '200越大,越往上
' Select Case my
' Case Is >= 2
' Picobj.Print Ycaption & "(" & "×E-" & my & ")"
' Case Is <= -2
' Picobj.Print Ycaption & "(" & "×E+" & Abs(my) & ")"
' Case Else
' Picobj.Print Ycaption
' End Select
Set fnt = New CLogFont
Set fnt.LogFont = Picobj.Font
Dim hFont As Long
fnt.Rotation = 90
hFont = SelectObject(.hDC, fnt.Handle)
.CurrentX = 50
.CurrentY = .ScaleHeight / 2
Select Case my
Case Is >= 2
Picobj.Print Ycaption & "(" & "×E-" & my & ")"
Case Is <= -2
Picobj.Print Ycaption & "(" & "×E+" & Abs(my) & ")"
Case Else
Picobj.Print Ycaption
End Select
Call SelectObject(.hDC, hFont)
'****************打印标题***********************
' .FontName = "隶书"
.FontSize = 15
Dim Length As Integer
Length = Len(Title)
If Length <= 10 Then .CurrentX = .ScaleWidth / 3
If Length > 10 Then .CurrentX = .ScaleWidth / 4
.CurrentY = 50
Picobj.Print Title
'***************确定实际坐标系统*********************************
Picobj.Scale (LscaleX, LscaleY)-(RscaleX, RscaleY)
End With
End Sub
'****************描点子过程****************
'条件:坐标系统必须已定
Sub PaintSet(x() As Single, y() As Single, n As Integer)
Dim i As Integer
For i = 1 To n
frmmain.picpaint.DrawWidth = 5
frmmain.picpaint.CurrentX = x(i)
frmmain.picpaint.CurrentY = y(i)
frmmain.picpaint.PSet (x(i), y(i))
Next i
End Sub
'*************作直线子程序*************************
'说明:1.坐标系统必须已给出
' 2.坐标轴原点坐标Xo,Yo及终点坐标Xlast,Ylast已算出,并设为公共变量
Sub PaintLine(x() As Single, y() As Single, n As Integer)
Dim k As Single
Dim B As Single
Dim xx1 As Single
Dim xx2 As Single
Dim yy1 As Single
Dim yy2 As Single
k = KK(x(), y(), n)
B = BB(x(), y(), n)
yy1 = k * Xo + B
xx1 = (Yo - B) / k
yy2 = k * Xlast + B
xx2 = (Ylast - B) / k
frmmain.picpaint.DrawWidth = 1
If k > 0 Then
If xx1 < Xo Then xx1 = Xo
If yy1 < Yo Then yy1 = Yo
If xx2 > Xlast Then xx2 = Xlast
If yy2 > Ylast Then yy2 = Ylast
frmmain.picpaint.Line (xx1, yy1)-(xx2, yy2), QBColor(12)
End If
If k < 0 Then
If xx2 < Xo Then xx2 = Xo
If yy1 > Ylast Then yy1 = Ylast
If xx1 > Xlast Then xx1 = Xlast
If yy2 < Yo Then yy2 = Yo
frmmain.picpaint.Line (xx2, yy1)-(xx1, yy2), QBColor(12)
End If
End Sub