Picture中绘制的图像(手工绘的,Bitblt绘的,GDI+绘的都行),不经保存,如何直接从内存转化为一个Picture对象(StdPicture)?

[SYSSZ]

Picture中绘制的图像(手工绘的,Bitblt绘的,GDI+绘的都行),不经保存,如何直接从内存转化为一个Picture对象(StdPicture)?
顶贴有分.

[LotusDNCS]

贴出你的代码

[孤独剑_LPZ]

不敢妄加评论，顶

[SYSSZ]

[Quote=引用 5 楼 lotus3318 的回复:]
贴出你的代码
[/Quote]
这不要代码,你随便怎么就能测试,你弄个Picture1用Line方法画条线行吧?

[神马都能聊]

不会， 帮老张顶。

[SYSSZ]

你弄个Picture1用Line方法画条线,你保存,它就是一张图片,可用于其它地方,现在问题不保存能否转化为Picture对象用于其它地方,省去保存这一步,这对处理很多图片的程序很有意义.

[SYSSZ]

如果你从路径加载一张图片Picture1.Picture.Handle是个长整数,但你画的Picture1.Picture.Handle=0,保存后再加载Picture1.Picture.Handle又是个长整数.

[ltpao]

Picture是加载的原始图形接口，画图后需用Image属性输出，还有一点要注意AutoRedraw要设置为True，不然图像保存不了

[ltpao]

Picture就是这样，我以为楼主要保存窗口图像

[chinaboyzyq]

先帮你顶,我再去看看有办法吗~~~~~~~

[SYSSZ]

[Quote=引用 12 楼 ltpao 的回复:]
Picture就是这样，我以为楼主要保存窗口图像
[/Quote]
你想,图像在这里,保存在它就一个图片,你用LoadPicture方法就将它加载到内存
Dim a as stdpicture
set a=LoadPicture("xxxxxxx"),它又跑到内存中去了,
现在为何不直接来?Picture1到a?

[SYSSZ]

VB是用GDI或GDI+绘图的,这时的状态相当于Graphics,也就是图已绘到画布上了,但它还不是一个图片对象.保存过程使Graphics对象变成了一张图片,在保存过程中VB做了什么?

[ltpao]

stdpicture是VB支持的对象，LoadPicture和SavePicture完成了BITMAP和stdpicture转换的过程

[SYSSZ]

[Quote=引用 16 楼 ltpao 的回复:]
stdpicture是VB支持的对象，LoadPicture和SavePicture完成了BITMAP和stdpicture转换的过程
[/Quote]
我赞同你的说法,但这一过程可否在内存中完成,不再保存个文件出来?

[ltpao]

可以的，我有代码

[ltpao]

Attribute VB_Name = "modPicArray"
' Global Memory Flags
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40

Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)

Private Declare Function GlobalAlloc Lib "kernel32" ( _
ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long

Private Declare Function GlobalSize Lib "kernel32" ( _
ByVal hMem As Long) As Long

Private Declare Function GlobalLock Lib "kernel32" ( _
ByVal hMem As Long) As Long

Private Declare Function GlobalUnlock Lib "kernel32" ( _
ByVal hMem As Long) As Long

Const PictureID = &H746C&

Private Type PictureHeader
Magic As Long
Size As Long
End Type

Public Sub Picture2Array(ByVal oObj As StdPicture, aBytes() As Byte)
Dim oIPS As IPersistStream
Dim oStream As IStream
Dim hGlobal As Long
Dim lPtr As Long
Dim lSize As Long
Dim Hdr As PictureHeader

' Get the IPersistStream interface
Set oIPS = oObj

' Create a IStream object
' on global memory
Set oStream = CreateStreamOnHGlobal(0, True)

' Save the picture in the stream
oIPS.Save oStream, True

' Get the global memory handle
' from the stream
hGlobal = GetHGlobalFromStream(oStream)

' Get the memory size
lSize = GlobalSize(hGlobal)

' Get a pointer to the memory
lPtr = GlobalLock(hGlobal)

If lPtr Then

lSize = lSize - Len(Hdr)

' Redim the array
ReDim aBytes(0 To lSize - 1)

' Copy the data to the array
MoveMemory aBytes(0), ByVal lPtr + Len(Hdr), lSize

End If

' Release the pointer
GlobalUnlock hGlobal

' Release the IStream object
Set oStream = Nothing

End Sub

Public Function Array2Picture(aBytes() As Byte) As StdPicture
Dim oIPS As IPersistStream
Dim oStream As IStream
Dim hGlobal As Long
Dim lPtr As Long
Dim lSize As Long
Dim Hdr As PictureHeader

' Create a new empty
' picture object
Set Array2Picture = New StdPicture

' Get the IPersistStream interface
Set oIPS = Array2Picture

' Calculate the array size
lSize = UBound(aBytes) - LBound(aBytes) + 1

' Allocate global memory
hGlobal = GlobalAlloc(GHND, lSize + Len(Hdr))

If hGlobal Then

' Get a pointer to the memory
lPtr = GlobalLock(hGlobal)

' Initialize the header
Hdr.Magic = PictureID
Hdr.Size = lSize

' Write the header
MoveMemory ByVal lPtr, Hdr, Len(Hdr)

' Copy the byte array to
' the global memory
MoveMemory ByVal lPtr + Len(Hdr), aBytes(0), lSize

' Release the pointer
GlobalUnlock hGlobal

' Create a IStream object
' with the global memory
Set oStream = CreateStreamOnHGlobal(hGlobal, True)

' Load the picture
' from the stream
oIPS.Load oStream

' Release the IStream
' object
Set oStream = Nothing

End If
End Function

[ltpao]

需引用OLELIB.tlb，网上搜索Edanmo's OLE interfaces & functions

[SYSSZ]

大家都来测试下19楼的代码.

[ltpao]

应该没问题的，我在一个网络传真项目中用过的

[chinaboyzyq]

Option Explicit

Private Declare Function SendMessage Lib "user32" Alias _
         "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
         ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetDC Lib "User32.dll" (ByVal hWnd As Long) As Long
Private Declare Function GetClientRect Lib "User32.dll" (ByVal hWnd As Long, ByRef lpRect As RectAPI) As Long
Private Declare Function SelectObject Lib "GDI32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function GetWindowRect Lib "User32.dll" (ByVal hWnd As Long, ByRef lpRect As RectAPI) As Long
Private Declare Function CreateCompatibleBitmap Lib "GDI32.dll" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function ReleaseDC Lib "User32.dll" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function DeleteObject Lib "GDI32.dll" (ByVal hObject As Long) As Long
Private Declare Function OpenClipboard Lib "User32.dll" (ByVal hWnd As Long) As Long
Private Declare Function EmptyClipboard Lib "User32.dll" () As Long
Private Declare Function SetClipboardData Lib "User32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CloseClipboard Lib "User32.dll" () As Long
Private Type RectAPI
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const WM_PAINT = &HF
Private Const WM_PRINT = &H317
Private Const PRF_NONCLIENT = &H2
Private Const PRF_ERASEBKGND = &H8
Private Const PRF_CLIENT = &H4&    
Private Const PRF_CHILDREN = &H10& 
Private Const PRF_OWNED = &H20&    
Private Const CF_BITMAP As Long = 2
  
Private Sub Command1_Click()
    Dim hDCMem As Long
    Dim Rect As RectAPI
    Dim hBmp As Long, hOld As Long
    Dim hDC As Long
    hDCMem = CreateCompatibleDC(0&)
    Call GetWindowRect(Picture1.hWnd, Rect)
    hDC = GetDC(hWnd)
    hBmp = CreateCompatibleBitmap(hDC, Rect.Right - Rect.Left, Rect.Bottom - Rect.Top)
    Call ReleaseDC(hWnd, hDC)
    hOld = SelectObject(hDCMem, hBmp)
    Call SendMessage(Picture1.hWnd, WM_PAINT, hDCMem, 0)
    Call SendMessage(Picture1.hWnd, WM_PRINT, hDCMem, ByVal (PRF_CHILDREN Or PRF_CLIENT Or PRF_ERASEBKGND Or PRF_NONCLIENT Or PRF_OWNED))
    Call SelectObject(hDCMem, hOld)
    Call DeleteObject(hDCMem)
    If (OpenClipboard(hWnd)) Then
        Call EmptyClipboard
        Call SetClipboardData(CF_BITMAP, hBmp)
        Call CloseClipboard
        Dim X As New StdPicture
        Set X = Clipboard.GetData
        Set Picture2.Picture = X     '从StdPicture对象获取
        Picture3 = Clipboard.GetData '直接从裁剪板获取
    End If
End Sub

Private Sub Form_Load()
    Picture1.BorderStyle = 0
    Picture1.Line (0, 0)-(1000, 1000)
End Sub

[泊客天涯]

关注