6-质量问题可视化管理

6.1-项目介绍

6.2-项目架构

6.2.1-系统组成

6.2.2-代码逻辑

6.3-新增问题

6.3.1-唯一ID号生成

6.3.2-新增形状

6.3.3-保存形状

6.4-显示问题

6.5-删除问题

6.6-查询问题

6.7-超期问题

6.8-问题交互

6.9-其它

6.10-本章小结

6.1-项目介绍

引言

本章依然采用一个项目的方式，介绍新的知识点。其实整体代码层面和前面的章节都是类似的，本章介绍的简单一点，具体细节可以仔细看看代码。

本章介绍的知识点如下：

插入形状

删除某个形状

形状颜色变更

查询形状

快捷键插入，与选择形状进行交互

本示例是一种质量可视化应用场景，假设键盘质量检查中，发现问题，如何在键盘图片上进行标记和后续的跟踪管理。假设有两种质量问题，一种是尺寸问题，用圆圈表示；一种是颜色问题，用矩形表示。红色表示问题未解决，绿色表示问题已解决。

核心功能包括：

1）问题的录入

2）问题的删除

3）问题的查询，多条件查询，超期问题统计展示

4）图片上选中单个问题点，通过快捷键，快速显示所选问题的信息

图6-1 示意图（背景键盘只是示意，与实际产品无关）

6.2.1-系统组成

整个系统可以分成三大区域：

• 1）产品示意图，包括图片，以及问题在图片上的显示，如图6-1

• 2）操作区，一些操作按钮，如图6-1

• 3）数据库，问题的细节信息记录地区，如图6-2，包括以下信息：

• 3.1）问题ID号，唯一表示一个问题

• 3.2）问题种类，区分是颜色问题，还是尺寸问题

• 3.3）问题状态，已解决，未解决

• 3.4）时间节点，用于判断未解决问题当前是否超期

• 3.5）图形内置变量名称：对于每个图形，内部的变量名称，方便操作

• 3.6）X/Y，表示问题的圆形或矩形在Excel中的位置

• 3.7）宽度/高度，表示问题的圆形或矩形的几何信息，通过这两个参数，加上形状信息，可以复现该图形

• 3.8）填充色RGB，问题的填充色，在这里考虑便利性，未采用RGB三个值来表征颜色

• 3.9）轮廓色RGB，问题的轮廓颜色

---

图6-2 数据库区域

6.2.2-代码逻辑

整个系统各功能模块相对独立，将其划分为6个模块，并加上了工作簿启动事件，如图6-3所示，下文会逐一介绍，本章采用按照业务逻辑去解读，不再采用之前章节的按Sub和Function一个个介绍。

---

图6-3 代码结构

6.3-新增问题

6.3.1-唯一ID号生成

6.3.2-新增形状

6.3.3-保存形状

6.3.1-唯一ID号生成

引言

本系统支持两种问题的标记，一种是尺寸，一种是颜色，分别用圆形和矩形表示。问题的位置事先是不知道的，所以默认将形状生成在固定位置，然后通过人工移动到需要位置，再将最新的位置保存即可。同时为了方便问题的管理，每个问题有一个唯一的ID号，是通过定义问题那一时刻的时间来生成的。

唯一ID号生成

代码如下

Function getUniqueId()

    currentTime = Now()

    uniqueId = Application.Text(currentTime, "yy-mm-dd hh:mm:ss")

    uniqueId2 = Application.Substitute(uniqueId, "-", "")

    uniqueId3 = Application.Substitute(uniqueId2, ":", "")

    uniqueId4 = Application.Substitute(uniqueId3, " ", "")

    getUniqueId = "id-" & CStr(uniqueId4)

    Debug.Print (uniqueId4)

End Function

通过查看本地窗口中各变量的取值，如图6-4所示，可以知道每个函数的作用。一步步将时间转换为一个字符串，去除其中的符号和空格，只保留纯数字。

1）Now()获取当前的时间

2）Application.Text将时间数据类型转换为固定格式的字符串

3）Application.Substitute进行字符串替换

4）Cstr将数值型转换为字符串型

6.3.2-新增形状

对于尺寸问题或者颜色问题，区别不大，只是形状不同而已，所以核心代码几乎一致。主要功能是生成对应的形状，并将该形状的基础信息写入数据库，包括位置、大小、颜色等信息

代码如下

Sub 新增尺寸问题()

    Set sht = ThisWorkbook.Worksheets("问题管理")

    positionX = sht.Range("B22").Left

    positionY = sht.Range("B22").Top

    widthVal = 12

    heightVal = 12

    Set newShape = sht.Shapes.AddShape(msoShapeOval, positionX, positionY, widthVal, heightVal)

    shapeName = newShape.Name

    Debug.Print (shapeName)

    With newShape.Fill

        .Visible = msoTrue

        .ForeColor.RGB = RGB(255, 0, 0)

        .Transparency = 0

        .Solid

    End With

    With newShape.Line

        .Visible = msoTrue

        .ForeColor.RGB = RGB(255, 0, 0)

        .Transparency = 0

    End With

    ' 获取行数

    maxRow = sht.Cells(Rows.Count, "Q").End(xlUp).Row

    inputRow = maxRow + 1

    ' 获取颜色十进制表示

    fillColorRGB = newShape.Fill.ForeColor.RGB

    lineColorRGB = newShape.Line.ForeColor.RGB

    ' 写入表格

    sht.Cells(inputRow, "Q").Value = shapeName

    sht.Cells(inputRow, "R").Value = positionX

    sht.Cells(inputRow, "S").Value = positionY

    sht.Cells(inputRow, "T").Value = widthVal

    sht.Cells(inputRow, "U").Value = heightVal

    sht.Cells(inputRow, "V").Value = fillColorRGB

    sht.Cells(inputRow, "W").Value = lineColorRGB

    sht.Cells(inputRow, "J").Value = getUniqueId()

    sht.Cells(inputRow, "K").Value = "尺寸"

    sht.Cells(inputRow, "L").Value = "未解决"

    ' 清空之前的标记，增加新标记

    sht.Range("X:X").ClearContents

    sht.Range("X2") = "标记"

    sht.Cells(inputRow, "X") = "新增点"

End Sub

Sub 新增颜色问题()

    Set sht = ThisWorkbook.Worksheets("问题管理")

    positionX = sht.Range("F22").Left

    positionY = sht.Range("F22").Top

    widthVal = 20

    heightVal = 12

    Set newShape = sht.Shapes.AddShape(msoShapeRectangle, positionX, positionY, widthVal, heightVal)

    shapeName = newShape.Name

    Debug.Print (shapeName)

    With newShape.Fill

        .Visible = msoTrue

        .ForeColor.RGB = RGB(255, 0, 0)

        .Transparency = 0

        .Solid

    End With

    With newShape.Line

        .Visible = msoTrue

        .ForeColor.RGB = RGB(255, 0, 0)

        .Transparency = 0

    End With

    ' 获取行数

    maxRow = sht.Cells(Rows.Count, "Q").End(xlUp).Row

    inputRow = maxRow + 1

    ' 获取颜色十进制表示

    fillColorRGB = newShape.Fill.ForeColor.RGB

    lineColorRGB = newShape.Line.ForeColor.RGB

    ' 写入表格

    sht.Cells(inputRow, "Q").Value = shapeName

    sht.Cells(inputRow, "R").Value = positionX

    sht.Cells(inputRow, "S").Value = positionY

    sht.Cells(inputRow, "T").Value = widthVal

    sht.Cells(inputRow, "U").Value = heightVal

    sht.Cells(inputRow, "V").Value = fillColorRGB

    sht.Cells(inputRow, "W").Value = lineColorRGB

    sht.Cells(inputRow, "J").Value = getUniqueId()

    sht.Cells(inputRow, "K").Value = "颜色"

    sht.Cells(inputRow, "L").Value = "未解决"

    ' 清空之前的标记，增加新标记

    sht.Range("X:X").ClearContents

    sht.Range("X2") = "标记"

    sht.Cells(inputRow, "X") = "新增点"

End Sub

其中新增一个形状为以上的代码的关键核心代码，具体如下：

Set newShape = sht.Shapes.AddShape(msoShapeOval, positionX, positionY, widthVal, heightVal)

1）其中msoShapeOval为形状信息，表示圆形，如果为矩形，则为msoShapeRectangle，从单词意思上应该也可以快速理解。这两个都为VBA中自带的常量

1.1）Oval：椭圆形

1.2）Rectangle：矩形

2）positionX, positionY，为形状左上角的位置，一般通过单元格位置获取，以下表示为单元格B22的左上角位置

2.1）positionX = sht.Range(“B22”).Left

2.2）positionY = sht.Range(“B22”).Top

3）widthVal, heightVal，为形状信息，分别表示宽度和高度，以下表示为宽度和高度都为12，所以此时的椭圆形成了圆形，这个单位是多少暂未知，可以通过尝试数值，看一下所需要的具体数值

3.1）widthVal = 12

3.2）heightVal = 12

6.3.3-保存形状

默认生成的形状是在固定位置，这跟我们最终想要的位置肯定是不符的，所以此时加入了手工移动部分，为了让下次打开的时候，形状位置是移动后的位置，需要把最后的位置信息等写入数据库。

代码如下

Sub 保存问题当前位置()

    Set sht = ThisWorkbook.Worksheets("问题管理")

    ' 获取行数

    maxRow = sht.Cells(Rows.Count, "Q").End(xlUp).Row

    For i = 3 To maxRow Step 1

        shapeName = sht.Cells(i, "Q").Value

        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

        ' 更新

        inputRow = i

        sht.Cells(inputRow, "R").Value = positionX

        sht.Cells(inputRow, "S").Value = positionY

        sht.Cells(inputRow, "T").Value = widthVal

        sht.Cells(inputRow, "U").Value = heightVal

        sht.Cells(inputRow, "V").Value = fillColorRGB

        sht.Cells(inputRow, "W").Value = lineColorRGB

    Next

End Sub

从以上代码可以看出，该过程不是直接遍历当前图片上已有的形状，而是对数据库中信息进行遍历，获取每一个形状的名称，进而获取这个形状对象，如下代码。这里就会存在一个可能的Bug，就是之前未将数据库中所有的形状显示在图片上，这样就会查找不到对象，会报错。为了避免这种情况出现，一定要先显示所有问题，在下一节中会进行说明

Set newShape = sht.Shapes.Range(Array(shapeName))

获取每个形状对象后，再获取其位置大小颜色等信息，更新到数据库中。核心信息为形状的在VBA中的变量名称，所以在上一节中生成形状时需要将其内部名称保存到数据库

shapeName = newShape.Name

sht.Cells(inputRow, "Q").Value = shapeName

6.4-显示问题

显示数据库中所有已定义问题。逻辑如下：

1）对页面中所有的形状进行遍历

2）除了操作按钮和背景图片之外的所有形状全部删除。系统中自定义的按钮和插入的图片，也是属于形状元素，所以务必将这些形状进行保留

3）遍历数据库中每一行，生成对应的形状，并更新形状对应的变量名称。更新形状对应的变量名称非常重要，因为重新生成的图形对应的变量名称是由系统自动生成的，只能记下，无法修改（或者只是我还未找到）

代码如下

Function reserveShape(shapeName, shapeArray)

    result = False

    For Each ele In shapeArray

        If shapeName = ele Then

            result = True

            Exit For

        End If

    Next

    reserveShape = result

End Function

Sub delAllShape()

    Set sht = ThisWorkbook.Worksheets("问题管理")

    shapeArray = Array("Picture 20", "Button 12", "Button 13", _

    "Button 14", "Button 15", "Button 16", "Button 17", "Button 20")

    For Each sh In sht.Shapes

        shapeName = sh.Name

        reserveYn = reserveShape(shapeName, shapeArray)

        If Not reserveYn Then

            sh.Delete

        End If

    Next

End Sub

Sub showAllProblem()

    Call delAllShape

    Set sht = ThisWorkbook.Worksheets("问题管理")

    ' 获取行数

    maxRow = sht.Cells(Rows.Count, "Q").End(xlUp).Row

    For i = 3 To maxRow Step 1

        shapeName = sht.Cells(i, "Q").Value

        questionType = sht.Cells(i, "K").Value

        If questionType = "尺寸" Then

            shapeType = msoShapeOval

        Else

            shapeType = msoShapeRectangle

        End If

        positionX = sht.Cells(i, "R").Value

        positionY = sht.Cells(i, "S").Value

        widthVal = sht.Cells(i, "T").Value

        heightVal = sht.Cells(i, "U").Value

        fillColor = sht.Cells(i, "V").Value

        lineColor = sht.Cells(i, "W").Value

        Set newShape = sht.Shapes.AddShape(shapeType, positionX, positionY, widthVal, heightVal)

        shapeName = newShape.Name

        Debug.Print (shapeName)

        sht.Cells(i, "Q").Value = shapeName

        With newShape.Fill

            .Visible = msoTrue

            .ForeColor.RGB = fillColor

            .Transparency = 0

            .Solid

        End With

        With newShape.Line

            .Visible = msoTrue

            .ForeColor.RGB = lineColor

            .Transparency = 0

        End With

    Next i

End Sub

其中主过程是showAllProblem，在显示所有形状前，务必要删除原有的表征问题的形状元素，防止重复。关于需要保留的形状的变量名称获取，可以单独写一个遍历，打印出来，然后保存即可。其实选中某个形状，在Excel的左上角区域会显示出来，只不过用的是中文，如图6-5所示，插入的背景图片对应的变量名称为 图片20，对应的实际名称为Picture 20。

shapeArray = Array("Picture 20", "Button 12", "Button 13", _

    "Button 14", "Button 15", "Button 16", "Button 17", "Button 20")

图片6-5 形状对应的变量名称

6.5-删除问题

本节功能就比较简单了，根据用户输入的ID号，将数据库中对应的那一行信息删除即可，再重新显示数据库的信息，即调用上一节的过程即可。

代码如下

Sub delProblem()

    Set sht = ThisWorkbook.Worksheets("问题管理")

    questionID = sht.Range("E16")

    maxRow = sht.Cells(Rows.Count, "Q").End(xlUp).Row

    For i = 3 To maxRow Step 1

        existsID = sht.Cells(i, "J")

        If existsID = questionID Then

            sht.Range("J" & i & ":X" & i).Select

            Selection.Delete Shift:=xlUp

        End If

    Next

    Call showAllProblem

End Sub

关于删除某一行区域核心代码如下，分为两步：选中拟删除区域，执行删除。具体代码也是先录入宏，然后稍作修改即可。

            sht.Range("J" & i & ":X" & i).Select

            Selection.Delete Shift:=xlUp

6.6-查询问题

本节支持三个条件的联合查询：问题状态，问题种类，问题ID号。虽说是查询，实际上执行的逻辑也是显示问题，只不过只是显示满足要求的问题，基本逻辑如下：

1）删除所有问题

2）对数据库中所有数据进行遍历

3）满足要求的问题，将形状显示出来

代码如下

Sub 查询问题()

    Call delAllShape

    Set sht = ThisWorkbook.Worksheets("问题管理")

    problemStatus = sht.Range("H15")

    questionType = sht.Range("H16")

    uniqueId = sht.Range("H17")

    ' 获取行数

    maxRow = sht.Cells(Rows.Count, "Q").End(xlUp).Row

    For i = 3 To maxRow Step 1

        uniqueId_i = sht.Cells(i, "J").Value

        questionType_i = sht.Cells(i, "K").Value

        problemStatus_i = sht.Cells(i, "L").Value

        yn = checkCondition(uniqueId_i, questionType_i, problemStatus_i, uniqueId, questionType, problemStatus)

        If yn = True Then

            If questionType_i = "尺寸" Then

                shapeType = msoShapeOval

            Else

                shapeType = msoShapeRectangle

            End If

            positionX = sht.Cells(i, "R").Value

            positionY = sht.Cells(i, "S").Value

            widthVal = sht.Cells(i, "T").Value

            heightVal = sht.Cells(i, "U").Value

            fillColor = sht.Cells(i, "V").Value

            lineColor = sht.Cells(i, "W").Value

            Set newShape = sht.Shapes.AddShape(shapeType, positionX, positionY, widthVal, heightVal)

            shapeName = newShape.Name

            Debug.Print (shapeName)

            sht.Cells(i, "Q").Value = shapeName

            With newShape.Fill

                .Visible = msoTrue

                .ForeColor.RGB = fillColor

                .Transparency = 0

                .Solid

            End With

            With newShape.Line

                .Visible = msoTrue

                .ForeColor.RGB = lineColor

                .Transparency = 0

            End With

        End If

    Next i

End Sub

Function checkCondition(uniqueId_i, questionType_i, problemStatus_i, uniqueId, questionType, problemStatus)

    result = True

    ' 如果条件不为空，则判断与条件是否一致，任何一个条件不满足则不满足

    If uniqueId <> "" Then

        If uniqueId_i <> uniqueId Then

            result = False

        End If

    End If

    ' 如果条件不为空，则判断与条件是否一致

    If questionType <> "" Then

        If questionType_i <> questionType Then

            result = False

        End If

    End If

    ' 如果条件不为空，则判断与条件是否一致

    If problemStatus <> "" Then

        If problemStatus_i <> problemStatus Then

            result = False

        End If

    End If

    checkCondition = result

End Function

每显示一个问题，务必更新该形状对应的变量名称。在多条件联合查询中，先默认某一行满足要求，然后再逐一对每个查询条件进行判断，只要有一个不满足，则该行不满足，无需显示。

6.7-超期问题

当某个问题未解决，且对应的时间节点在查询当天之前则定义为超期问题。所以超期问题，本质上也是一个条件查询。具体方法也是对数据库中每一行进行遍历判断即可。注意，本示例中对没有填写时间节点信息的问题，不做判断。

代码如下

Sub exceedTime()

    Call delAllShape

    sizeProblem = 0

    colorProblem = 0

    currentDate = Date

    Set sht = ThisWorkbook.Worksheets("问题管理")

    ' 获取行数

    maxRow = sht.Cells(Rows.Count, "Q").End(xlUp).Row

    For i = 3 To maxRow Step 1

        problemStatus = sht.Cells(i, "L").Value

        If problemStatus = "未解决" Then

            solveDate = sht.Cells(i, "P").Value

            If solveDate <> "" Then

                solveDate = CDate(solveDate)

                If solveDate < currentDate Then

                    shapeName = sht.Cells(i, "Q").Value

                    problemType = sht.Cells(i, "K").Value

                    If problemType = "尺寸" Then

                        shapeType = msoShapeOval

                        sizeProblem = sizeProblem + 1

                    Else

                        shapeType = msoShapeRectangle

                        colorProblem = colorProblem + 1

                    End If

                    positionX = sht.Cells(i, "R").Value

                    positionY = sht.Cells(i, "S").Value

                    widthVal = sht.Cells(i, "T").Value

                    heightVal = sht.Cells(i, "U").Value

                    fillColor = sht.Cells(i, "V").Value

                    lineColor = sht.Cells(i, "W").Value

                    shapeName = drawShape(sht, shapeType, positionX, positionY, widthVal, heightVal, fillColor, lineColor)

                    sht.Cells(i, "Q").Value = shapeName

                End If

            End If

        End If

    Next i

    sht.Range("H18") = sizeProblem

    sht.Range("H19") = colorProblem

End Sub

Function drawShape(sht, shapeType, positionX, positionY, widthVal, heightVal, fillColor, lineColor)

    Set newShape = sht.Shapes.AddShape(shapeType, positionX, positionY, widthVal, heightVal)

    shapeName = newShape.Name

    Debug.Print (shapeName)

    With newShape.Fill

        .Visible = msoTrue

        .ForeColor.RGB = fillColor

        .Transparency = 0

        .Solid

    End With

    With newShape.Line

        .Visible = msoTrue

        .ForeColor.RGB = lineColor

        .Transparency = 0

    End With

    drawShape = shapeName

End Function

6.8-问题交互

选中某个图形后，使用快捷键，ctrl+m，则弹出一个窗口，显示问题的详细信息。基本逻辑是获取选择所选图形的内部变量名称，再去数据库中遍历查找，然后显示出来。

---

图6-6 问题交互

---

代码如下

Sub showInfo()

    selectedShape = Selection.Name

    Set sht = ThisWorkbook.Worksheets("问题管理")

    ' 获取行数

    maxRow = sht.Cells(Rows.Count, "Q").End(xlUp).Row

    questionType = ""

    uniqueId = ""

    questionType = ""

    problemStatus = ""

    For i = 3 To maxRow Step 1

        shapeName = sht.Cells(i, "Q").Value

        If shapeName = selectedShape Then

            uniqueId = sht.Cells(i, "J").Value

            questionType = sht.Cells(i, "K").Value

            problemStatus = sht.Cells(i, "L").Value

            rowNum = i

            Exit For

        End If

    Next i

    If uniqueId <> "" Then

        info = "已选择图形信息如下：id号，" & uniqueId & "；问题种类，" & questionType & _

        "；问题状态，" & problemStatus & Chr(10) & Chr(13) & "问题所在行：" & rowNum

    Else

        info = "未识别出所选图形，请检查是否选中图形。若检查选择无误，请联系开发者"

    End If

    MsgBox info

End Sub

这里就出现了一个问题，选中一个图形后，如果通过点击按钮去触发上面的过程，那么当前选择的图形就变成了点击的按钮了。为了解决这个问题，设置了一个快捷键，触发上面的过程。具体操作是，先选中图像，然后按下快捷键。在Thisworkbook中定义以下事件

Private Sub Workbook_Open()

    Call showAllProblem

    '创建快捷键

    Application.OnKey "^m", "F_问题交互.showInfo"

End Sub

6.9-其它

问题状态变更以后，如从已解决到未解决，或者反之，需要及时更新数据库表示颜色的信息。这里增加了一个工作簿关闭前事件，遍历数据库，根据问题状态更新对应颜色信息。

代码如下

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    Application.DisplayAlerts = False

    Call changeTheColor

End Sub

Sub changeTheColor()

    Set sht = ThisWorkbook.Worksheets("问题管理")

    ' 获取行数

    maxRow = sht.Cells(Rows.Count, "Q").End(xlUp).Row

    For i = 3 To maxRow Step 1

        problemStatus = sht.Cells(i, "L").Value

        If problemStatus = "已解决" Then

            fillColor = 5287936

            lineColor = 5287936

        Else

            fillColor = 255

            lineColor = 255

        End If

        sht.Cells(i, "V").Value = fillColor

        sht.Cells(i, "W").Value = lineColor

    Next i

    Call showAllProblem

End Sub

6.10-本章小结

本章使用一个示例展示了以下知识点，回顾一下是否都已经掌握了，如果没有，不妨回看一下：

1）图形的增删改查，显示

2）快捷键创建

3）工作簿事件