水深注记采用渐变颜色的编程实现

Posted 2022-04-12 xiaokcehui

最近有个水深测量的项目，业主要求水深成果必须按照他们的样式提供，不按照海图格式提供。这种格式的主要特点是：

（1）有水深点

（2）水深注记带负号

（3）根据水深大小给水深点及注记赋值不同的颜色

很明显，此种格式比海图格式要复杂得多。海图格式一般只要求水深注记是大小数，无需水深点且注记是单色。

由于时间仓促，且博主时间也比较紧张，就没有编程实现。同事们是通过手动实现的，具体也不是很复杂。

首先利用CAD的绘制点程序，批量绘制水深点，将水深值赋值给点的Z属性，然后设置点格式的样式。然后，利用博主自编文字绘制程序，将水深注记写入CAD中，并将水深值赋值给文字的Z属性。最后，利用CAD快速选择工具，按照预先设置的水深色标，对水深点和水深注记赋色。虽然采用的是阶梯状的色标 即一个水深范围对应一个颜色，但是结果也是很漂亮的。

事后，博主百度搜索了一下这个问题，网络上没有很多相关的信息，似乎只有CASS系统提供这个功能，说明用渐变色给注记上色用得不是很多。但是如何  用程序绘制调色板的程序则比较多。接下来，博主将以绘制调色板为基础实现根据水深值对水深点及注记上色的功能。

具体的功能实现分二步：

第一步：设置好水深最小值和水深最大值的颜色

第二步：匹配水深值范围与颜色范围，根据单个水深值计算其对应颜色。

具体界面如下:

生成的修改如下：

        颜色显示不如手动调色好看，但是渐变的效果比手动强。由于使用第一个命令“字符串导入（完整字符串）”，且整数水深没有小数位，上图中的小空白形成的细线即等深线。

       换一个颜色试试。

      

      效果如下：

      

     看来颜色显示效果确实不如手动调色好看，那就在中间再加一个颜色。

      

     效果如下：

     

      这个效果就很不错了。

      给水深赋颜色的最主要的代码是根据水深获取对应的颜色，博主下面贴出这个VBA函数的代码。

Private Sub GetColorByDepth(depth1 As Double, dMinDepth As Double, dMaxDepth As Double, ByRef nRGB() As Long)

Dim r As Long, g As Long, b As Long
Dim r1 As Long, g1 As Long, b1 As Long
Dim r2 As Long, g2 As Long, b2 As Long

Dim r3 As Long, g3 As Long, b3 As Long
Dim dCenter As Double

r = Val(TextBox1.Text)
g = Val(TextBox2.Text)
b = Val(TextBox3.Text)

r1 = Val(TextBox4.Text)
g1 = Val(TextBox5.Text)
b1 = Val(TextBox6.Text)

r2 = Val(TextBox7.Text)
g2 = Val(TextBox8.Text)
b2 = Val(TextBox9.Text)

dCenter = dMinDepth + 0.5 * (dMaxDepth - dMinDepth)

If depth1 < dCenter Then

r3 = CLng(r + (r1 - r) * (depth1 - dMinDepth) / (dCenter - dMinDepth))
g3 = CLng(g + (g1 - g) * (depth1 - dMinDepth) / (dCenter - dMinDepth))
b3 = CLng(b + (b1 - b) * (depth1 - dMinDepth) / (dCenter - dMinDepth))

Else
r3 = CLng(r1 + (r2 - r1) * (depth1 - dCenter) / (dMaxDepth - dCenter))
g3 = CLng(g1 + (g2 - g1) * (depth1 - dCenter) / (dMaxDepth - dCenter))
b3 = CLng(b1 + (b2 - b1) * (depth1 - dCenter) / (dMaxDepth - dCenter))

End If


'根据水深值计算匹配的颜色值

nRGB(0) = r3
nRGB(1) = g3
nRGB(2) = b3

End Sub