.png uzantılı resim eklemek

[HASAN40]

Merhaba,

Excel çalışma sayfasına eklediğim bir image nesnesine .png uzantılı resim eklemek istiyorum. Arkaplanı olmayan saydam .gif formatında eklediğim de kalite bozuluyor ve hoş olmuyor. Bu konuda yardımcı olabilir misiniz?

 

[Levent Menteşoğlu]

Resmi image nesnesine nasıl yüklüyorsunuz.

 

[HASAN40]

Levent Bey,
Ekle > Resim yolunu kullanarak değil de, activex denetimi olarak ekliyorum böylece makrolar ile otomatik resim çağırabiliyorum. Ancak bu şekilde gif formatında olduğundan kalitesiz oluyor resimler.

 

[Levent Menteşoğlu]

Hasan bey kasdettiğim bir butona yazdığınız kodlarlamı yüklüyorsunuz. Eğer öylese kodları yazarmısınız.

 

[HASAN40]

Levent Bey,
Butona yazdığım kod basit bir loadpicture özelliğidir. Kodlar ise ;

Sheets(3).Image3.Picture = LoadPicture("D:\" & Sheets(1).[c7] & "\" & Sheets(3).[b21] & ".gif")

 

[Levent Menteşoğlu]

Png resim ekleme biraz karmaşık bir konudur. Aşağıda belirttiğim şekilde uygularsanız istediğiniz sonucu elde edersiniz.

Kaynak: http://www.vbaexpress.com/forum/archive/index.php/t-30566.html

Aşağıdaki kodları bir normal modüle kopyalayın.

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

Private Type PICTDESC
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type

Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As Long
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type

Private Declare Function GdiplusStartup Lib "GDIPlus" ( _
token As Long, _
inputbuf As GdiplusStartupInput, _
Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" ( _
ByVal FileName As Long, _
bitmap As Long) As Long
Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" ( _
ByVal bitmap As Long, _
hbmReturn As Long, _
ByVal background As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" ( _
ByVal Image As Long) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" ( _
ByVal token As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
PicDesc As PICTDESC, _
RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long

Public Function LoadImage(ByVal strFName As String) As IPicture
Dim uGdiInput As GdiplusStartupInput
Dim hGdiPlus As Long
Dim hGdiImage As Long
Dim hBitmap As Long

uGdiInput.GdiplusVersion = 1

If GdiplusStartup(hGdiPlus, uGdiInput) = 0 Then
If GdipCreateBitmapFromFile(StrPtr(strFName), hGdiImage) = 0 Then
GdipCreateHBITMAPFromBitmap hGdiImage, hBitmap, 0
Set LoadImage = ConvertToIPicture(hBitmap)
GdipDisposeImage hGdiImage
End If
GdiplusShutdown hGdiPlus
End If

End Function

Public Function ConvertToIPicture(ByVal hPic As Long) As IPicture

Dim uPicInfo As PICTDESC
Dim IID_IDispatch As GUID
Dim IPic As IPicture

Const PICTYPE_BITMAP = 1

With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With

With uPicInfo
.Size = Len(uPicInfo)
.Type = PICTYPE_BITMAP
.hPic = hPic
.hPal = 0
End With

OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic

Set ConvertToIPicture = IPic
End Function

Daha sonra kendi kodunuzu aşağıdaki gibi düzenleyin.

Sheets(3).Image3.Picture = LoadImage("D:\" & Sheets(1).[c7] & "\" & Sheets(3).[b21] & ".png")

 

[HASAN40]

Levent Bey,
İlginize teşekkür ederim bu kadar araştırmadan sonra benim yazacağım şeyler hoş olmaz ancak bu kodlarla saydam olan png formatlı resimlerin arkaplanı siyah renkte gözükmekte. İstediğim ise .png resimlerin .gif resimler gibi saydam olması ama kalite kaybının olmaması :/

 

[Levent Menteşoğlu]

Levent Bey,
İlginize teşekkür ederim bu kadar araştırmadan sonra benim yazacağım şeyler hoş olmaz ancak bu kodlarla saydam olan png formatlı resimlerin arkaplanı siyah renkte gözükmekte. İstediğim ise .png resimlerin .gif resimler gibi saydam olması ama kalite kaybının olmaması :/

Bu konuda maalesef fikrim yok.

 

[HASAN40]

Bu konuda maalesef fikrim yok.

İyi akşamlar Levent Bey,

Şehir dışında olmam dolayısıyla konuya geç dönüş yaptım. Bunun için özür dilerim. İlginiz için teşekkür ederim, sanırım sorunuma grafiksel bir çözüm bulmalıyım ( kaliteli gif yapımı, farklı bir tasarım, vs... ) .

İyi akşamlar dilerim...

 

[yusuf1284]

Hocam doğru konuya mı yazdım bilmiyorum User form üzerinde olan image1 fotoğrafıı değiştiridğimde bazı fotoğraflarda hata alıyordum resimleri paintten açıp farklı kaydet dediğimde saydam arka plan kalkacağı uyarısı veriyor ve onaylayıp kaydettim.
Kaydettiğim fotoğrafdan hata almadığmı fark ettim ama her fotoğraf için böyle uğraşmam mı gerekiyor başka yöntem var mıdır

 

[Korhan Ayhan]

En önemli detayı yazmamışsınız.

Resimlerin uzantısı nedir?

 

[winstoncash]

Ben aşağıdaki kodu kullanıyorum png getirmek için. Arka plansız gayet güzel getiriyor. Dosya yolunu, hücre numaralarını falan kendinize uyarlayarak kullanabilirsiniz.

Sub Resimgetir()
 
    Dim NoA As Long, i As Long
    Dim PicFile As String, PicTop As Integer, PicLeft As Integer, PicW As Integer, PicH As Integer
    NoA = Range("D" & Rows.Count).End(xlUp).Row
 
    For i = 26 To 75
        PicFile = "C:\Users\kesek\OneDrive\Belgeler\OneDrive\PAYLASIM\15-ÜRÜN FOTOĞRAFLARI\ürün resim\" & Range("D" & i).Text & ".png"
        If Dir(PicFile) = Empty Then
            Range("B" & i) = ""
            GoTo ResumeFor:
        End If
        PicTop = Range("B" & i).Top + 2
        PicLeft = Range("B" & i).Left + 2
        PicW = Range("B" & i).Width - 2
        PicH = Range("B" & i).Height - 2
        Set MyPic = ActiveSheet.Shapes.AddPicture(PicFile, True, True, PicLeft, PicTop, PicW, PicH)
ResumeFor:
    Next
End Sub