RichTextBox技巧之插入图片

' 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

PictureToRTF方法:
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 & "\~pic" & ((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, 
00, 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, 00, Bmp.Width, Bmp.Height, hPicDC, 00, 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 ByteAs String
    Hex00 
= Right("0" & Hex(icolor), 2)
End Function

你可能感兴趣的:(text)