|
楼主 |
发表于 2018-9-1 12:58
|
显示全部楼层
这是 三坛老窖 大师的代码,只不过因为数据源来自于封装的模块内(过程调用),不知道如何改为本工作表数据调用,无从对接修改相关参数,代码太高深看不懂,可供参考,期望老师能就类似本表的数据格式实现一个通用模块:
- ' ===============================================================================
- ' 模块名称: 输出
- '
- Option Explicit
- ' ********************************************************************************
- ' 模块常数声明
- ' ********************************************************************************
- Private Const msMODULE As String = "OutputOptScheme"
- ' 3 WorkOrder 输出工单
- ' 5 TestShape 测试Shape存在与否
- ' 6 CreateShape 创建Shape
- ' ================================================================================
- ' 功能:输出最优方案的加工单
- '
- ' 描述:从myODC中提取最优方案数据,据此生成带图形的加工单
- '
- ' 参数:Sh -- 工作表对象
- ' myODC -- 一维下料对象
- '
- ' 返回:加工单(到方案文件中)
- '
- ' 备注:本过程由输出方案过程(OutpuScheme)调用
- ' ================================================================================
- Private Sub WorkOrder(Sh As Worksheet, myODC As Object)
- Dim rng As Range
- Dim shpPart As Shape
- Dim i As Long, j As Long, k As Long, s As String, CutLoss As Long, ModeCount As Long
- Dim PartTotalLenght As Long '零件总长度
- Dim rule As Double
- Dim shpLeft As Double, shpTop As Double
- Dim MaxLenght As Double
- Dim ShapeLenght As Double
- Dim ShapeHeight As Double
- Dim RangeHeight As Double
- Dim arr, arrM, arrP, temp1, temp2
-
- '从myODC中提取数据
- With myODC
- arr = .WorkOrderData: arrP = .PartData: arrM = .MaterialData: CutLoss = .CutWidth: ModeCount = .ModeCount
- End With
-
- '获取最长的棒料长度(用于计算图形比例)
- For i = LBound(arrM) To UBound(arrM)
- If arrM(i, 1) > MaxLenght And arrM(i, 4) Then MaxLenght = arrM(i, 1)
- Next i
-
- '输出数据及图形到工作表
- With Sh
-
- '输出数据
- .Range("CutWidth") = CutLoss
- .Range("Date") = Date
-
- With .Range("ModeNo")
- If ModeCount > 1 Then .Offset(1).Resize(ModeCount - 1).EntireRow.Insert
- .Resize(ModeCount, 7) = arr
- .Offset(ModeCount, 1).Resize(1, 6).FormulaR1C1 = _
- "=SUMPRODUCT(R[-" & ModeCount & "]C:R[-1]C,R[-" & ModeCount & "]C" & .Column + 2 & ":R[-1]C" & .Column + 2 & ")"
- .Offset(ModeCount, 2).FormulaR1C1 = "=SUM(R[-" & ModeCount & "]C:R[-1]C)"
- End With
-
- '检测Shape是否存在,若不存在则将被创建
- TestShape .Range("ModeNo").Offset(, 3)
-
- ShapeLenght = .Shapes("M").Width
- ShapeHeight = .Shapes("M").Height
- RangeHeight = .Range("ModeNo").Height
-
- '长度变换比例
- rule = ShapeLenght / MaxLenght
-
- '在工作表相应单元格中输出下料模式示图和字符串
- For i = 1 To ModeCount
- shpLeft = .Range("ModeNo").Offset(, 3).Left
- shpTop = .Range("ModeNo").Offset(i - 1).Top + RangeHeight * 3 / 4 - ShapeHeight / 2
- temp1 = Split(arr(i, 4), "+")
- For j = 0 To UBound(temp1)
- temp2 = Split(temp1(j), "*")
- PartTotalLenght = PartTotalLenght + temp2(0) * temp2(1) * arr(i, 3)
- For k = 1 To temp2(1)
- Set shpPart = .Shapes("M").Duplicate
- With shpPart
- .Name = "P" & temp2(0)
- .Left = shpLeft
- .Top = shpTop
- .Width = temp2(0) * rule
- End With
- shpLeft = shpLeft + (temp2(0) + CutLoss) * rule
- Next k
- Next j
- '输出料头示图
- If arr(i, 5) > 0 Then
- Set shpPart = .Shapes("T").Duplicate
- With shpPart
- .Name = "T" & arr(i, 5)
- .Left = shpLeft: shpPart.Top = shpTop
- .Width = arr(i, 5) * rule
- End With
- End If
- Next i
-
- '删除多余的形状
- .Shapes.Range("M").Delete
- .Shapes.Range("T").Delete
- .Range("ModeNo").Offset(ModeCount, 3) = PartTotalLenght
- End With
-
- End Sub
- ' ================================================================================
- ' 功能:检测母形状是否存在,若不存在则创建母形状
- '
- ' 描述:采用形状复制方法(Shape.Duplicate)检测母形状是否存在,如果不存在,则调用
- ' 创建形状子程序(CreateShape)创建母形状,否则删除复制品
- '
- ' 参数:rng -- 单元格对象,用于计算形状位置和尺寸
- '
- ' 返回:none
- '
- ' 备注:本过程由生成加工单过程(WorkOrder)调用
- ' ================================================================================
- Private Sub TestShape(rng As Range)
- Dim shp As Shape
- On Error Resume Next
-
- Set shp = ActiveSheet.Shapes("M").Duplicate
- If Err.Number Then
- With rng
- CreateShape "M", "", .Left, .Top, .Width - 5, .Height * 3 / 10, vbYellow, vbRed
- End With
- Else
- shp.Delete
- End If
-
- Err.Clear
-
- Set shp = ActiveSheet.Shapes("T").Duplicate
- If Err.Number Then
- Set shp = ActiveSheet.Shapes("M").Duplicate
- shp.Name = "T"
- shp.Fill.ForeColor.RGB = vbBlue
- Else
- shp.Delete
- End If
-
- End Sub
- ' ================================================================================
- ' 功能:创建形状(矩形)
- '
- ' 描述:按输入参数创建形状(Shape)
- '
- ' 参数:1、shpName -- 形状名
- ' 2、shpText -- 形状文本
- ' 3、intLeft -- 左边位置
- ' 4、intTop -- 顶部位置
- ' 5、intWidth -- 宽度
- ' 6、intHeight --高度
- ' 7、FillColor -- 形状填充色
- ' 8、LineColor -- 形状外框线颜色
- '
- ' 返回:Shape
- '
- ' 备注:本过程由母形状检测过程(TestShape)调用
- ' ================================================================================
- Private Function CreateShape(ByVal shpName As String, _
- ByVal shpText As String, _
- ByVal intLeft As Double, _
- ByVal intTop As Double, _
- ByVal intWidth As Double, _
- ByVal intHeight As Double, _
- Optional ByVal FillColor As Long, _
- Optional ByVal LineColor As Long) As Shape
-
- Dim shp As Shape
-
- Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, intLeft, intTop, intWidth, intHeight)
-
- With shp
- .Name = shpName
- .Fill.ForeColor.RGB = FillColor
- .Line.Weight = 1
- .Line.ForeColor.RGB = LineColor
- .TextFrame.Characters.Font.ColorIndex = 1
- .TextFrame2.TextRange.Characters.Text = shpText
- End With
-
- Set CreateShape = shp
- End Function
复制代码 |
|