找到的以前的代码,BAS文件贴在最后
调用函数示例。
有二个值写在配置文件里,
[Analysis]
折线图标=▲●■★◢◆▼
颜色表=128,8388608,32896,8421376,16711680,32768,16711935
图就不截了,难打码。代码不解释了,代码写于 2015年,自己也忘了
。
只知道数据是从 指定窗体的 listview 中读取的,生成一个二维数组,然后去绘图。
程序代码:
Public Sub 分析入口(cs As String, cs2 As String, fr As Form, X名称 As Long)
'传入的参数为 对应的各个字段 ,X名称 是指前几个为X
If Len(cs) = 0 Then
MsgBox "系统错误,未取得所需的信息内容", vbCritical, 程序标题
Unload Me
Exit Sub
End If
Dim i As Long, j As Long, k As Long
Dim indexkey() As Long '保存每个指标在listview中的索引号
Dim fj() As String
fj = Split(cs, ",")
aa.标题 = cs2 '标题
Me.Caption = cs2
数据个数 = UBound(fj) '取总指标个数
ReDim aa.指标(数据个数) '重定义指标数
For i = 0 To 数据个数 '设置每个指标
aa.指标(i) = fj(i)
Next i
ReDim indexkey(数据个数) '重定义索引号位置
With fr.ListView1
'恢复序号排序
.SortKey = 0
.SortOrder = lvwAscending
.Sorted = True
For j = 0 To 数据个数
For i = 1 To .ColumnHeaders.Count
If .ColumnHeaders(i).Text = fj(j) Then '如果列标题等于text
indexkey(j) = i - 1 '第一列是 text ,相当于下标 0
Exit For
End If
Next i
Next j
j = 0
For i = 1 To .ListItems.Count
If Val(.ListItems(i).SubItems(indexkey(0))) > 0 Then '如果该行第一列有数据
j = j + 1
End If
Next i
农户个数 = j - 1
If 农户个数 < 1 Then
MsgBox "操作错误,没有发现可供绘图的数据。", vbCritical, 程序标题
Unload Me
Exit Sub
End If
ReDim aa.单位(农户个数)
ReDim aa.数据(农户个数, 数据个数)
j = 0
For i = 1 To .ListItems.Count
If Val(.ListItems(i).SubItems(indexkey(0))) > 0 Then '如果该行第一列有数据
'-------读X名称-----
For k = 1 To X名称
aa.单位(j) = aa.单位(j) & " " & .ListItems(i).SubItems(k)
Next k
aa.单位(j) = Trim(aa.单位(j))
'-------读数据----------
For k = 0 To 数据个数
aa.数据(j, k) = .ListItems(i).SubItems(indexkey(k))
Next k
j = j + 1
End If
Next i
End With
Call 画图
End Sub
Public Sub 画图()
Picture1.Cls
Select Case 图类型
Case 折线分析图
Call 折线图(Picture1, aa, 上边距1, 下边距1, 左边距1, 右边距1)
Case 柱形分析图
Call 柱形图(Picture1, aa, 上边距1, 下边距1, 左边距1, 右边距1)
Case 堆柱分析图
Call 堆柱图(Picture1, aa, 上边距1, 下边距1, 左边距1, 右边距1)
End Select
End Sub
-------BAS文件---------
程序代码:
Option Explicit
Public Type 数据画图类型
标题 As String
单位() As String 'X轴
指标() As String '几根线的名称
数据() As Double '对应每根线的数据,是一个二维数组
End Type
Public Const 边距 = 500 '用来标注数字的高度和宽度
Public Const 图例宽 = 1800
Public Const 标题高 = 1000
'Public Const 图标样 = "△ ○ □ ☆ ⊿ ◇ ▽"
'Public Const 图标样 = "▲ ● ■ ★ ◢ ◆ ▼"
'Public Const 颜色表 = "4 1 6 3 9 2 13 10 14 11 12 5"
'Public 图标样 As String
Public 颜色表 As String
Public 折线图标() As String '使用配置文件
'--------显示用的边距---------
Public Const 左边距1 = 30
Public Const 右边距1 = 30
Public Const 上边距1 = 30
Public Const 下边距1 = 30
'--------打印用的边距--------
Public 左边距2 As Long
Public 右边距2 As Long
Public 上边距2 As Long
Public 下边距2 As Long
Public Enum 分析图类型分类
折线分析图 = 1
柱形分析图 = 2
堆柱分析图 = 3
End Enum
Public Sub 折线图(obj As Object, DD As 数据画图类型, 上边距 As Long, 下边距 As Long, 左边距 As Long, 右边距 As Long)
On Error Resume Next
Dim 数据个数 As Long
数据个数 = UBound(DD.指标())
Dim COL() As Long
ReDim COL(数据个数)
Dim 样本数 As Long
样本数 = UBound(DD.单位) + 1
Dim Max As Double ' 0起点
Max = 找MAX(DD)
Max = Int(Max) + 1 'max= 向上取一整
Dim Y坐标间隔(10) As Long
Dim X坐标间隔() As Long
ReDim X坐标间隔(样本数)
Dim 有效高 As Long
Dim 高间隔 As Long
有效高 = obj.ScaleHeight - 上边距 - 下边距 - 标题高 - 边距
高间隔 = (有效高) / 10
Dim 有效宽 As Long
Dim 宽间隔 As Long
有效宽 = obj.ScaleWidth - 左边距 - 右边距 - 边距 '边距是用来标Y坐标的
宽间隔 = (有效宽 - 图例宽 - 150) / (样本数 + 1)
Dim i As Long, j As Long
Dim strtmp As String, k As Long
For i = 0 To 10
Y坐标间隔(i) = i * 高间隔
Next i
For i = 0 To 样本数
X坐标间隔(i) = i * 宽间隔
Next i
'读颜色
Call 颜色(COL())
'画坐标网络
Call 画坐标系(obj, 上边距, 下边距, 左边距, 右边距, Max, DD, COL())
'画图例
Call 画图例折(obj, 上边距, 下边距, 左边距, 右边距, Max, DD, COL())
'绘图
Dim k1 As Long, k2 As Long, k3 As Long, k4 As Long, k5 As Long, k6 As Long
'k1 = 左边距 + 宽间隔 + 边距
'k2 = 上边距 + 标题高 + 有效高
obj.FontSize = 8
obj.FontTransparent = False
k5 = obj.TextHeight(" ") / 2
k6 = obj.TextWidth(" ") / 2
obj.DrawWidth = 2
obj.FontSize = 8
For i = 0 To 数据个数
obj.ForeColor = COL(i)
k1 = 左边距 + 宽间隔 + 边距
k2 = 上边距 + 标题高 + 有效高 - DD.数据(0, i) / Max * 有效高
obj.CurrentX = k1 - k5
obj.CurrentY = k2 - k6
obj.Print 折线图标(i)
'obj.Circle (k1, k3), 30, COL(i) '画圆,需取消
For j = 1 To 样本数 - 1
k3 = 左边距 + 宽间隔 * (j + 1) + 边距
k4 = 上边距 + 标题高 + 有效高 - DD.数据(j, i) / Max * 有效高
obj.CurrentX = k3 - k5
obj.CurrentY = k4 - k6
obj.Print 折线图标(i)
obj.Line (k1, k2)-(k3, k4), COL(i)
k1 = k3
k2 = k4
'k = 上边距 + 标题高 + 有效高 - DD.数据(j, i) / Max * 有效高
'obj.Line -((左边距 + 宽间隔 * (j + 1)) + 边距, k), COL(i)
'obj.Circle ((左边距 + 宽间隔 * (j + 1)) + 边距, k), 30, COL(i)
Next j
Next i
obj.FontTransparent = True
'Stop
End Sub
Public Function 找MAX(DD As 数据画图类型) As Double
On Error Resume Next
Dim Max As Double ' 0起点
Dim i As Long, j As Long
Dim 数据个数 As Long
数据个数 = UBound(DD.指标())
Dim 样本数 As Long
样本数 = UBound(DD.单位)
For i = 0 To 样本数
For j = 0 To 数据个数
If Max < DD.数据(i, j) Then
Max = DD.数据(i, j)
End If
Next j
Next i
找MAX = Max
End Function
Public Sub 堆柱图(obj As Object, DD As 数据画图类型, 上边距 As Long, 下边距 As Long, 左边距 As Long, 右边距 As Long)
On Error Resume Next
Dim 数据个数 As Long
数据个数 = UBound(DD.指标())
Dim COL() As Long
ReDim COL(数据个数)
Dim 样本数 As Long
样本数 = UBound(DD.单位) + 1
Dim Max As Double ' 0起点
Max = 找和MAX(DD)
Max = Int(Max) + 1 'max= 向上取一整
Dim Y坐标间隔(10) As Long
Dim X坐标间隔() As Long
ReDim X坐标间隔(样本数)
Dim 有效高 As Long
Dim 高间隔 As Long
有效高 = obj.ScaleHeight - 上边距 - 下边距 - 标题高 - 边距
高间隔 = (有效高) / 10
Dim 有效宽 As Long
Dim 宽间隔 As Long
有效宽 = obj.ScaleWidth - 左边距 - 右边距 - 边距 '边距是用来标Y坐标的
宽间隔 = (有效宽 - 图例宽 - 150) / (样本数 + 1)
Dim i As Long, j As Long
Dim strtmp As String, k As Long
For i = 0 To 10
Y坐标间隔(i) = i * 高间隔
Next i
For i = 0 To 样本数
X坐标间隔(i) = i * 宽间隔
Next i
'读颜色
Call 颜色(COL())
'画坐标网络
Call 画坐标系(obj, 上边距, 下边距, 左边距, 右边距, Max, DD, COL())
'画图例
Call 画图例(obj, 上边距, 下边距, 左边距, 右边距, Max, DD, COL())
'绘图
Dim k1 As Long, k2 As Long, k3 As Long, k4 As Long
obj.DrawWidth = 1
For i = 0 To 样本数 - 1
k = 0
k1 = 上边距 + 标题高 + 有效高
k2 = 左边距 + 宽间隔 * i + 宽间隔 * 0.75 + 边距
k3 = k2 + 宽间隔 * 0.5
k = k1
For j = 0 To 数据个数
k4 = DD.数据(i, j) / Max * 有效高
k = k - k4
obj.Line (k2, k)-(k3, k1), COL(j), BF
k1 = k
Next j
Next i
End Sub
Public Sub 柱形图(obj As Object, DD As 数据画图类型, 上边距 As Long, 下边距 As Long, 左边距 As Long, 右边距 As Long)
On Error Resume Next
Dim 数据个数 As Long
数据个数 = UBound(DD.指标())
Dim COL() As Long
ReDim COL(数据个数)
Dim 样本数 As Long
样本数 = UBound(DD.单位) + 1
Dim Max As Double ' 0起点
Max = 找MAX(DD)
Max = Int(Max) + 1 'max= 向上取一整
Dim Y坐标间隔(10) As Long
Dim X坐标间隔() As Long
ReDim X坐标间隔(样本数)
Dim 有效高 As Long
Dim 高间隔 As Long
有效高 = obj.ScaleHeight - 上边距 - 下边距 - 标题高 - 边距
高间隔 = (有效高) / 10
Dim 有效宽 As Long
Dim 宽间隔 As Long
有效宽 = obj.ScaleWidth - 左边距 - 右边距 - 边距 '边距是用来标Y坐标的
宽间隔 = (有效宽 - 图例宽 - 150) / (样本数 + 1)
Dim i As Long, j As Long
Dim strtmp As String, k As Long
For i = 0 To 10
Y坐标间隔(i) = i * 高间隔
Next i
For i = 0 To 样本数
X坐标间隔(i) = i * 宽间隔
Next i
'读颜色
Call 颜色(COL())
'画坐标网络
Call 画坐标系(obj, 上边距, 下边距, 左边距, 右边距, Max, DD, COL())
'画图例
Call 画图例(obj, 上边距, 下边距, 左边距, 右边距, Max, DD, COL())
'绘图
Dim k1 As Long, k2 As Long, k3 As Long, k4 As Long
Dim k5 As Long, k6 As Long
obj.DrawWidth = 1
k5 = (宽间隔 * 0.8) / (数据个数 + 1)
For i = 0 To 样本数 - 1
k1 = 上边距 + 标题高 + 有效高
'k2 = 左边距 + 宽间隔 * i + 宽间隔 * 0.75 + 边距
k2 = 左边距 + 边距 + 宽间隔 * i + 宽间隔 * 0.6
For j = 0 To 数据个数
k4 = DD.数据(i, j) / Max * 有效高
k3 = k2 + k5 * j
k6 = k2 + k5 * j + k5
obj.Line (k3, k1 - k4)-(k6, k1), COL(j), BF
Next j
Next i
End Sub
Public Function 找和MAX(DD As 数据画图类型) As Double
Dim Max As Double ' 0起点
Dim i As Long, j As Long
Dim 数据个数 As Long
数据个数 = UBound(DD.指标())
Dim 样本数 As Long
样本数 = UBound(DD.单位)
Dim m As Double
For i = 0 To 样本数
m = 0
For j = 0 To 数据个数
m = m + DD.数据(i, j)
Next j
If Max < m Then
Max = m
End If
Next i
找和MAX = Max
End Function
Public Sub 颜色(cs() As Long)
On Error Resume Next
Dim i As Long, j As Long
Dim k As Long
Dim fj() As String
If InStr(1, 颜色表, ",") > 0 Then
fj = Split(颜色表, ",")
Else
fj = Split(颜色表, " ")
End If
For i = 0 To UBound(cs)
k = Val(fj(i))
If k < 14 Then
cs(i) = QBColor(k)
Else
cs(i) = k
End If
If i >= UBound(fj) Then
Exit For
End If
Next i
End Sub
Public Sub 画坐标系(obj As Object, 上边距 As Long, 下边距 As Long, 左边距 As Long, 右边距 As Long, Max As Double, DD As 数据画图类型, COL() As Long)
On Error Resume Next
Dim i As Long
Dim k1 As Long, k2 As Long, k3 As Long, k4 As Long, k5 As Long
Dim strtmp As String
Dim s1() As String
Dim linecolor As Long
'-----------数据个数----------------
Dim 数据个数 As Long
数据个数 = UBound(DD.指标())
Dim 样本数 As Long
样本数 = UBound(DD.单位) + 1
Dim Y坐标间隔(10) As Long
Dim X坐标间隔() As Long
'---------计算坐标数据-----------
ReDim X坐标间隔(样本数)
Dim 有效高 As Long
Dim 高间隔 As Long
有效高 = obj.ScaleHeight - 上边距 - 下边距 - 标题高 - 边距
高间隔 = (有效高) / 10
Dim 有效宽 As Long
Dim 宽间隔 As Long
有效宽 = obj.ScaleWidth - 左边距 - 右边距 - 边距 '边距是用来标Y坐标的
宽间隔 = (有效宽 - 图例宽 - 150) / (样本数 + 1)
For i = 0 To 10
Y坐标间隔(i) = i * 高间隔
Next i
For i = 0 To 样本数
X坐标间隔(i) = i * 宽间隔
Next i
'显示标题
obj.ForeColor = 0
obj.FontSize = 20
obj.FontBold = True
obj.CurrentX = (有效宽 - obj.TextWidth(DD.标题)) / 2 + 左边距
obj.CurrentY = 上边距 + (标题高 - obj.TextHeight(DD.标题)) / 2
obj.Print DD.标题
obj.FontBold = False
linecolor = RGB(128, 128, 128)
'画坐标系
obj.FontSize = 9
obj.DrawWidth = 1
k5 = 上边距 + 标题高
k3 = (左边距 + 宽间隔 * 样本数 + 宽间隔) + 边距
For i = 0 To 10 '横线
'obj.ForeColor = RGB(128, 128, 128)
k2 = (Y坐标间隔(i) + k5)
obj.Line (左边距 + 边距, k2)-(k3, k2), linecolor
'obj.ForeColor = 0 '显示坐标系Y
strtmp = Format(Max - Max / 10 * i, "0.0")
obj.CurrentX = 左边距 + 边距 - obj.TextWidth(strtmp) - 50
obj.CurrentY = Y坐标间隔(i) + k5 - obj.TextHeight(strtmp) / 2
obj.Print strtmp
Next i
k2 = 有效高 + k5
For i = 0 To 样本数 + 1 '竖线
'obj.ForeColor = RGB(128, 128, 128)
k1 = 左边距 + i * 宽间隔 + 边距
obj.Line (k1, k5)-(k1, k2), linecolor
If i > 0 And i < 样本数 + 1 Then '显示坐标系X
'obj.ForeColor = 0
strtmp = DD.单位(i - 1)
s1 = Split(strtmp, " ")
k1 = 宽间隔 * i + 左边距 + 边距
k4 = k2 + obj.TextHeight(strtmp) / 2
obj.CurrentY = obj.CurrentY + 30
For k3 = 0 To UBound(s1)
obj.CurrentX = k1 - obj.TextWidth(s1(k3)) / 2
obj.CurrentY = obj.CurrentY + obj.TextHeight(strtmp) * 0.2
obj.Print s1(k3)
Next k3
End If
Next i
End Sub
Public Sub 画图例(obj As Object, 上边距 As Long, 下边距 As Long, 左边距 As Long, 右边距 As Long, Max As Double, DD As 数据画图类型, COL() As Long)
On Error Resume Next
Dim i As Long, j As Long
Dim k1 As Long, k2 As Long, k3 As Long, k4 As Long, k5 As Long
Dim strtmp As String
Dim s1() As String
'-----------数据个数----------------
Dim 数据个数 As Long
数据个数 = UBound(DD.指标())
Dim 样本数 As Long
样本数 = UBound(DD.单位) + 1
Dim Y坐标间隔(10) As Long
Dim X坐标间隔() As Long
'---------计算坐标数据-----------
ReDim X坐标间隔(样本数)
Dim 有效高 As Long
Dim 高间隔 As Long
有效高 = obj.ScaleHeight - 上边距 - 下边距 - 标题高 - 边距
高间隔 = (有效高) / 10
Dim 有效宽 As Long
Dim 宽间隔 As Long
有效宽 = obj.ScaleWidth - 左边距 - 右边距 - 边距 '边距是用来标Y坐标的
宽间隔 = (有效宽 - 图例宽 - 150) / (样本数 + 1)
For i = 0 To 10
Y坐标间隔(i) = i * 高间隔
Next i
For i = 0 To 样本数
X坐标间隔(i) = i * 宽间隔
Next i
k5 = 上边距 + 标题高
'图例
'图例,双线框
obj.ForeColor = 0
k3 = 左边距 + 有效宽 + 边距 '右角
k2 = k3 - 图例宽 '左角
obj.Line (k2, k5)-(k3, k5 + 有效高), , B
obj.Line (k2 + 30, k5 + 30)-(k3 - 30, k5 + 有效高 - 30), , B
strtmp = "图 例"
obj.FontSize = 12
obj.CurrentX = k3 - (图例宽 + obj.TextWidth(strtmp)) / 2 'K3 是右角
obj.CurrentY = k5 + 高间隔
obj.Print strtmp
obj.FontSize = 9
obj.DrawWidth = 2
For i = 0 To 数据个数
If 数据个数 = 0 Then
j = k5 + 高间隔 * 4.5 + obj.TextHeight(" ") / 2
Else
j = k5 + 高间隔 * 3 + i * (高间隔 * 5 / 数据个数) + obj.TextHeight(" ") / 2
End If
obj.Line ((k3 - 图例宽 / 2 + 150), j - 50)-(k3 - 150, j + 50), COL(i), BF 'k3 为右角
If 数据个数 = 0 Then
j = k5 + 高间隔 * 4.5
Else
j = k5 + 高间隔 * 3 + i * (高间隔 * 5 / 数据个数)
End If
obj.ForeColor = 0
obj.CurrentX = k2 + 150 'k2 为左角
obj.CurrentY = j
obj.Print DD.指标(i)
Next i
End Sub
Public Sub 画图例折(obj As Object, 上边距 As Long, 下边距 As Long, 左边距 As Long, 右边距 As Long, Max As Double, DD As 数据画图类型, COL() As Long)
On Error Resume Next
Dim i As Long, j As Long
Dim k1 As Long, k2 As Long, k3 As Long, k4 As Long, k5 As Long
Dim strtmp As String
Dim s1() As String
'-----------数据个数----------------
Dim 数据个数 As Long
数据个数 = UBound(DD.指标())
Dim 样本数 As Long
样本数 = UBound(DD.单位) + 1
Dim Y坐标间隔(10) As Long
Dim X坐标间隔() As Long
'---------计算坐标数据-----------
ReDim X坐标间隔(样本数)
Dim 有效高 As Long
Dim 高间隔 As Long
有效高 = obj.ScaleHeight - 上边距 - 下边距 - 标题高 - 边距
高间隔 = (有效高) / 10
Dim 有效宽 As Long
Dim 宽间隔 As Long
有效宽 = obj.ScaleWidth - 左边距 - 右边距 - 边距 '边距是用来标Y坐标的
宽间隔 = (有效宽 - 图例宽 - 150) / (样本数 + 1)
For i = 0 To 10
Y坐标间隔(i) = i * 高间隔
Next i
For i = 0 To 样本数
X坐标间隔(i) = i * 宽间隔
Next i
k5 = 上边距 + 标题高
'图例
'图例,双线框
obj.ForeColor = 0
k3 = 左边距 + 有效宽 + 边距 '右角
k2 = k3 - 图例宽 '左角
obj.Line (k2, k5)-(k3, k5 + 有效高), , B
obj.Line (k2 + 30, k5 + 30)-(k3 - 30, k5 + 有效高 - 30), , B
strtmp = "图 例"
obj.FontSize = 12
obj.CurrentX = k3 - (图例宽 + obj.TextWidth(strtmp)) / 2 'K3 是右角
obj.CurrentY = k5 + 高间隔
obj.Print strtmp
obj.FontSize = 9
obj.DrawWidth = 2
For i = 0 To 数据个数
If 数据个数 = 0 Then
j = k5 + 高间隔 * 4.5 + obj.TextHeight(" ") / 2
Else
j = k5 + 高间隔 * 3 + i * (高间隔 * 5 / 数据个数) + obj.TextHeight(" ") / 2
End If
obj.Line ((k3 - 图例宽 / 2 + 150), j)-(k3 - 150, j), COL(i), BF 'k3 为右角
obj.ForeColor = COL(i)
obj.CurrentX = (k3 - 图例宽 / 2 + k3) / 2 - obj.TextWidth(" ") / 2
obj.CurrentY = j - obj.TextHeight(" ") / 2
obj.Print 折线图标(i)
If 数据个数 = 0 Then
j = k5 + 高间隔 * 4.5
Else
j = k5 + 高间隔 * 3 + i * (高间隔 * 5 / 数据个数)
End If
obj.ForeColor = 0
obj.CurrentX = k2 + 150 'k2 为左角
obj.CurrentY = j
obj.Print DD.指标(i)
Next i
End Sub