Excel VBA 添加变化日期的水印/批量插入艺术字/形状文本框

Excel活学活用 11-22 77

前言：

现时姐妹们对“日期控件代码”大体比较关心，姐妹们都想要分析一些“日期控件代码”的相关文章。那么小编同时在网上网罗了一些关于“日期控件代码””的相关文章，希望同学们能喜欢，姐妹们一起来了解一下吧！

本文于2023年5月24日首发于本人同名公众号：Excel活学活用，更多文章案例请搜索关注！

☆本期内容概要☆

VBA插入形状文本框水印，日期随系统日期变化。批量删除水印

大家好，我是冷水泡茶，今天在EXCELHOME论坛上看到一个网友求助的贴子：

我一看，这玩意我搞过啊，在我的《财务管理系统》中，我就添加了水印的。

需求分析：

1、日期变化，我们理解为，跟随系统日期变化，即每天打开文件时，这个水印上的日期与当前系统日期一致。

2、文字固定，就是水印中除日期以外的文字不变。

3、共4个，要添加4个同样的水印。

需求分析完了，直接开干吧！

把我以前的代码复制过来改一改，初步结果是这样的（代码见第二条文章）：

然而，问题来了，人家要的水印是灰色的，怎么办呢？我又翻出了我以前搞的一个艺术字效果大全（“我是艺术字”），点删除，清除所有艺术字，点添加，添加1~48号艺术字（代码我也放到第二条）。

共有48种艺术字效果，但没有一种是符合要求的。于是就改吧，改了半天，最终发现用艺术字可能是不行的，应该用形状加文字。

于是，请教ChatGPT吧，它给的代码基本能行，但是没有倾斜（旋转），又录制了几个宏，总之，一顿骚操作以后，终于完成了，代码如下：

Sub AddWatermark()    Dim shp As Shape    Dim watermarkText As String    Dim pageHeight As Double    Dim shpWidth As Double    Dim centerTop As Double    Dim Top As Double    watermarkText = "联邦调查局联邦调查局联邦调查局" & Chr(10) & Format(Date, "YYYY-MM-DD")    Sheets("联邦").Activate    For Each shp In ActiveSheet.Shapes        If shp.Type = msoTextBox Then            shp.Delete        End If    Next    With ActiveSheet        pageHeight = 11.69 * 72        Top = 150        centerTop = Top        shpWidth = 350        For i = 1 To 4            Set shp = .Shapes.AddTextbox(msoTextOrientationHorizontal, 90, centerTop, shpWidth, 100)            With shp                .Select                With Selection                    .ShapeRange.IncrementRotation -25                    .ShapeRange.Fill.Visible = msoFalse                    .ShapeRange.Line.Visible = msoFalse                End With                .TextFrame.Characters.Text = watermarkText                .TextFrame.Characters.Font.Size = 20                .TextFrame.Characters.Font.Color = RGB(150, 150, 150)                .TextFrame.HorizontalAlignment = xlHAlignCenter                .TextFrame.VerticalAlignment = xlVAlignCenter                .TextFrame.Orientation = 1                .TextFrame.AutoSize = False                .LockAspectRatio = msoTrue                .Top = centerTop - (.Height / 2)            End With            centerTop = centerTop + shp.Height + (pageHeight - Top - shp.Height * 4) / 3        Next    End WithEnd SubPrivate Sub Workbook_Open()    Call AddWatermarkEnd Sub

代码解析：

1、首先，我们定义一个添加水印的过程，AddWaterMark

2、接着，我们定义几个变量

3、给水印文字变量watermarkText赋值：固定文字+回车+当前日期。

4、然后，我们删除已有的水印。

5、添加新的水印，选中，定义它的旋转角度-25，无填充，无边框。

6、设置文字的格式。

7、这里通过i=1 to 4循环添加，它的Top值是不断增加的，间距相等。

8、在ThisWorkBook的Open事件中，调用AddWatermark过程，每次打开文件时，删除旧水印，添加新水印。

好，今天就分享到这，欢迎点赞、留言、分享，谢谢大家，我们下期再会。

☆猜你喜欢☆

【重磅】Excel VBA 应用分享/中医诊所收费系统/Excel+ListBox版