Program Yapmak | Programcılık Hakkında Her Şey | VİSUAL BASİC 6.0 | C, C++ ve C# Yazılım Dilleri | VB.NET Yazılım Dili

Resim Verisini Resme Donusturmek

Resme ait Byte Array cinsinden bir veriyi IPicture objesine dönüştürmek için kullanabileceğiniz fonksiyon buu dökümanda verilmiştir.
Diskte kayıtlı herhangi bir resim dosyasını LoadPicture ile IPicture nesnesine dönüştürüp PictureBox da göstermek mümkündür. Fakat herhangi bir resim verisini dönüştürmeye yönelih hazır bir fonksiyon yoktur.

Bu örnekteki LoadPictureData fonksiyonu ile bu işlemi gerçekleştirebilirsiniz. Mesela TCP socket bağlantısı ile uzak bilgisayardaki resim verisini taşıyabilir veya hayalgücünüze bağlı olarak bir video görüntüsünü stream olarak aktarabilirsiniz.

Aşağıda, konuya ilişkin döküman kodları bulunmaktadır.

mdlLoadPicture.bas

Option Explicit

'//*******************************************************//
'// Author:   Gokhan ERDOGDU
'// Created:  26 December 2009
'// mail:     gokkhan_erdogdu@yahoo.com
'//*******************************************************//

Private Const S_OK = &H0
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const HIMETRIC_PER_INCH As Long = 2540
Private Const sIID_IPicture As String = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Private Const GMEM_MOVEABLE = &H2

' types
' =====================================================================
Private Type Guid
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type


' externals
' =====================================================================
Private Declare Function GlobalAlloc _
    Lib "kernel32" _
    (ByVal wFlags As Long, _
    ByVal dwBytes As Long) As Long

Private Declare Function GlobalLock _
    Lib "kernel32" _
    (ByVal hMem As Long) As Long
    
Private Declare Function GlobalUnlock _
    Lib "kernel32" _
    (ByVal hMem As Long) As Long

Private Declare Function GlobalFree _
    Lib "kernel32" _
    (ByVal hMem As Long) As Long

Private Declare Sub CopyMemory _
    Lib "kernel32" Alias "RtlMoveMemory" _
   (ByRef Destination As Any, _
    ByRef Source As Any, _
    ByVal Length As Long)
    
Private Declare Function CreateStreamOnHGlobal _
    Lib "ole32" _
    (ByVal hGlobal As Long, _
     ByVal fDeleteOnRelease As Boolean, _
     ByRef ppstm As Any) As Long
    
Private Declare Function OleLoadPicture _
    Lib "olepro32" _
    (pStream As Any, _
     ByVal lSize As Long, _
     ByVal fRunmode As Long, _
     riid As Any, _
     ppvObj As Any) As Long
    
Private Declare Function CLSIDFromString _
    Lib "ole32" _
    (ByVal str As Long, _
     id As Guid) 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 GetDeviceCaps _
    Lib "gdi32" _
    (ByVal hdc As Long, _
     ByVal nIndex As Long) As Long

Private Declare Function MulDiv _
    Lib "kernel32" _
    (ByVal nNumber As Long, _
     ByVal nNumerator As Long, _
     ByVal nDenominator As Long) As Long

Private Function MAP_LOGHIM_TO_PIX(ByVal x As Long, ByVal ppli As Long) As Long
    MAP_LOGHIM_TO_PIX = MulDiv(ppli, x, HIMETRIC_PER_INCH)
End Function

Public Function LoadPictureData(ByVal hWnd As Long, ByRef pData() As Byte, ByVal nLen As Long, ByRef ret_w As Long, ByRef ret_h As Long, ByRef cx As Long, ByRef cy As Long) As IPicture
    Dim dcPictureLoad As Long
    Dim oPicture As IPicture
    Dim hGlobal As Long
    Dim pvData As Long
    Dim oStream As IUnknown
    Dim IID_IPicture As Guid
    
    hGlobal = GlobalAlloc(GMEM_MOVEABLE, nLen)
    If (hGlobal) Then
        pvData = GlobalLock(hGlobal)
        If (pvData) Then
            ' Copy image bytes to memory buffer, and unlock.
            Call CopyMemory(ByVal pvData, pData(LBound(pData)), nLen)
            Call GlobalUnlock(hGlobal)
            
            ' Create an IStream object in global memory buffer.
            If (CreateStreamOnHGlobal(hGlobal, True, oStream) = S_OK) Then
                ' Translate CLSID string to IPicture interface ID.
                If (CLSIDFromString(StrPtr(sIID_IPicture), IID_IPicture) = S_OK) Then
                    ' Create an IPicture from the IStream (the docs say the call does not
                    ' AddRef its last param, but it looks like the reference counts are correct..)
                    Call OleLoadPicture(ByVal ObjPtr(oStream), 0, False, IID_IPicture, oPicture)
                    
                    If (Not oPicture Is Nothing) Then
                        cx = oPicture.Width
                        cy = oPicture.Height
                        
                        dcPictureLoad = GetDC(hWnd)
                        ret_w = MAP_LOGHIM_TO_PIX(cx, GetDeviceCaps(dcPictureLoad, LOGPIXELSX))
                        ret_h = MAP_LOGHIM_TO_PIX(cy, GetDeviceCaps(dcPictureLoad, LOGPIXELSY))
                        Call ReleaseDC(hWnd, dcPictureLoad)
                    End If
                End If
            End If
        End If
        ' Release global memory object.
        Call GlobalFree(hGlobal)
    End If
    
    ' Return results.
    Set LoadPictureData = oPicture
End Function


test formu

Option Explicit

Private Const TEST_FILE As String = "C:Documents and SettingsgerdogduDesktopxxx.jpg"
'Private Const TEST_FILE As String = "C:Documents and SettingsgerdogduMy DocumentsMy Picturestest.bmp"

Private Sub Command1_Click()
    Dim nFreeFile As Long
    Dim datas() As Byte
    Dim nLen As Long
    Dim ret_w As Long
    Dim ret_h As Long
    Dim cx As Long
    Dim cy As Long
    
    nFreeFile = VBA.FreeFile()
    Open TEST_FILE For Binary Access Read As #nFreeFile
    nLen = LOF(nFreeFile)
    ReDim datas(nLen - 1)
    Get #nFreeFile, , datas
    Close #nFreeFile
    
    Set Me.Picture = LoadPictureData(Me.hWnd, datas, nLen, ret_w, ret_h, cx, cy)
End Sub
Sincan Laptop tamiratı ile alakalı içeriklerin bulunduğu web siteden bilgilere ulaşabilirsiniz. Sincan'da laptop tamiratını en iyi yapan yerleri sorgulayabilirsiniz. Cihan KOÇ
=> Sen de ücretsiz bir internet sitesi kurmak ister misin? O zaman burayı tıkla! <=