Board logo

标题: [技术讨论] vbs控制excel对象实现文字特效实例 [打印本页]

作者: batman    时间: 2011-6-4 02:27     标题: vbs控制excel对象实现文字特效实例

本帖最后由 batman 于 2011-6-5 15:00 编辑
  1. Dim fso, vbstr, hang
  2. Set fso = CreateObject("scripting.filesystemobject")
  3. For Each str In Split(fso.OpenTextFile(WScript.ScriptName).readall(), vbCrLf)
  4.   If Left(str, 1) = "'" Then vbstr = vbstr & Mid(str, 2, Len(str)) & vbCrLf
  5.   Next
  6. Set fso = Nothing
  7. Dim oexcel, orange, htxt, ltxt
  8. Set oexcel = CreateObject("excel.application")
  9. oexcel.Visible = True
  10. oexcel.Workbooks.Add
  11. oexcel.DisplayFullScreen = True
  12. oexcel.CommandBars(1).Enabled = False
  13. Set orange = oexcel.Range("a1", "az50")
  14. orange.Font.Name = "楷体_gb2312"
  15. orange.Font.Size = 20
  16. orange.Interior.ColorIndex = 1
  17. orange.Font.ColorIndex = 2
  18. orange.Font.Bold = True
  19. orange.ColumnWidth = 5
  20. For Each htxt In Split(vbstr, vbCrLf)
  21.   i = i + 1
  22.   For j = 1 To Len(htxt)
  23.     oexcel.Cells(i+4, j+5).value = Mid(htxt, j, 1)
  24.     WScript.Sleep 200
  25.   Next
  26. Next
  27. WScript.Sleep 2000
  28. oExcel.ActiveWorkbook.Saved = True
  29. oexcel.Workbooks.Close
  30. oexcel.Quit
  31. Set ws = Nothing
  32. Set oexcel = Nothing
  33. '      将进酒-李白
  34. '
  35. '君不见黄河之水天上来,奔流到海不复回。
  36. '君不见高堂明镜悲白发,朝如青丝暮成雪。
  37. '人生得意须尽欢,莫使金樽空对月。
  38. '天生我材必有用,千金散尽还复来。
  39. '烹羊宰牛且为乐,会须一饮三百杯。
  40. '岑夫子,丹丘生,将进酒,杯莫停。
  41. '与君歌一曲,  请君为我倾耳听:
  42. '钟鼓馔玉不足贵,但愿长醉不复醒。
  43. '古来圣贤皆寂寞,唯有饮者留其名。
  44. '陈王昔时宴平乐,斗酒十千恣欢谑。
  45. '主人何为言少钱,径须沽取对君酌。
  46. '五花马,千金裘,呼儿将出换美酒,
  47. '与尔同销万古愁。
复制代码

作者: 523066680    时间: 2011-6-4 10:25

本帖最后由 523066680 于 2011-6-4 10:28 编辑

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

作者: 523066680    时间: 2011-6-4 16:25

本帖最后由 523066680 于 2011-6-4 16:33 编辑

不知道我有没有绕弯路

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依次代表不同的浓度)
  1. msgbox ColorRGB(8,8,0)     '红+绿 = 黄
  2. function ColorRGB(Cr,Cg,Cb)
  3. dim R,G,B,str,num,i
  4. 'Cr,Cg,Cb range [0,8]
  5. R=string(Cr,"1") & string((8-Cr),"0")
  6. G=string(Cg,"1") & string((8-Cg),"0")
  7. B=string(Cb,"1") & string((8-Cb),"0")
  8. str=R & G & B
  9. num=0
  10. for i = 1 to 24
  11. num=num+(mid(str,i,1)*2)^(i-1)
  12. next
  13. ColorRGB=num
  14. end function
复制代码
尝试写了一个过渡的填充颜色,每个颜色只有8个阶,而且实际还有几个颜色接近黑色,不绚丽啊。

作者: batman    时间: 2011-6-5 01:30

本帖最后由 batman 于 2011-6-5 03:53 编辑

说明:
    本特效加上了对文本显示居中的控制以及文本行超出屏幕时的下拉条控制,同时可以自行修改字体、大小、颜色、列宽以及逐显速度(改延时)来取得不同的显示效果,同时可将文本替换为自己想要显示的其他文本,但请注意在每行前加上“'”字符,否则vbs会报错。主要参数修改在这一行:size = 30 : width = 7 : hadd = 2 : color1 = 51 : color2 = 24 : zt = "楷体_gb2312",但注意字体大小最好不要超过30,列宽最好设置在3-7之间,字体要选择office所支持的字体。
  1. Dim fso, vbstr, hang, lie, arr, code, str, var
  2. 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", " ")
  3. For Each str In arr
  4.   For Each var In arr
  5.     code = code & str & var
  6.   Next
  7. Next
  8. 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
  9. Set fso = CreateObject("scripting.filesystemobject")
  10. arr = Split(fso.OpenTextFile(WScript.ScriptName).readall(), vbCrLf)
  11. Set fso = Nothing
  12. For Each str In arr 'for循环取得文本总行数及最长行的字符数
  13.   If Left(str, 1) = "'" Then
  14.     vbstr = vbstr & Mid(str, 2, Len(str)) & vbCrLf
  15.     hang = hang + 1
  16.     If lie < Len(str) - 1 Then lie = Len(str) - 1
  17.   End If
  18. Next
  19. Dim oexcel, orange
  20. Set oexcel = CreateObject("excel.application")
  21. oexcel.Visible = True
  22. oexcel.Workbooks.Add
  23. fullscreen '设置excel全屏显示,要取消请改为endfullscreen
  24. Dim width, mwidth, mheight, hadd, ladd, color1, color2, zt, size, dnum, lnum
  25. size = 20: width = 5 : hadd = 2 : color1 = 51 : color2 = 24 : zt = "楷体_gb2312" '定义字体、大小、列宽、颜色等的值
  26. mheight = CreateObject("HtmlFile").ParentWindow.Screen.Availheight '取得屏幕总高度值
  27. mwidth = CreateObject("HtmlFile").ParentWindow.Screen.Availwidth '取得屏幕总宽度值
  28. dnum = Int(mheight/size/1.813) - 2*hadd '计算下拉条控件运行的初始行数值,其中的1.813是个人测算出的字体大小单位值相对于屏高的值
  29. lnum = Int(mwidth/8.944/width) '计算屏幕显示区域的总列数,其中的8.944是个人测算列宽单位值相对于屏高的值
  30. ladd = Int((lnum-lie)/2)
  31. Set orange = oexcel.Range("a1", Mid(code, lnum*2-1, 2)& hang + 4*hadd) '设置显示区域
  32. orange.Font.Name = zt '设置显示区域字体
  33. orange.Font.Size = size '设置显示区域字体大小
  34. orange.Interior.ColorIndex = color1 '设置显示区域背景色
  35. orange.Font.ColorIndex = color2 '设置显示区域字体颜色
  36. orange.Font.Bold = True '设置显示区域字体加粗
  37. orange.ColumnWidth = width '设置显示区域列宽
  38. Set orange = Nothing
  39. Dim htxt
  40. For Each htxt In Split(vbstr, vbCrLf)
  41.   i = i + 1
  42.   If i > dnum Then
  43.     k = k + 1 : l = k + hadd
  44.     oexcel.Rows(l).value = ""
  45.     oexcel.ActiveWindow.SmallScroll 1
  46.   End If
  47.   For j = 1 To Len(htxt)
  48.     oexcel.Cells(i+hadd, j+ladd).value = Mid(htxt, j, 1)
  49.     WScript.Sleep 200
  50.   Next
  51. Next
  52. WScript.Sleep 2000
  53. oExcel.ActiveWorkbook.Saved = True
  54. oexcel.Workbooks.Close
  55. oexcel.Quit
  56. Set oexcel = Nothing
  57. Function fullscreen
  58.   With oexcel
  59.    .DisplayFullScreen = True
  60.    .CommandBars(1).Enabled = False
  61.    .CommandBars("full screen").Controls(1).OnAction = "取消全屏显示"
  62.    With .ActiveWindow
  63.     .DisplayHeadings = False
  64.     .DisplayHorizontalScrollBar = False
  65.     .DisplayVerticalScrollBar = False
  66.     .DisplayWorkbookTabs = False
  67.    End With
  68.   End With
  69. End Function
  70. Function endfullscreen
  71.   With oexcel
  72.    .DisplayFullScreen = False
  73.    .CommandBars(1).Enabled = True
  74.    .CommandBars("full screen").reset
  75.    With .ActiveWindow
  76.     .DisplayHeadings = True
  77.     .DisplayHorizontalScrollBar = True
  78.     .DisplayVerticalScrollBar = True
  79.     .DisplayWorkbookTabs = True
  80.    End With
  81.   End With
  82. End Function
  83. '      长情-佚名
  84. '
  85. '我的思念就像夕阳下的影子越来越长,
  86. '直到无法在留住那模糊的记忆,
  87. '才收敛起那颗早已破碎的心,
  88. '拾起满地散落的忧伤,
  89. '回到堆满思绪的小屋。
  90. '把忧伤,把思念化成一粒粒墙角静静的微尘,
  91. '在没有人来的时候,
  92. '不去碰触她。
  93. '
  94. '我的思念就像灯火阑珊下的影子好长好长,
  95. '慢慢延伸到窗外那颗充满沧桑的老树下。
  96. '寂寞的老树是孤独的。
  97. '我愿爬上树梢,
  98. '做它最顶端的一片叶子。
  99. '柔柔的风是孤独的,
  100. '任由它吹起我的思念。
  101. '满院的月光似水柔情,
  102. '那一颗颗晶莹的星,
  103. '是我散满天空对你的期望。
  104. '很多时候,
  105. '我都是这样想你。
  106. '你就像一杯浓浓的奶茶,
  107. '真想停住苍茫的脚步,
  108. '闭起双眼静静的品尝那淡淡的清香。
  109. '
  110. '很多时候,
  111. '我把自己分割成一个个小段。
  112. '让每一个小段都有一份思念,
  113. '那样不会聚集一个更大的思念也就不会受伤。
  114. '小小的思念是一种幸福,
  115. '是一种相思的美。
  116. '如果可以,
  117. '我会把自己分割成千百万个小段,
  118. '好让我的思念追随你飘荡的衣襟。
  119. '清幽的小河,
  120. '泛起如雪的白浪。
  121. '把心折成一只小船,
  122. '放逐在最顶端的浪花。
  123. '如果还有机会,
  124. '在我还没被吞没的时候,
  125. '为你在写下一首诗。
  126. '那一段段缭绕的文字,
  127. '会慢慢的沉入水底,
  128. '直到消失。
  129. '而我的思念却越来越深。
  130. '
  131. '轻轻地推开冰封已久的心门,
  132. '让那散落满地的灰尘,
  133. '在那个狭小空间里晒晒太阳。
  134. '拿起扫把清扫一片寂寞,
  135. '小屋豁然开朗。
  136. '想你在瞬间化作万只彩蝶翩翩起舞。
  137. '你会莫名的心动吗?
  138. '那是我思念的手臂在触摸你。
  139. '我把遥远的思念化成一个个想你的点,
  140. '再用心底最美的一束光串联。
  141. '离你越远我的点就越多,
  142. '我心里的光会随着点的增加而无限延长。
  143. '想你了,
  144. '我用串联的点捎去我的思念。
  145. '黑夜里,
  146. '我用那束光为你照亮回家的路。
  147. '点慢慢的增加,
  148. '而那束光也在延长。
  149. '直到有一天你拉住我点的那头,
  150. '我会小心的拽住点的这头。
  151. '让你顺着我编织的梦,
  152. '不再醒。
复制代码

作者: batman    时间: 2011-6-5 01:59

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




欢迎光临 批处理之家 (http://bbs.bathome.net/) Powered by Discuz! 7.2