Olá amigos!
Encontrei na net um código que tem a finalidade de inserir uma imagem em um controle RichTextBox sem o auxilio do controle CommonDialog, porém, não sei como chamar a função do código.
Caso alguém saiba como fazer para executar a função ao clicar em um botão, por gentileza, me informe. Ficarei muito grato.
Segue o código:
'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
Aqui é a rotina que converte a imagem em um RTF:
'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 & "\~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, 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
Desde já, obrigado!
Encontrei na net um código que tem a finalidade de inserir uma imagem em um controle RichTextBox sem o auxilio do controle CommonDialog, porém, não sei como chamar a função do código.
Caso alguém saiba como fazer para executar a função ao clicar em um botão, por gentileza, me informe. Ficarei muito grato.
Segue o código:
'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
Aqui é a rotina que converte a imagem em um RTF:
'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 & "\~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, 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
Desde já, obrigado!