[接龙...]部分程序代码注释，目录更新20051222

drm · 发表于 2005-10-6 19:35

正想學習太詳細了感謝Long_III 大大啦

wsqlg · 发表于 2005-10-6 21:39

太感谢了。Long_III 。

麦兜兜 · 发表于 2005-10-7 23:00

好贴子别沉了

顶起来

大保 · 发表于 2005-10-8 22:23

大家辛苦了,向你们致敬!

嗲玲 · 发表于 2005-10-10 09:16

以下是引用Long_III在2005-8-5 15:12:38的发言：
我的意思是大家都来这样做，plxmm，你也弄两个上来啊

2、第二个，关于工资表的表头增减，代码有点长，就直接在后面注释了，不复制代码了

没啊？在哪？为什么看不见的呢？[em04]

水榭听涛 · 发表于 2005-10-10 15:12

给龙3申请加威望！！！！！

棒到无以复加的地步了。

zw1028 · 发表于 2005-10-10 16:55

强力要求给龙3老师加精！

lsss1111 · 发表于 2005-10-10 19:07

太棒了,这主意太好了.谢谢楼主

Long_III · 发表于 2005-10-12 12:44

52、删除多余的图形。在操作中，经常会出现隐形的小文本框，产生的原因不明，如果你打开一个表需要1分钟以上，就得考虑这些框框了，按Ctrl+G》定位条件》对象，确定，按tab键查看

下面的代码中还处理了一个问题，就是几个矩形框叠在一起时，取最上面的一个矩形框，请看代码（单独附件中所示的格式） gqAxPNfK.rar (71.46 KB, 下载次数: 123)

Private Sub CommandButton1_Click() Dim sht As Worksheet Dim p As Shape, o%, k%, k1% Dim m As Long, aa As Double aa = Timer '记录当前时间 Application.ScreenUpdating = False '关闭屏幕更新，加快代码运行 For Each sht In Sheets '在每个表里循环 o = 0: k = 0: k1 = 0 '初始化值 If sht.Name <> Me.Name Then '假如表的名称不等于总表的话 For Each p In sht.Shapes '在所有图形里循环 Select Case Left(p.Name, 3) '取图形前3个字符 Case "Pic" '表示图片类型，如果等于图片 o = o + 1: If o > 1 Then p.Delete: m = m + 1 '则保留一个，其他删除，对应A1单元格里的标志 Case "Tex" '如果等于文本框，隐形的那种，很烦躁的，直接删除 p.Delete: m = m + 1 Case "Lin" '如果等于直线，直接删除 p.Delete: m = m + 1 Case "Rec" '如果等于矩形，就是表里有文字的东东，要保留最上面的一个，用k记录总个数 k = k + 1 End Select Next For Each p In sht.Shapes '再次循环，删除除最后一个的其他矩形 If Left(p.Name, 3) = "Rec" Then k1 = k1 + 1 '如果它不是最后一个，就删除 If k1 < k Then p.Delete: m = m + 1 End If Next End If Next Application.ScreenUpdating = True MsgBox "共删除shape" & m & "个，耗时：＝" & Format(Timer - aa, "0.00") & "秒" End Sub

Long_III · 发表于 2005-10-13 12:34

53、设置图形的颜色与单元格颜色一致。通过转换颜色成GRB格式做的， 91rCrrLu.rar (37.66 KB, 下载次数: 142)

，代码：

Private Sub CommandButton1_Click() Dim R%, G%, B% Dim p As Shape Dim rng As Range For Each p In Me.Shapes '在图形里做一个循环 If InStr(1, p.Name, "Freeform") Then '假设图形名称里保护Freeform时（任意多边形） Set rng = Range("i:i").Find(p.AlternativeText, lookat:=xlWhole) '查找任意多边形的web选项里的值，是否在I列有 If Not rng Is Nothing Then '如果找到的话，则 Set_RGB rng.Offset(0, 3).Interior.Color, R, G, B '直接用列表框里的颜色值做，好像不可以，只好转换成RGB格式的了 p.Fill.ForeColor.RGB = RGB(R, G, B) '自选图形的前景色，可以用列表里颜色对应的值，也可以用RGB格式的颜色值 End If End If Next End Sub

Sub Set_RGB(ByVal myColor As Long, ByRef R%, ByRef G%, ByRef B%) '转换子过程，把长整型的转为RGB格式的数据 R = myColor Mod 256 G = myColor \ 256 Mod 256 '这样固定的东西可以直接引用，我也是down的别人的 B = myColor \ 256 \ 256 End Sub

【附】本例好像可以不用RGB来转换，直接可以这样赋值p.Fill.ForeColor.RGB = rng.Offset(0, 3).Interior.Color就可以了

[此贴子已经被作者于2005-10-20 8:55:43编辑过]

		自动登录	找回密码
密码			免费注册