七彩蜂窝——关于Word其他颜色的取得

守柔

前时雨雪霏霏周岁时发了个贴子http://club.excelhome.net/viewthread.php?tid=239805&px=0，讨论了关于绘图工具栏中其他填充色的取得的问题，遂有心制作一个代码，以分享之。

非常希望雨兄和更多的网友为以下代码加上注释。

tNJZkD0N.rar (15.89 KB, 下载次数: 116)

2007-5-17 06:42 上传

点击文件名下载附件
七彩蜂窝——关于Word其他颜色的取得

[此贴子已经被作者于2007-5-17 6:47:28编辑过]

守柔

'* ＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋＋
'* Created By SHOUROU@ExcelHome 2007-5-17 6:37:35
'仅测试于System: Windows NT Word: 11.0 Language: 2052
'№ 0207^The Code CopyIn [ThisDocument-ThisDocument]^'
'* －－－－－－－－－－－－－－－－－－－－－－－－－－－－－
Option Explicit
Sub GetmyColor()
'取得相当于FormatBackgroundMoreColors(Dialogs(1005))中的颜色
    Dim i As Integer, myShape As Shape, N As Byte, M As Integer, L As Integer
    Dim sinTop As Single, sinLeft As Single, myTop As Single, myLeft As Single
    Dim sinWidth As Single, sinHeight As Single, F As Integer, D As Integer
    Dim myRGB As Long, myColor As String
    '定义正六边形宽\高\初始上边距和左边距
    sinWidth = 18
    sinHeight = 15.55
    sinTop = 90
    sinLeft = 30
    'sin30=sinHeight/4
    '    Application.ScreenUpdating = False
    With ActiveDocument
        .PageSetup.Orientation = wdOrientLandscape
        For N = 1 To 13
            myTop = sinTop + (N - 1) * sinWidth - (N - 1) * sinHeight / 4
            If N < 8 Then
                L = 1
                M = 6 + N
                F = 1
            Else
                L = 20 - N
                M = 1
                F = -1
            End If
            For i = L To M Step F
                If F = 1 Then
                    myLeft = sinLeft + (i - 1) * sinHeight - (N - 1) * sinHeight / 2
                Else
                    myLeft = sinLeft + (7 - i) * sinHeight + (13 - N) * sinHeight / 2
                    '                    Debug.Print myLeft
                End If
                Set myShape = .Shapes.AddShape(msoShapeHexagon, myLeft, myTop, sinWidth, sinHeight, .Paragraphs(1).Range)
           

守柔

     With myShape
                    .IncrementRotation 90#
                    .Fill.ForeColor.RGB = VBA.RGB(0, 51, 102)
                    If D = 0 Then .SetShapesDefaultProperties
                    .Select
                    VBA.SendKeys "{TAB}", False
                    VBA.SendKeys "{RIGHT " & D & "}", False
                    VBA.SendKeys "{ENTER}", False
                    Word.CommandBars("DRAWING").Controls(15).Controls(4).Execute
                    myRGB = .Fill.ForeColor.RGB
                    myColor = myColor & "[" & GetRedValue(myRGB) & "," & GetGreenValue(myRGB) & "," & GetBlueValue(myRGB) & "]　"
                    D = D + 1
                End With
            Next
            myColor = VBA.Mid(myColor, 1, Len(myColor) - 1)
            myColor = myColor & Chr(13)
        Next
        With .Content
            .Font.Name = "Tahoma"
            .Font.Size = 7.5
            .ParagraphFormat.Space2
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
            .InsertAfter myColor
            .Paragraphs.Last.Range.Delete
            .ShapeRange.Group
            .ShapeRange.Align msoAlignCenters, True
            .ShapeRange.Align msoAlignMiddles, True
        End With
    End With
    Application.ScreenUpdating = True
End Sub
'----------------------
Function GetRedValue(Color As Long) As Integer
    GetRedValue = Color Mod 256
End Function
'----------------------

Function GetGreenValue(Color As Long) As Integer
    GetGreenValue = (Color \ 256) Mod 256
End Function
'----------------------

Function GetBlueValue(Color As Long) As Integer
    GetBlueValue = Color \ 65536
End Function
'----------------------

liujy

守柔斑竹辛苦了！谢谢守柔斑竹分享。

konggs

谢谢老大分享。

雨雪霏霏

QUOTE:

以下是引用守柔在2007-5-17 6:44:31的发言：

前时雨雪霏霏周岁时发了个贴子http://club.excelhome.net/viewthread.php?tid=239805&px=0，讨论了关于绘图工具栏中其他填充色的取得的问题，遂有心制作一个代码，以分享之。

这两天都还在想，要用VBA画出“六边形色板”实在是有点难度——某种意义上说，也是用VBA来实现Word绘图里各种图形的“超级排列组合”了，是老大的一个独特的对Word的贡献！

注意到了老大样例文档中的图形序号是从“3998”到“4124”，可见老大花的心血！

QUOTE:

以下是引用守柔在2007-5-17 6:44:31的发言：

非常希望雨兄和更多的网友为以下代码加上注释。

谢谢老大对小弟的“爱之切”与“育于无声”！话语不多，字字如浪！

小弟尽管对VBA不辨南北，但一定会努力为代码作一注释——当然，不懂的自然要扰动孔兄与众位好兄弟了！小弟先谢下！

[此贴子已经被作者于2007-5-17 8:35:12编辑过]

sylun

先收藏再学习。谢谢老大分享！

sylun

学习本帖时遇到几个问题，请赐教：

不知什么原因，程序运行到“Word.CommandBars("DRAWING").Controls(15).Controls(4).Execute”这句时会提示出错（“对象不支持该属性或方法”）。查CommandBars("DRAWING").Controls(15)原来是“墨迹绘图与书写”命令，但在word正常编辑界面好像找不到此命令，查帮助文件，好像使用该功能须要一定条件。试将其改为“Word.CommandBars("DRAWING").Controls(16).Execute”虽可以画出蜂窝，但只有第一种颜色，而不是“七彩”，插入文档的RGB值也只是第一种颜色值，而且还并发如下问题：

(1)如在VBE代码窗口运行，运行时会在光标处多次插入回车甚至字母而导致运行错误提示（虽然蜂窝可以画出）,在word编辑界面运行则无此现象，好像与sendkey语句有关；

(2)页面设置中每页行数被更改，即使预先将其设置为默认字号五号，每页26行以上，最后还是变成每页17行，致结果为2页（按五号2倍行距设置横向好像也是17行，纵向大约26行）；

(3)如选定图形对象并设定d值后单独运行如下代码，有时可以更改填充颜色，有时也不行（不能进入“其他填充颜色”设置。有时在编辑界面工具菜单从对话框运行该宏，单击宏名时不能更改颜色，而双击宏名则可以，而用Ａlt+F8调出对话框，单击都可以，不得要领），但将该代码替换原程序相应代码时均不能更改填充颜色：

Sub test()

Dim d As Integer

d = 25

VBA.SendKeys "M", False

VBA.SendKeys "%C", False

VBA.SendKeys "{RIGHT " & d & "}", False

VBA.SendKeys "{ENTER}", False

Word.CommandBars("DRAWING").Controls(16).Execute

End sub

估计应是自己对sendkey语句的理解问题。

[此贴子已经被作者于2007-5-19 17:01:31编辑过]

雨雪霏霏

呵呵，小弟抓了一番后脑勺后发给sylun兄的“瞎猜”，看来全然与老大“阳春白雪”无干呢！sylun兄此帖一发，便知sylun兄费了大力帮助小弟！小弟深谢了！也不得不向老大说一声：小弟不肖，当不了老大的厚望！容小弟蜗行数年，再来体会老大现在的“妙法”吧！

恳请老大早现法身，于祥云之上为sylun兄讲解真经，小弟地下支起三千六百耳，看看能否听得到一点雷音！

谢谢sylun兄为小弟担当！请受小弟十八碗二锅头！以后还多劳sylun兄一路牵引！

[此贴子已经被作者于2007-5-19 18:35:51编辑过]

守柔

QUOTE:

以下是引用sylun在2007-5-19 16:59:04的发言：

学习本帖时遇到几个问题，请赐教：

sylun兄很认真！

我来解释一下：

1:Word.CommandBars("DRAWING").Controls(15).Controls(4).Execute为简易用法，实际上并不是特别规范，如果用户的绘图工具栏有自定义的命令、按钮时（在第15个控件之前），则会出现错误。可以使用两种方法，比如：

Word.CommandBars("DRAWING").Controls("填充颜色(&F)").Controls("其他填充颜色(&M)...").Execute

这种方法将命令定位了（指定的命令的名称），显示，如果是英文版或者其他语言版本，还必须使用相应的名称，可见，这种方法也不是完全的。正规的，可以使用命令的ID属性来定位，ID是Word赋于每个内置命令(命令栏控件:CommandBarButton、CommandBarComboBox 和 CommandBarControl )特有的唯一索引号，ID号决定的命令的动作，自定义命令的ID号均为1。

则：

Word.CommandBars.FindControl(ID:=1051).Execute

那么，如果快速知道目标控件的ID属性呢？当然还是用上述的方法返回更快一些，Msgbox Word.CommandBars("DRAWING").Controls(15).Controls(4).ID，如果您的工具栏与我的不一致的话，可以调整一下Controls的索引号，可以通过CommandBars("DRAWING").Controls(15).Caption来知道是否正确。

2:所有原因来缘于Sendkeys方法的理解.

SendKeys方法是向当前活动窗口发送键盘消息。简单的理解一下当前窗口，那就是在活动窗口中用户唯一可以和计算机交换信息的窗口，如果我们在WORD中键入文本时，当前窗口是WORD应用程序，如果我们在WORD应用程序下，打开了“打开对话框”，则当前窗口活动窗口是“打开对话框”，就象是使用“ALT+PrintScreen Sys Rq”捕捉活动屏幕一样的。那么这个宏过程，正确的运行方式，应该将宏名指定的工具栏中，或者ALT+F8在Word应用程序窗口中运行。理论上说，在VBE窗口下，仍然可以正确运行，原因在于我们的目标活动窗口是“颜色”对话框，我能顺利的在VBE窗口下运行此宏，但由于电脑设置和配置的不同，Sendkeys发送消息的提前或者滞后，都将影响程序的正确运行。

3:关于GetmyColor过程，最关键的技术是：

Word.CommandBars.FindControl(ID:=1051).Execute

支撑它的是：

VBA.SendKeys "{TAB}", False

VBA.SendKeys "{RIGHT " & D & "}", False

VBA.SendKeys "{ENTER}", False

我非常欢喜使用Sendkeys的Wait参数，False，我总结为预置，这在我先前很多的贴子中可以搜索到。

取得七彩颜色，最核心的代码是：

With myShape

.IncrementRotation 90#

.Fill.ForeColor.RGB = VBA.RGB(0, 51, 102)

If D = 0 Then .SetShapesDefaultProperties也就是说,在绘制了一个倒正六边形后,必须给它设置一种颜色,这种颜色,是"颜色对话框"中的第一种颜色,并且,把它设置为默认图形格式,它是一种定位,VBA每次添加一个六边形后,"颜色对话框"总是定位在第一个控件上,便于后续的持续操作.

其他的两个循环,只是逻辑与数学上的判断.