| 网站首页 | 业界新闻 | 小组 | 威客 | 人才 | 下载频道 | 博客 | 代码贴 | 在线编程 | 编程论坛
欢迎加入我们,一同切磋技术
用户名:   
 
密 码:  
共有 880 人关注过本帖
标题:可以帮忙看下我的 GETDIBITS ,SETDIBITS CODE 出现什么问题吗?
只看楼主 加入收藏
summer_mun
Rank: 1
等 级:新手上路
帖 子:1
专家分:0
注 册:2008-11-29
收藏
 问题点数:0 回复次数:0 
可以帮忙看下我的 GETDIBITS ,SETDIBITS CODE 出现什么问题吗?
Option Explicit


Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetCurrentObject Lib "gdi32" (ByVal hdc As Long, ByVal uObjectType As Long) 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 timeGetTime Lib "winmm.dll" () As Long
Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BitMapInfo, ByVal wUsage As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)

Private Type BitMapInfoHeader 'ÎļþÐÅϢͷ--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 Const Bits As Long = 32 'ÑÕÉ«Éî¶È£¬ÕâÀï°ÑËùÓÐͼÏñ¶¼°´ÕÕ32λÀ´´¦Àí
Public Done As Boolean 'ÓÃÓÚ±ê¼ÇÒ»¸ö¹ý³ÌÊÇ·ñ½áÊø
Public TimeGet As Long 'ÓÃÓڼǼÊäÈë¹ý³Ì´¦ÀíËù»¨·ÑµÄʱ¼ä
Public TimePut As Long 'ÓÃÓڼǼÊä³ö¹ý³Ì´¦ÀíËù»¨·ÑµÄʱ¼ä
Dim ColVal() As Byte 'ÓÃÓÚ´æ·Å´ÓDIBÊäÈëµÄÏñËØÖµ
Dim ColOut() As Byte 'ÓÃÓÚ´æ·ÅÏòDIBÊä³öµÄÏñËØÖµ
Dim InPutHei As Long 'ÓÃÓڼǼÊäÈëͼÏñµÄ¸ß¶È
Dim InPutWid As Long 'ÓÃÓڼǼÊäÈëͼÏñµÄ¿í¶È
Dim OutputWid As Long
Dim OutputHei As Long
Dim LineBytes As Long
Dim bi24BitInfo As BitMapInfo '¶¨ÒåBMPÐÅÏ¢




Public Sub DibGet(ByVal IdSource As Long, XBegin As Long, ByVal YBegin As Long, ByVal XEnd As Long, ByVal YEnd As Long)
  Dim iBitmap As Long
  Dim iDC As Long
  Dim I As Long
  Dim W As Long
  Dim H As Long

  On Error GoTo ErrLine
  Done = False
  TimeGet = timeGetTime
  InPutWid = XEnd - XBegin
  InPutHei = YEnd - YBegin
  W = InPutWid + 1
  H = InPutHei + 1

  I = (Bits \ 8) - 1
  ReDim ColVal(I, InPutWid, InPutHei)
  With bi24BitInfo.bmiHeader
    .biBitCount = Bits
    .biCompression = 0&
    .biPlanes = 1
    .biSize = Len(bi24BitInfo.bmiHeader)
    .biWidth = W
    .biHeight = H
  End With

  iBitmap = GetCurrentObject(IdSource, 7&)
  
GetDIBits IdSource, iBitmap, 0&, H, ColVal(0, 0, 0), bi24BitInfo, 0&
DeleteObject iBitmap

  Done = True
  TimeGet = timeGetTime - TimeGet
Exit Sub
ErrLine:
  MsgBox "´íÎóºÅ£º" & Err.Number & "£º" & Err.Description
End Sub

Public Sub DIBPut(ByVal IdDestination As Long)
  Dim W As Long
  Dim H As Long

  On Error GoTo ErrLine
  Done = False
  TimePut = timeGetTime

  W = OutputWid + 1
  H = OutputHei + 1

  With bi24BitInfo.bmiHeader
    .biWidth = W
    .biHeight = H
    LineBytes = ((W * Bits + 31) And &HFFFFFFE0) \ 8
    .biSizeImage = LineBytes * H
  End With
 
SetDIBitsToDevice IdDestination, 0, 0, W, H, 0, 0, 0, H, ColOut(0, 0, 0), bi24BitInfo, 0&

  Done = True
  TimePut = timeGetTime - TimePut
  Exit Sub
ErrLine:
  MsgBox Err.Description
End Sub
Public Sub CopyData(ByVal W As Long, ByVal H As Long)
  Dim Length As Long
  Dim I As Long
  Dim L As Long
  I = Bits \ 8
L = I - 1
  Length = (W + 1&) * (H + 1&) * I
  ReDim ColOut(L, W, H)
  CopyMemory ColOut(0, 0, 0), ColVal(0, 0, 0), Length
End Sub


 Sub Command1_Click()
With Picture1
    .ScaleMode = 3
    .BorderStyle = 0
    DibGet .hdc, 0, 0, .ScaleWidth, .ScaleHeight
  End With
  CopyData InPutHei, InPutWid
  Picture2.AutoRedraw = True
  DIBPut Picture2.hdc
  Picture2.Refresh


End Sub
图片没有显现在PictureBox2 里,这是VB6....感谢不尽了

[[it] 本帖最后由 summer_mun 于 2008-11-29 12:23 编辑 [/it]]
搜索更多相关主题的帖子: GETDIBITS SETDIBITS CODE 
2008-11-29 12:22
快速回复:可以帮忙看下我的 GETDIBITS ,SETDIBITS CODE 出现什么问题吗?
数据加载中...
 
   



关于我们 | 广告合作 | 编程中国 | 清除Cookies | TOP | 手机版

编程中国 版权所有,并保留所有权利。
Powered by Discuz, Processed in 0.022165 second(s), 9 queries.
Copyright©2004-2024, BCCN.NET, All Rights Reserved