|
|
楼主 |
发表于 2018-10-19 09:19
|
显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
大师，你好，现在我进行了一些调整，代码如下：
- Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
- Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
- Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
- Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
- Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
- Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
- Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BitMapInfo, ByVal wUsage As Long) As Long
- Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BitMapInfo, ByVal wUsage As Long) As Long
- Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
- Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
- Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
- Private Declare Function CreatePatternBrush Lib "gdi32" (ByVal hBitmap As Long) As Long
- Private Declare Function FillRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
- Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
- Private Const DIB_RGB_COLORS = 0 ' color table in RGBs
- Private Type BitMapInfoHeader
- biSize As Long
- biWidth As Long
- biHeight As Long
- biPlanes As Integer
- biBitCount As Integer
- biCompression As Long
- biSizeImage As Long
- biXPelsPerMeter As Long
- biYPelsPerMeter As Long
- biClrUsed As Long
- biClrImportant As Long
- End Type
- Private Type RGBQuad
- rgbBlue As Byte
- rgbGreen As Byte
- rgbRed As Byte
- ''rgbReserved As Byte
- End Type
- Private Type BitMapInfo
- bmiHeader As BitMapInfoHeader
- bmiColors As RGBQuad
- End Type
- Private Type GUID
- Data1 As Long
- Data2 As Integer
- Data3 As Integer
- Data4(7) As Byte
- End Type
- Private Type PicBmp
- Size As Long
- Type As Long
- hBmp As Long
- hPal As Long
- Reserved As Long
- End Type
- Private Const HIMETRIC_PER_PIXEL = 96 / 2540
- Private Const vbPicTypeBitmap = 1
- Private Enum EnumPicMode
- BlackWhite = 0
- GrayScale = 1
- 浮雕 = 2
- 负片 = 3
- 油画 = 4
- 木刻 = 5
- End Enum
- Private Sub CommandButton1_Click() '灰度
- hwnd& = FindWindow(vbNullString, "UserForm1")
- hdc = GetDC(hwnd)
- Rgn1 = CreateRectRgn(0, 0, 400, 400)
- Brush1 = CreatePatternBrush(Convert(LoadPicture("d:\psu1.jpg"), GrayScale))
- FillRgn hdc, Rgn1, Brush1
- DeleteObject Brush1
- End Sub
- Private Function Convert(PicSrc As StdPicture, ToMode As EnumPicMode, Optional bytThreshold As Byte = 128) As StdPicture
- Dim ix As Integer
- Dim iy As Integer
- Dim iWidth As Integer '以像素为单位的图形宽度
- Dim iHeight As Integer '以像素为单位的图形高度
- Dim bytTarget As Byte
- Dim hdc As Long, hDCmem As Long
- Dim hBmp As Long, hBmpPrev As Long
-
- Dim bits() As Byte '三维数组，用于获取原彩色图像中各像素的RGB数值以及存放转化后的灰度值
-
- Dim bitsBW() '三维数组，用于存放转化为黑白图后各像素的值
-
- '获取图形的宽度和高度
- iWidth = PicSrc.Width * HIMETRIC_PER_PIXEL
- iHeight = PicSrc.Height * HIMETRIC_PER_PIXEL
-
- '创建并初始化一个bitMapInfo自定义类型
- Dim bi24BitInfo As BitMapInfo
- With bi24BitInfo.bmiHeader
- .biBitCount = 32
- .biCompression = 0&
- .biPlanes = 1
- .biSize = Len(bi24BitInfo.bmiHeader)
- .biWidth = iWidth
- .biHeight = iHeight
- End With
- '重新定义数组大小
- ReDim bits(0 To 3, 0 To iWidth - 1, 0 To iHeight - 1) As Byte
- ReDim bitsBW(0 To 3, 0 To iWidth - 1, 0 To iHeight - 1)
- hdc = GetDC(0)
- hDCmem = CreateCompatibleDC(hdc)
- '使用GetDIBits方法一次性获取picture1中各点的rgb值，比point方法或getPixel函数逐像素获取像素rgb要快出一个数量级
- lrtn = GetDIBits(hDCmem, PicSrc.Handle, 0&, iHeight, bits(0, 0, 0), bi24BitInfo, DIB_RGB_COLORS)
- '数组的三个维度分别代表像素的RGB分量、以图形左下角为原点的X和Y坐标。
- '具体说来，这时bits(0,2,3)代表从图形左下角数起横向第2个纵向第3个像素的Blue值，而bits(1,2,3)和bits(2,2,3)分别的Green值和Red值.
-
- Select Case ToMode
- Case GrayScale '***********RGB转为灰度******
- ascii_char = "$@B%8&WM#*oahkbdpqwmZO0QLCJUYXzcvunxrjft/\|()1{}[]?-_+~<>i!lI;:,\^`'. "
- pLength = Len(ascii_char)
- unit = (256# + 1) / pLength
- For ix = 0 To iWidth - 1
- For iy = 0 To iHeight - 1
- 'Debug.Print bits(0, ix, iy), bits(1, ix, iy), bits(2, ix, iy)
- bytTarget = bits(0, ix, iy) * 0.11 + bits(1, ix, iy) * 0.59 + bits(2, ix, iy) * 0.3 '这是传统的根据三原色亮度加权得到灰阶的算法
- ascii_char = Int(bytTarget / unit)
- bitsBW(0, ix, iy) = Mid(ascii_char, Int(bytTarget / unit) + 1, 1)
- bitsBW(1, ix, iy) = Mid(ascii_char, Int(bytTarget / unit) + 1, 1)
- bitsBW(2, ix, iy) = bytTarget
- Next
- Next
-
- End Select
-
- '************下面是从DIBits转为stdPicture的代码***************
- hBmp = CreateCompatibleBitmap(hdc, iWidth, iHeight) '创建一个与屏幕兼容的位图，得到它的句柄
- SetDIBits hDCmem, hBmp, 0, iHeight, bitsBW(0, 0, 0), bi24BitInfo, DIB_RGB_COLORS '将DIBits信息放入hBmp中
- DeleteDC hDCmem
- ReleaseDC 0, hdc
-
- '从hBmp得到stdPicture的标准方法
- Dim r As Long
- Dim pic As PicBmp
- Dim IPic As StdPicture
- Dim IID_IDispatch As GUID
- '填充IDispatch界面，clsID为{00020400-0000-0000-C000-000000000046}
- With IID_IDispatch
- .Data1 = &H20400
- .Data4(0) = &HC0
- .Data4(7) = &H46
- End With
- '填充Pic结构
- With pic
- .Size = Len(pic) 'pic结构的大小
- .Type = vbPicTypeBitmap '图形类型, Bitmap
- .hBmp = hBmp '位图句柄
- .hPal = 0 '因为是24位色，所以不需要设定Pallete
- End With
- '建立Picture对象
- r = OleCreatePictureIndirect(pic, IID_IDispatch, 1, IPic)
- '返回Picture对象
- Set Convert = IPic
- End Function
图像有起色，得到图像如图，还是有问题，都是竖的线，好像是1237-129行的mid的数值有问题，请帮我改改看。 |
-
|
楼主: dongdonggege
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2018-10-17 16:27
