Belirtilen Ebatlarda Resim İndirme

[Ömer2134]

Arkadaşlar merhaba

Aşağıda bulunan kodda webdeki resimleri indirebiliyorum. Örnek verecek olursa 1000 x 1200 şeklinde görsellere indirmek istiyorum. Yada başka ölçülerde. Bunu nasıl yapabilirim.

Option Explicit

#If VBA7 And Win64 Then
    Private Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _
      Alias "URLDownloadToFileA" ( _
        ByVal pCaller As LongPtr, _
        ByVal szURL As String, _
        ByVal szFileName As String, _
        ByVal dwReserved As LongPtr, _
        ByVal lpfnCB As LongPtr _
      ) As Long
    Private Declare PtrSafe Function DeleteUrlCacheEntry Lib "Wininet.dll" _
      Alias "DeleteUrlCacheEntryA" ( _
        ByVal lpszUrlName As String _
      ) As Long
#Else
    Private Declare Function URLDownloadToFile Lib "urlmon" _
      Alias "URLDownloadToFileA" ( _
        ByVal pCaller As Long, _
        ByVal szURL As String, _
        ByVal szFileName As String, _
        ByVal dwReserved As Long, _
        ByVal lpfnCB As Long _
      ) As Long
    Private Declare Function DeleteUrlCacheEntry Lib "Wininet.dll" _
      Alias "DeleteUrlCacheEntryA" ( _
        ByVal lpszUrlName As String _
      ) As Long
#End If

Public Const ERROR_SUCCESS As Long = 15
Public Const BINDF_GETNEWESTVERSION As Long = &H10
Public Const INTERNET_FLAG_RELOAD As Long = &H80000000

Sub dlStaplesImages()
    Dim rw As Long, lr As Long, ret As Long, sIMGDIR As String, sWAN As String, sLAN As String
    Dim i As Long
    Dim resim As String
    Dim urlalt As String
    
    
  
    sIMGDIR = "c:\folder\" & "resim"
    If Dir(sIMGDIR, vbDirectory) = "" Then MkDir sIMGDIR

    With ActiveSheet    '<-set this worksheet reference properly!
    
        
        urlalt = "http://www.brandlifemag.com/wp-content/uploads/2019/01/acilis-shutterstock_1120772963-1170x780.jpg"

            sWAN = urlalt
            sLAN = sIMGDIR & Chr(92) & Trim(Right(Replace(sWAN, Chr(47), Space(999)), 999))

            
            Debug.Print sWAN
            Debug.Print sLAN

            If CBool(Len(Dir(sLAN))) Then
                Call DeleteUrlCacheEntry(sLAN)
                Kill sLAN
            End If
             ret = URLDownloadToFile(0&, sWAN, sLAN, BINDF_GETNEWESTVERSION, 0&)
            
End With
End Sub

Teşekkürler.

 

[Ömer2134]

Merhaba hocalarım. Yardımınızı rica ederim.

 

[Korhan Ayhan]

Merhaba,

Siz indirdiğiniz resmin çözünürlüğünü mü değiştirmek istiyorsunuz?

Eğer durum böyleyse linkte bir kod buldum. Sanırım bu işlemi yapıyor.

VBA Image Resize Function by Geoff Griffith, Imagne Thought Software

Resize images using VBA and the Microsoft Windows Image Acquisition Library, by Geoff Griffith

www.msaccessgurus.com

 

[Ömer2134]

Evet istediğim bu şekilde Korhan bey. Fakat kodu nereye koyacağımı bilmiyorum.