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
'Private Type METAHEADER
' mtType As Integer
' mtHeaderSize As Integer
' mtVersion As Integer
' mtSize As Long
' mtNoObjects As Integer
' mtMaxRecord As Long
' mtNoParameters As Integer
'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
Public Function StdPicAsRTF(aStdPic As StdPicture) As String
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 Function getTempName(Optional anExt As String = "tmp") As String
' ***********************************************************************
' Author: The Hand
' Date: June, 2002
' Company: EliteVB
'
' Function: getTempName
' Arguments: anExt - an extension to be used for the temp file. If none
' is provided, the function automatically uses "tmp"
' as the extension. It is up to the procedure that
' uses this temporary name to clean up the file (kill
' it) after it is created.
'
' Description:
' Creates a temporary filename in the registered system temp directory
' ***********************************************************************
Dim tempPath As String
Dim fileName As String
Dim i As Long
Const validChars As String = "123567890qwertyuiopasdfghjklzxcvbnm"
' Create a buffer
tempPath = String$(255, " ")
' get the system path
GetTempPath 255, tempPath
' trim off the fat
tempPath = Left$(tempPath, InStr(tempPath, Chr$(0)) - 1)
' Create a buffer
fileName = Space(12)
' Put the non-random stuff into the string
Mid$(fileName, 1, 1) = "T"
Mid$(fileName, Len(fileName) - Len(anExt), 1) = "."
' Add in the specified extension, if provided ("tmp" is default)
Mid$(fileName, Len(fileName) - Len(anExt) + 1, Len(anExt)) = anExt
' fill the buffer with random stuff
Randomize
For i = 2 To Len(fileName) - 4
Mid$(fileName, i, 1) = Mid$(validChars, CLng(Rnd() * (Len(validChars)) + 1), 1)
Next i
tempPath = tempPath & fileName
' return the path name
getTempName = tempPath
End Function
Private Sub Command1_Click ()
Pic.Picture = LoadPicture("c:\pic.bmp")
Dim aStr As String
aStr = StdPicAsRTF(Pic.Picture)
RichTextBox.SelRTF = aStr
End Sub
Reply With Quote
Thanks! 