51Testing软件测试论坛

 找回密码
 (注-册)加入51Testing

QQ登录

只需一步,快速开始

微信登录,快人一步

手机号码,快捷登录

查看: 2813|回复: 1
打印 上一主题 下一主题

[资料] VBS读取图片像素 WIA 组件

[复制链接]

该用户从未签到

跳转到指定楼层
1#
发表于 2013-6-27 22:50:00 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
在浏览自己系统里带有的COM组件时,看到了WIA.ImageFile.1 这个网上查了下,了解到这个组件可以对图片做些处理。具体能做些图片格式转换,像素处理,剪切之类的工作。这个组件Win7应该是自带的。

我用他写了个宏,将图片转换为Excel单元格拼接的马赛克图片。下面是代码。图片最好256色的。

  1. Public Const scrHeight = 435
  2. Public Const scrWidth = 124
  3. Public Const RC = 8
  4. Public objBMPData, objScreen, Screen
  5. Public bitRowCount, bitColCount, allLine
  6. Public bits()

  7. Sub LoadingPicture()
  8. '' 初始化显示屏幕
  9. Call ReadBMPData
  10. Call SetConfig
  11. Call ClearScreen
  12. Call RefreshScreen
  13. End Sub


  14. Sub ReadBMPData()
  15.     Dim file
  16.     Set dlgOpen = Application.FileDialog(3)
  17.     If dlgOpen.Show = -1 Then
  18.         file = dlgOpen.SelectedItems(1)
  19.     Else
  20.         End
  21.     End If
  22.    
  23.     Set pic = CreateObject("WIA.ImageFile.1")
  24.     pic.LoadFile file
  25.     bitColCount = pic.Width
  26.     bitRowCount = pic.Height
  27.     bitDepth = pic.PixelDepth
  28.     Set cl = pic.ARGBData
  29.     ReDim bits(bitRowCount, bitColCount)
  30.     Index = 1
  31.     For i = 0 To bitRowCount - 1
  32.         For j = 0 To bitColCount - 1
  33.             bits(i, j) = cl.Item(Index)
  34.             Index = Index + 1
  35.         Next
  36.     Next
  37. End Sub

  38. Sub SetConfig()
  39.     Set Screen = Sheets("屏幕")
  40.     Set objScreen = Screen.Range("A2").Resize(bitRowCount, bitColCount)
  41.     Screen.Cells.ColumnWidth = scrWidth / bitColCount
  42.     Screen.Range("2:50000").RowHeight = scrWidth * RC / bitColCount
  43. End Sub

  44. Sub RefreshScreen()
  45.     Application.ScreenUpdating = False
  46.     For i = 0 To bitRowCount - 1
  47.         For j = 0 To bitColCount - 1
  48.             objScreen.Cells(i + 1, j + 1).Interior.Color = bits(i, j)
  49.         Next
  50.     Next
  51.     Application.ScreenUpdating = True
  52. End Sub

  53. Sub ClearScreen()
  54.     Screen.Cells.Clear
  55. End Sub
复制代码

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有帐号?(注-册)加入51Testing

x
分享到:  QQ好友和群QQ好友和群 QQ空间QQ空间 腾讯微博腾讯微博 腾讯朋友腾讯朋友
收藏收藏
回复

使用道具 举报

  • TA的每日心情
    擦汗
    14 小时前
  • 签到天数: 1042 天

    连续签到: 4 天

    [LV.10]测试总司令

    2#
    发表于 2013-6-28 09:59:51 | 只看该作者
    支持下~
    回复 支持 反对

    使用道具 举报

    本版积分规则

    关闭

    站长推荐上一条 /1 下一条

    小黑屋|手机版|Archiver|51Testing软件测试网 ( 沪ICP备05003035号 关于我们

    GMT+8, 2024-11-7 23:37 , Processed in 0.070473 second(s), 28 queries .

    Powered by Discuz! X3.2

    © 2001-2024 Comsenz Inc.

    快速回复 返回顶部 返回列表