Excel-VBA-质量问题可视化管理-16-保存1个问题

Coding的巴扎黑

于 2021-11-12 21:14:33 发布

阅读量548

点赞数

分类专栏： VBA-Excel 文章标签： Excel VBA AddShape

本文链接：https://blog.csdn.net/zishendianxia/article/details/121294979

版权

VBA-Excel 专栏收录该内容

39 篇文章 7 订阅

订阅专栏

系统：Windows 10
软件：Excel 2016

本系列是假设一种应用场景，键盘质量检查中，发现问题，如何在键盘图片上进行标记和后续的跟踪管理。其实也同样适用在其它应用场景，尤其与位置相关的质量特性管理上
本文拟实现对新增问题对应形状的位置、颜色保存
核心知识点为用多形状表示问题

Part 1：项目功能介绍

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

Part 2：拟实现功能描述

上一篇文章实现了新增问题，但是遗留了一个任务，新建的问题，构成问题的圆形形状经过人工移动，需要记录下来
另外就是整个版面做了一些修改，界面也做了一些优化，只剩下增删改查四步操作

版面如下
请添加图片描述

动图
请添加图片描述

Part 3：代码

新增问题
和上一篇文章一样，只是获取ID的位置变动了一下

Sub 新增问题2()
    Set sht = ThisWorkbook.Worksheets("问题管理")
    problemID = sht.Range("B15")
    
    flag = 0
    If problemID = "" Then
        flag = 1
        problemID = "P-" & getUniqueId()
        
        ' 把新增的问题ID写入
        sht.Range("B15") = problemID
        
        ' 写入问题库
        inputRow2 = sht.Cells(Rows.Count, "J").End(xlUp).Row + 1
        sht.Cells(inputRow2, "J") = problemID
         
    End If
    
    ' 获取行数
    maxRow = sht.Cells(Rows.Count, "O").End(xlUp).Row
    inputRow = maxRow + 1
    middleTxt = CStr(inputRow - 2)
    
    widthVal = 20
    heightVal = 20
    positionX = sht.Range("B22").Left
    positionY = sht.Range("B22").Top
    
    Set newShape = sht.Shapes.AddShape(msoShapeOval, positionX, positionY, widthVal, heightVal)
    newShape.TextFrame2.TextRange.Characters.Text = middleTxt
    
    ' 文字居中
    newShape.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
    newShape.TextFrame2.VerticalAnchor = msoAnchorMiddle
    
    shapeName = newShape.Name
    
    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
    
    shapeID = "S-" & getUniqueId()

    
    ' 获取颜色十进制表示
    fillColorRGB = newShape.Fill.ForeColor.RGB
    lineColorRGB = newShape.Line.ForeColor.RGB
    
    ' 写入表格
    sht.Cells(inputRow, "N").Value = problemID
    sht.Cells(inputRow, "O").Value = shapeID
    sht.Cells(inputRow, "P").Value = shapeName
    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 Sub

保存位置

Sub 保存问题()
    Set sht = ThisWorkbook.Worksheets("问题管理")
    
    problemID = sht.Range("B15")

    If problemID = "" Then
        MsgBox "无问题需要保存"
        Exit Sub
    End If
    
    ' 获取行数
    maxRow = sht.Cells(Rows.Count, "N").End(xlUp).Row
    
    For i = 3 To maxRow Step 1
        problemIDi = sht.Cells(i, "N").Value
        
        If problemID = problemIDi Then
            shapeName = sht.Cells(i, "P").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
            
            sht.Cells(i, "Q").Value = positionX
            sht.Cells(i, "R").Value = positionY
            sht.Cells(i, "S").Value = widthVal
            sht.Cells(i, "T").Value = heightVal
            sht.Cells(i, "U").Value = fillColorRGB
            sht.Cells(i, "V").Value = lineColorRGB
        
        End If
    Next

End Sub