Excel-VBA-质量问题可视化管理-19-修改问题

系统：Windows 10
软件：Excel 2016

• 本系列是假设一种应用场景，键盘质量检查中，发现问题，如何在键盘图片上进行标记和后续的跟踪管理。其实也同样适用在其它应用场景，尤其与位置相关的质量特性管理上

Part 1： 项目功能介绍

1. 之前介绍了基于单形状问题表征的一系列操作
2. 接下来讲讲基于多形状的问题表征，只介绍以下核心4大功能
   • 增，定义问题，采用多圆形来表征
   • 删，删除一个问题
   • 改，基于问题号修改问题
   • 查，基于问题号查询问题，今天介绍一下

Part 2： 修改

1. 若对于已经定义的问题，需要对其进行修改，包括圆点的位置、颜色、圆中的数字
2. 为了本功能可以实现，需要对之前查询问题新增一个功能，及时更新形状的名称

图1 动图

查询部分新增代码

shapeName = newShape.Name
sht.Cells(i, "P") = shapeName

查询完整代码

Sub 查询问题()
    Set sht = ThisWorkbook.Worksheets("问题管理")
    problemID = sht.Range("B15")
    
    ' 问题
    maxRow = sht.Cells(Rows.Count, "N").End(xlUp).Row
    
    For i = 3 To maxRow Step 1
        existsID = sht.Cells(i, "N")
        If existsID = problemID Then
                positionX = sht.Cells(i, "Q")
                positionY = sht.Cells(i, "R")
                widthVal = sht.Cells(i, "S")
                heightVal = sht.Cells(i, "T")
                fillColorRGB = sht.Cells(i, "U")
                lineColorRGB = sht.Cells(i, "V")
                middleTxt = sht.Cells(i, "W")
                
                Set newShape = sht.Shapes.AddShape(msoShapeOval, positionX, positionY, widthVal, heightVal)
                newShape.TextFrame2.TextRange.Characters.Text = middleTxt
                
                shapeName = newShape.Name
                sht.Cells(i, "P") = shapeName
                
                ' 文字居中
                newShape.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
                newShape.TextFrame2.VerticalAnchor = msoAnchorMiddle
                newShape.TextFrame2.TextRange.Font.Size = 6
                
                With newShape.Fill
                    .Visible = msoTrue
                    .ForeColor.RGB = fillColorRGB
                    .Transparency = 0
                    .Solid
                End With
                
                With newShape.Line
                    .Visible = msoTrue
                    .ForeColor.RGB = lineColorRGB
                    .Transparency = 0
                End With
                
        End If
    Next

    
End Sub

Part 3： 代码逻辑

1. 对拟查询问题的ID去数据库遍历
2. 获取每一个构成形状的名称
3. 根据名称获取该形状对象
4. 获取其所有需要属性：位置，颜色，文本内容
5. 将获取得到的属性重新写入数据库

Part 4： 代码

Sub 修改问题_不删点()
    Set sht = ThisWorkbook.Worksheets("问题管理")
    problemID = sht.Range("B15")
    
    ' 问题
    maxRow = sht.Cells(Rows.Count, "N").End(xlUp).Row
    
    For i = 3 To maxRow Step 1
        existsID = sht.Cells(i, "N")
        If existsID = problemID Then
                shapeName = sht.Cells(i, "P")
                Set newShape = sht.Shapes.Range(Array(shapeName))
                
                positionX = newShape.Left
                positionY = newShape.Top
                widthVal = newShape.Width
                heightVal = newShape.Height
                
                lineColorRGB = newShape.Line.ForeColor.RGB
                fillColorRGB = newShape.Fill.ForeColor.RGB
                middleTxt = newShape.TextFrame2.TextRange.Characters.Text
                
                inputRow = i
                sht.Cells(inputRow, "Q").Value = positionX
                sht.Cells(inputRow, "R").Value = positionY
                sht.Cells(inputRow, "S").Value = widthVal
                sht.Cells(inputRow, "T").Value = heightVal
                sht.Cells(inputRow, "U").Value = fillColorRGB
                sht.Cells(inputRow, "V").Value = lineColorRGB
                sht.Cells(inputRow, "W").Value = middleTxt
                
        End If
    Next

    
End Sub

代码截图

Part 5：部分代码解读

1. Set newShape = sht.Shapes.Range(Array(shapeName))通过形状的名称获取该形状对象

---

• 更多学习交流，可加小编微信号learningBin

---

更多精彩，请关注微信公众号
扫描二维码，关注本公众号