请问:怎么通过一个BMP的hDC将图片转换为DIB BITMAP（元文件）或者通过hDC将该图片插入到RichTextBox中(不使用剪贴板),万分感谢！

[smartMouse]

如题

[smartMouse]

谢谢大家 ，我是要生成RTF格式的报表，内容包括图片，表格，文字，格式不固定。表格，文字是生成RTF控制码，图片是由拷屏在内存中生成一个Picture,转换成控制码，然后将控制码输入到RICHTEXTBOX中显示。
用剪贴板的话，图片在RTF中不好控制到x行x列的位置，生成临时图片又影响性能（图片较大），

[TechnoFantasy]

如果是这样的话，建议你看一下这两个链接：
http://msdn.microsoft.com/library/default.asp?url=/library/en-us/dnrtfspec/html/rtfspec.asp
这个是MSDN中关于RT文件格式的详细说明

还有这个：
http://www.elitevb.com/content/01,0057,01

[rainstormmaster]

根据rtf的文件格式写吧，必要的时候还可以扩充rtf定义

[supergreenbean]

GetDIBits

[TechnoFantasy]

这里有一个可以将Picture中图片转换为RTF控制字符串的代码：

Private Function StdPicAsRTF(aStdPic As StdPicture) As String

' ***********************************************************************
' Author: The Hand
' Date: June, 2002
' Company: EliteVB
'
' Function: StdPicAsRTF
' Arguments: aStdPic - Any standard picture object from memory, a
' picturebox, or other source.
'
' Description:
' Embeds a standard picture object in a windows metafile and returns
' rich text format code (RTF) so it can be placed in a RichTextBox.
' Useful for emoticons in chat programs, pics, etc. Currently does
' not support icon files, but that is easy enough to add in.
' ***********************************************************************
Dim hMetaDC As Long
Dim hMeta As Long
Dim hPicDC As Long
Dim hOldBmp As Long
Dim aBMP As BITMAP
Dim aSize As Size
Dim aPt As POINTAPI
Dim fileName As String
' Dim aMetaHdr As METAHEADER
Dim screenDC As Long
Dim headerStr As String
Dim retStr As String
Dim byteStr As String
Dim bytes() As Byte
Dim filenum As Integer
Dim numBytes As Long
Dim i As Long

' Create a metafile to a temporary file in the registered windows TEMP folder
fileName = getTempName("WMF")
hMetaDC = CreateMetaFile(fileName)

' Set the map mode to MM_ANISOTROPIC
SetMapMode hMetaDC, MM_ANISOTROPIC
' Set the metafile origin as 0, 0
SetWindowOrgEx hMetaDC, 0, 0, aPt
' Get the bitmap's dimensions
GetObject aStdPic.Handle, Len(aBMP), aBMP
' Set the metafile width and height
SetWindowExtEx hMetaDC, aBMP.bmWidth, aBMP.bmHeight, aSize
' save the new dimensions
SaveDC hMetaDC
' OK. Now transfer the freakin image to the metafile
screenDC = GetDC(0)
hPicDC = CreateCompatibleDC(screenDC)
ReleaseDC 0, screenDC
hOldBmp = SelectObject(hPicDC, aStdPic.Handle)
BitBlt hMetaDC, 0, 0, aBMP.bmWidth, aBMP.bmHeight, hPicDC, 0, 0, vbSrcCopy
SelectObject hPicDC, hOldBmp
DeleteDC hPicDC
DeleteObject hOldBmp
' "redraw" the metafile DC
RestoreDC hMetaDC, True
' close it and get the metafile handle
hMeta = CloseMetaFile(hMetaDC)

' GetObject hMeta, Len(aMetaHdr), aMetaHdr
' delete it from memory
DeleteMetaFile hMeta

' Do the RTF header for the object. This little bit is sometimes required on
' earlier versions of the rich text box and in certain operating systems
' (WinNT springs to mind)
headerStr = "{\rtf1\ansi"
' Picture specific tag stuff
headerStr = headerStr & _
"{\pict\picscalex100\picscaley100" & _
"\picw" & aStdPic.Width & "\pich" & aStdPic.Height & _
"\picwgoal" & aBMP.bmWidth * Screen.TwipsPerPixelX & _
"\pichgoal" & aBMP.bmHeight * Screen.TwipsPerPixelY & _
"\wmetafile8"

' Get the size of the metafile
numBytes = FileLen(fileName)
' Create our byte buffer for reading
ReDim bytes(1 To numBytes)
' get a free file number
filenum = FreeFile()
' open the file for input
Open fileName For Binary Access Read As #filenum
' read the bytes
Get #filenum, , bytes
' close the file
Close #filenum
' Generate our hex encoded byte string
byteStr = String(numBytes * 2, "0")
For i = LBound(bytes) To UBound(bytes)
If bytes(i) > &HF Then
Mid$(byteStr, 1 + (i - 1) * 2, 2) = Hex$(bytes(i))
Else
Mid$(byteStr, 2 + (i - 1) * 2, 1) = Hex$(bytes(i))
End If
Next i
' stick it all together
retStr = headerStr & " " & byteStr & "}"
' Add in the closing RTF bit
retStr = retStr & "}"

StdPicAsRTF = retStr
On Local Error Resume Next
' Kill the temporary file
If Dir(fileName) <> "" Then Kill fileName
End Function

[rainstormmaster]

//怎么通过一个BMP的hDC将图片转换为DIB BITMAP（元文件）

首先，BMP文件没有hDC，其次DIB BITMAP也不是元文件，他是与设备无关的位图。如果你要将一个bmp文件插入到richtextbox控件中（只是不希望使用剪贴板）的话，可以这样：
Option Explicit
Private Type Size
cx As Long
cy As Long
End Type
Private Type POINTAPI
X As Long
y As Long
End Type
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
' Used to create the metafile
Private Declare Function CreateMetaFile Lib "gdi32" Alias "CreateMetaFileA" (ByVal lpString As String) As Long
Private Declare Function CloseMetaFile Lib "gdi32" (ByVal hDCMF As Long) As Long
Private Declare Function DeleteMetaFile Lib "gdi32" (ByVal hMF As Long) As Long
' 6 APIs used to render/embed the bitmap in the metafile
Private Declare Function SetMapMode Lib "gdi32" (ByVal hdc As Long, ByVal nMapMode As Long) As Long
Private Declare Function SetWindowExtEx Lib "gdi32" (ByVal hdc As Long, ByVal nX As Long, ByVal nY As Long, lpSize As Size) As Long
Private Declare Function SetWindowOrgEx Lib "gdi32" (ByVal hdc As Long, ByVal nX As Long, ByVal nY As Long, lpPoint As POINTAPI) As Long
Private Declare Function SaveDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function RestoreDC Lib "gdi32" (ByVal hdc As Long, ByVal nSavedDC As Long) As Long
' These APIs are used to BitBlt the bitmap image into the metafile
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
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 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

' Used for creating the temporary WMF file
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Private Const MM_ANISOTROPIC = 8 ' Map mode anisotropic:
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long

Private Function GetTempName(TmpFilePrefix As String) As String
Dim TempFileName As String * 256
Dim X As Long
Dim DriveName As String
DriveName = "c:"
X = GetTempFileName(DriveName, TmpFilePrefix, 0, TempFileName)
GetTempName = Left$(TempFileName, InStr(TempFileName, Chr(0)) - 1)
End Function
Private Function StdPicAsRTF(aStdPic As StdPicture) As String
' ***********************************************************************
' Author: The Hand
' Date: June, 2002
' Company: EliteVB
'
' Function: StdPicAsRTF
' Arguments: aStdPic - Any standard picture object from memory, a
' picturebox, or other source.
'
' Description:
' Embeds a standard picture object in a windows metafile and returns
' rich text format code (RTF) so it can be placed in a RichTextBox.
' Useful for emoticons in chat programs, pics, etc. Currently does
' not support icon files, but that is easy enough to add in.
' ***********************************************************************
Dim hMetaDC As Long
Dim hMeta As Long
Dim hPicDC As Long
Dim hOldBmp As Long
Dim aBMP As BITMAP
Dim aSize As Size
Dim aPt As POINTAPI
Dim fileName As String
' Dim aMetaHdr As METAHEADER
Dim screenDC As Long
Dim headerStr As String
Dim retStr As String
Dim byteStr As String
Dim bytes() As Byte
Dim filenum As Integer
Dim numBytes As Long
Dim i As Long

' Create a metafile to a temporary file in the registered windows TEMP folder
fileName = GetTempName("WMF")
hMetaDC = CreateMetaFile(fileName)

' Set the map mode to MM_ANISOTROPIC
SetMapMode hMetaDC, MM_ANISOTROPIC
' Set the metafile origin as 0, 0
SetWindowOrgEx hMetaDC, 0, 0, aPt
' Get the bitmap's dimensions
GetObject aStdPic.Handle, Len(aBMP), aBMP
' Set the metafile width and height
SetWindowExtEx hMetaDC, aBMP.bmWidth, aBMP.bmHeight, aSize
' save the new dimensions
SaveDC hMetaDC
' OK. Now transfer the freakin image to the metafile
screenDC = GetDC(0)
hPicDC = CreateCompatibleDC(screenDC)
ReleaseDC 0, screenDC
hOldBmp = SelectObject(hPicDC, aStdPic.Handle)
BitBlt hMetaDC, 0, 0, aBMP.bmWidth, aBMP.bmHeight, hPicDC, 0, 0, vbSrcCopy
SelectObject hPicDC, hOldBmp
DeleteDC hPicDC
DeleteObject hOldBmp
' "redraw" the metafile DC
RestoreDC hMetaDC, True
' close it and get the metafile handle
hMeta = CloseMetaFile(hMetaDC)

' GetObject hMeta, Len(aMetaHdr), aMetaHdr
' delete it from memory
DeleteMetaFile hMeta

' Do the RTF header for the object. This little bit is sometimes required on
' earlier versions of the rich text box and in certain operating systems
' (WinNT springs to mind)
headerStr = "{\rtf1\ansi"
' Picture specific tag stuff
headerStr = headerStr & _
"{\pict\picscalex100\picscaley100" & _
"\picw" & aStdPic.Width & "\pich" & aStdPic.Height & _
"\picwgoal" & aBMP.bmWidth * Screen.TwipsPerPixelX & _
"\pichgoal" & aBMP.bmHeight * Screen.TwipsPerPixelY & _
"\wmetafile8"

' Get the size of the metafile
numBytes = FileLen(fileName)
' Create our byte buffer for reading
ReDim bytes(1 To numBytes)
' get a free file number
filenum = FreeFile()
' open the file for input
Open fileName For Binary Access Read As #filenum
' read the bytes
Get #filenum, , bytes
' close the file
Close #filenum
' Generate our hex encoded byte string
byteStr = String(numBytes * 2, "0")
For i = LBound(bytes) To UBound(bytes)
If bytes(i) > &HF Then
Mid$(byteStr, 1 + (i - 1) * 2, 2) = Hex$(bytes(i))
Else
Mid$(byteStr, 2 + (i - 1) * 2, 1) = Hex$(bytes(i))
End If
Next i
' stick it all together
retStr = headerStr & " " & byteStr & "}"
' Add in the closing RTF bit
retStr = retStr & "}"

StdPicAsRTF = retStr
On Local Error Resume Next
' Kill the temporary file
If Dir(fileName) <> "" Then Kill fileName
End Function
'调用
Private Sub Command1_Click()
Dim aStr As String
Dim pic As StdPicture
Set pic = LoadPicture("e:\a.jpg")
aStr = StdPicAsRTF(pic)
RichTextBox1.SelRTF = aStr
Set pic = Nothing
End Sub

[TechnoFantasy]

http://www.elitevb.com/content/01,0057,01/

[rainstormmaster]

呵呵，老大的速度够快的：）

[rainstormmaster]

我的代码和老大的一样，就是把声明添上了：）

[TechnoFantasy]

还有一个更简单的方法：

RichTextBox1.OLEObjects.Add , , "d:\aaa.bmp"

可以通过RTF控件的OLEObjects来添加OLE对象并操作。

[rainstormmaster]

RichTextBox1.OLEObjects.Add 的话，会出现画图程序的菜单，看楼主是否需要了，其实用剪贴板不是也很好吗？