[技术讨论] vbs控制excel对象实现文字特效实例

batman

Dim fso, vbstr, hang
Set fso = CreateObject("scripting.filesystemobject")
For Each str In Split(fso.OpenTextFile(WScript.ScriptName).readall(), vbCrLf)
  If Left(str, 1) = "'" Then vbstr = vbstr & Mid(str, 2, Len(str)) & vbCrLf
  Next
Set fso = Nothing
Dim oexcel, orange, htxt, ltxt
Set oexcel = CreateObject("excel.application")
oexcel.Visible = True
oexcel.Workbooks.Add
oexcel.DisplayFullScreen = True
oexcel.CommandBars(1).Enabled = False
Set orange = oexcel.Range("a1", "az50")
orange.Font.Name = "楷体_gb2312"
orange.Font.Size = 20
orange.Interior.ColorIndex = 1
orange.Font.ColorIndex = 2
orange.Font.Bold = True
orange.ColumnWidth = 5
For Each htxt In Split(vbstr, vbCrLf)
  i = i + 1
  For j = 1 To Len(htxt)
    oexcel.Cells(i+4, j+5).value = Mid(htxt, j, 1)
    WScript.Sleep 200
  Next
Next
WScript.Sleep 2000
oExcel.ActiveWorkbook.Saved = True
oexcel.Workbooks.Close
oexcel.Quit
Set ws = Nothing
Set oexcel = Nothing

'      将进酒-李白
'
'君不见黄河之水天上来，奔流到海不复回。
'君不见高堂明镜悲白发，朝如青丝暮成雪。
'人生得意须尽欢，莫使金樽空对月。
'天生我材必有用，千金散尽还复来。
'烹羊宰牛且为乐，会须一饮三百杯。
'岑夫子,丹丘生，将进酒，杯莫停。
'与君歌一曲，  请君为我倾耳听：
'钟鼓馔玉不足贵，但愿长醉不复醒。
'古来圣贤皆寂寞，唯有饮者留其名。
'陈王昔时宴平乐，斗酒十千恣欢谑。
'主人何为言少钱，径须沽取对君酌。
'五花马，千金裘，呼儿将出换美酒，
'与尔同销万古愁。
复制代码

523066680

打开看了一下，很友好背景和字体。

523066680

不知道我有没有绕弯路

Excel中的颜色值是通过索引值设置的，
如果是通过 R,G,B 三个值设置颜色成分，则比较方便自己调配颜色。
经过几个颜色的尝试，找出了索引值与RGB值之间的规律
分三段(二进制)
例如  0000000,00000000,11111111 代表填满的红色
其最终值=255    （B,G,R）

以下代码通过 R,G,B 的值得到索引值
R,G,B的传值范围是 0 到 8 （整数哈,0,1,2,3,4,5,6,7,8依次代表不同的浓度）

msgbox ColorRGB(8,8,0)     '红+绿 = 黄

function ColorRGB(Cr,Cg,Cb)
	dim R,G,B,str,num,i
	'Cr,Cg,Cb range [0,8]
	R=string(Cr,"1") & string((8-Cr),"0")
	G=string(Cg,"1") & string((8-Cg),"0")
	B=string(Cb,"1") & string((8-Cb),"0")
	str=R & G & B
	num=0
	for i = 1 to 24
		num=num+(mid(str,i,1)*2)^(i-1)
	next
	ColorRGB=num
end function
复制代码

尝试写了一个过渡的填充颜色，每个颜色只有8个阶，而且实际还有几个颜色接近黑色，不绚丽啊。

batman

说明：
    本特效加上了对文本显示居中的控制以及文本行超出屏幕时的下拉条控制，同时可以自行修改字体、大小、颜色、列宽以及逐显速度（改延时）来取得不同的显示效果，同时可将文本替换为自己想要显示的其他文本，但请注意在每行前加上“'”字符，否则vbs会报错。主要参数修改在这一行：size = 30 : width = 7 : hadd = 2 : color1 = 51 : color2 = 24 : zt = "楷体_gb2312"，但注意字体大小最好不要超过30，列宽最好设置在3-7之间，字体要选择office所支持的字体。

Dim fso, vbstr, hang, lie, arr, code, str, var
arr = split("a b c d e f g h i j k l m n o p q r s t u v w x y z", " ")
For Each str In arr
  For Each var In arr
    code = code & str & var
  Next
Next
code = " a b c d e f g h i j k l m n o p q r s t u v w x y z" & code
Set fso = CreateObject("scripting.filesystemobject")
arr = Split(fso.OpenTextFile(WScript.ScriptName).readall(), vbCrLf)
Set fso = Nothing
For Each str In arr 'for循环取得文本总行数及最长行的字符数
  If Left(str, 1) = "'" Then 
    vbstr = vbstr & Mid(str, 2, Len(str)) & vbCrLf
    hang = hang + 1
    If lie < Len(str) - 1 Then lie = Len(str) - 1
  End If
Next
Dim oexcel, orange
Set oexcel = CreateObject("excel.application")
oexcel.Visible = True
oexcel.Workbooks.Add
fullscreen '设置excel全屏显示,要取消请改为endfullscreen
Dim width, mwidth, mheight, hadd, ladd, color1, color2, zt, size, dnum, lnum
size = 20: width = 5 : hadd = 2 : color1 = 51 : color2 = 24 : zt = "楷体_gb2312" '定义字体、大小、列宽、颜色等的值
mheight = CreateObject("HtmlFile").ParentWindow.Screen.Availheight '取得屏幕总高度值
mwidth = CreateObject("HtmlFile").ParentWindow.Screen.Availwidth '取得屏幕总宽度值
dnum = Int(mheight/size/1.813) - 2*hadd '计算下拉条控件运行的初始行数值，其中的1.813是个人测算出的字体大小单位值相对于屏高的值
lnum = Int(mwidth/8.944/width) '计算屏幕显示区域的总列数，其中的8.944是个人测算列宽单位值相对于屏高的值
ladd = Int((lnum-lie)/2)
Set orange = oexcel.Range("a1", Mid(code, lnum*2-1, 2)& hang + 4*hadd) '设置显示区域
orange.Font.Name = zt '设置显示区域字体
orange.Font.Size = size '设置显示区域字体大小
orange.Interior.ColorIndex = color1 '设置显示区域背景色
orange.Font.ColorIndex = color2 '设置显示区域字体颜色
orange.Font.Bold = True '设置显示区域字体加粗
orange.ColumnWidth = width '设置显示区域列宽
Set orange = Nothing
Dim htxt
For Each htxt In Split(vbstr, vbCrLf)
  i = i + 1
  If i > dnum Then
    k = k + 1 : l = k + hadd
    oexcel.Rows(l).value = ""
    oexcel.ActiveWindow.SmallScroll 1
  End If 
  For j = 1 To Len(htxt)
    oexcel.Cells(i+hadd, j+ladd).value = Mid(htxt, j, 1)
    WScript.Sleep 200
  Next
Next
WScript.Sleep 2000
oExcel.ActiveWorkbook.Saved = True
oexcel.Workbooks.Close
oexcel.Quit
Set oexcel = Nothing

Function fullscreen
  With oexcel
   .DisplayFullScreen = True
   .CommandBars(1).Enabled = False
   .CommandBars("full screen").Controls(1).OnAction = "取消全屏显示"
   With .ActiveWindow
    .DisplayHeadings = False
    .DisplayHorizontalScrollBar = False
    .DisplayVerticalScrollBar = False
    .DisplayWorkbookTabs = False
   End With
  End With
End Function 

Function endfullscreen
  With oexcel
   .DisplayFullScreen = False 
   .CommandBars(1).Enabled = True
   .CommandBars("full screen").reset
   With .ActiveWindow
    .DisplayHeadings = True
    .DisplayHorizontalScrollBar = True 
    .DisplayVerticalScrollBar = True 
    .DisplayWorkbookTabs = True
   End With
  End With
End Function

'      长情-佚名
'
'我的思念就像夕阳下的影子越来越长，
'直到无法在留住那模糊的记忆，
'才收敛起那颗早已破碎的心，
'拾起满地散落的忧伤，
'回到堆满思绪的小屋。
'把忧伤，把思念化成一粒粒墙角静静的微尘，
'在没有人来的时候，
'不去碰触她。
'
'我的思念就像灯火阑珊下的影子好长好长，
'慢慢延伸到窗外那颗充满沧桑的老树下。
'寂寞的老树是孤独的。
'我愿爬上树梢，
'做它最顶端的一片叶子。
'柔柔的风是孤独的，
'任由它吹起我的思念。
'满院的月光似水柔情，
'那一颗颗晶莹的星，
'是我散满天空对你的期望。
'很多时候，
'我都是这样想你。
'你就像一杯浓浓的奶茶，
'真想停住苍茫的脚步，
'闭起双眼静静的品尝那淡淡的清香。
'
'很多时候，
'我把自己分割成一个个小段。
'让每一个小段都有一份思念，
'那样不会聚集一个更大的思念也就不会受伤。
'小小的思念是一种幸福，
'是一种相思的美。
'如果可以，
'我会把自己分割成千百万个小段，
'好让我的思念追随你飘荡的衣襟。
'清幽的小河，
'泛起如雪的白浪。
'把心折成一只小船，
'放逐在最顶端的浪花。
'如果还有机会，
'在我还没被吞没的时候，
'为你在写下一首诗。
'那一段段缭绕的文字，
'会慢慢的沉入水底，
'直到消失。
'而我的思念却越来越深。
'
'轻轻地推开冰封已久的心门，
'让那散落满地的灰尘，
'在那个狭小空间里晒晒太阳。
'拿起扫把清扫一片寂寞，
'小屋豁然开朗。
'想你在瞬间化作万只彩蝶翩翩起舞。
'你会莫名的心动吗？
'那是我思念的手臂在触摸你。
'我把遥远的思念化成一个个想你的点，
'再用心底最美的一束光串联。
'离你越远我的点就越多，
'我心里的光会随着点的增加而无限延长。
'想你了，
'我用串联的点捎去我的思念。
'黑夜里，
'我用那束光为你照亮回家的路。
'点慢慢的增加，
'而那束光也在延长。
'直到有一天你拉住我点的那头，
'我会小心的拽住点的这头。
'让你顺着我编织的梦，
'不再醒。
复制代码

batman

3# 523066680
自己编写颜色配比函数是很好，但在对颜色变化要求不大的特效中，个人还是喜欢手工调试。。。