Inserting Pictures as RichTextBoxes Help

[MysT_DooM]

The code for doing all this is in the module modRTFpic

Code Select Expand


Option Explicit

Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" _
   (ByVal lpDriverName As String, ByVal lpDeviceName As String, _
   ByVal lpOutput As Long, ByVal lpInitData 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 CreateCompatibleDC Lib "gdi32" ( _
    ByVal hdc As Long _
) As Long

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

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 GetObject Lib "gdi32" Alias "GetObjectA" ( _
    ByVal hObject As Long, _
    ByVal nCount As Long, _
    lpObject As Any _
) 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

Private Declare Function RestoreDC Lib "gdi32" ( _
    ByVal hdc As Long, _
    ByVal nSavedDC As Long _
) As Long

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 SelectObject Lib "gdi32" ( _
    ByVal hdc As Long, _
    ByVal hObject As Long _
) As Long

Private Const MM_ANISOTROPIC = 8

Private Type Size
    x As Long
    y As Long
End Type

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type BITMAP
    Type   As Long
    Width  As Long
    Height As Long
    WidthB As Long
    Planes As Long
    BitsPx As Long
    Bits   As Long
End Type

'Inserts the picture at the current insertion point
Public Function InsertPicture(RTB As RichTextBox, pic As StdPicture)
Dim strRTFall As String
Dim lStart As Long
    With RTB
        .SelText = Chr(&H9D) & .SelText & Chr(&H81)
        strRTFall = .TextRTF
        strRTFall = Replace(strRTFall, "\'9d", PictureToRTF(pic))
        .TextRTF = strRTFall
        'position cursor past new insertion
        lStart = .Find(Chr(&H81))
        strRTFall = Replace(strRTFall, "\'81", "")
        .TextRTF = strRTFall
        .SelStart = lStart
    End With
End Function

'returns the RTF string representation of our picture
Public Function PictureToRTF(pic As StdPicture) As String
    Dim hMetaDC As Long, hMeta As Long, hPicDC As Long, hOldBmp As Long
    Dim Bmp As BITMAP, Sz As Size, Pt As POINTAPI
    Dim sTempFile As String, screenDC As Long
    Dim headerStr As String, retStr As String, byteStr As String
    Dim ByteArr() As Byte, nBytes As Long
    Dim fn As Long, i As Long, j As Long

    sTempFile = App.Path & "\My Documents\da.bmp" & ((Rnd * 1000000) + 1000000) \ 1 & ".tmp"  'some temprory file
    If Dir(sTempFile) <> "" Then Kill sTempFile
   
    'Create a metafile which is a collection of structures that store a
    'picture in a device-independent format.
    hMetaDC = CreateMetaFile(sTempFile)
   
    'set size of Metafile window
    SetMapMode hMetaDC, MM_ANISOTROPIC
    SetWindowOrgEx hMetaDC, 0, 0, Pt
    GetObject pic.Handle, Len(Bmp), Bmp
    SetWindowExtEx hMetaDC, Bmp.Width, Bmp.Height, Sz
    'save sate for later retrieval
    SaveDC hMetaDC
   
    'get DC compatible to screen
    screenDC = GetDC(0)
    hPicDC = CreateCompatibleDC(screenDC)
    ReleaseDC 0, screenDC
   
    'set out picture as new DC picture
    hOldBmp = SelectObject(hPicDC, pic.Handle)
   
    'copy our picture to metafile
    BitBlt hMetaDC, 0, 0, Bmp.Width, Bmp.Height, hPicDC, 0, 0, vbSrcCopy
   
    'cleanup - close metafile
    SelectObject hPicDC, hOldBmp
    DeleteDC hPicDC
    DeleteObject hOldBmp
    'retrieve saved state
    RestoreDC hMetaDC, True
    hMeta = CloseMetaFile(hMetaDC)
    DeleteMetaFile hMeta
   
    'header to string we want to insert
    headerStr = "{\pict\wmetafile8" & _
                "\picw" & pic.Width & "\pich" & pic.Height & _
                "\picwgoal" & Bmp.Width * Screen.TwipsPerPixelX & _
                "\pichgoal" & Bmp.Height * Screen.TwipsPerPixelY & _
                " "
       
    'read metafile from disk into byte array
    nBytes = FileLen(sTempFile)
    ReDim ByteArr(1 To nBytes)
    fn = FreeFile()
    Open sTempFile For Binary Access Read As #fn
    Get #fn, , ByteArr
    Close #fn
    Dim nlines As Long
       
    'turn each byte into two char hex value
    i = 0
    byteStr = ""
    Do
        byteStr = byteStr & vbCrLf
        For j = 1 To 39
            i = i + 1
            If i > nBytes Then Exit For
            byteStr = byteStr & Hex00(ByteArr(i))
        Next j
    Loop While i < nBytes
   
    'string we will be inserting
    retStr = headerStr & LCase(byteStr) & vbCrLf & "}"
    PictureToRTF = retStr
   
    'remove temp metafile
    Kill sTempFile

End Function

'adds leading zero to hex value if needed.
Public Function Hex00(icolor As Byte) As String
    Hex00 = Right("0" & Hex(icolor), 2)
End Function


Code Select Expand

Private Sub Form_Load()
modRTFpic.InsertPicture
End Sub

and i seem to be getting arguement not optional error. i searched msdn for help but no success.  So am i doing something wrong?

[Warrior]

That error means you are not providing a parameter for a function which it needs, check which error it breaks on and then look up that function.

[RealityRipple]

1) you have to tell it what to do, like this:

Code Select Expand

Private Sub Form_Load()
modRTFpic.InsertPicture RichTextBox1, Picture1.Picture
End Sub

2) That's a lot of extra code just to insert a picture in a rich text box. I remember there was an OLEObjects way of doing it that accomplished the same thing.