Resim almada düzenleme

[igultekin2000]

iyi günler;
makro ile sayfada resim alıyorum, ancak kenarlardaki boşlukta çıkıyor , düzenleme ila sadece görünen alanın resmini almak mümkün olabilir mi?

Sub jpg_kaydet2()
On Error Resume Next
Call dosyayısil
  Dim objTemp As Object
  Dim chtMyChart As Chart
  Dim rngImg As Range
  Dim No As Long
  Dim TempName As String
  Set rngImg = Range("B2:C8") 'resim alanını burda belirleyin
  rngImg.Copy
  Set objTemp = ActiveSheet.Shapes.AddShape(1, 1, 1, 1, 1)
  objTemp.Select
  ActiveSheet.Paste
  objTemp.Delete
  TempName = Range("O1")
  With Selection
      .CopyPicture 1, 2
      Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
  With chtMyChart
      .Paste
      .Export TempName
      .Parent.Delete
  End With
  .Delete
  End With
  MsgBox "Resim Alanı , " & TempName & " olarak kaydedildi.", , "Excel'i sevmeyen NEZLE olsun."
  Set rngImg = Nothing
  Set objTemp = Nothing
End Sub

 

[halit3]

Bu kodları bir madüle kopyala ve RESİM_KAYDET makro kodunu çalıştır.

#If Win64 Then
Private Declare PtrSafe Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare PtrSafe Function EmptyClipboard& Lib "user32" ()
Private Declare PtrSafe Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Private Declare PtrSafe Function CloseClipboard& Lib "user32" ()
Private Declare PtrSafe Function CopyImage& Lib "user32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
#Else
Private Declare Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare Function EmptyClipboard& Lib "user32" ()
Private Declare Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Private Declare Function CloseClipboard& Lib "user32" ()
Private Declare Function CopyImage& Lib "user32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
#End If

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type

Private Sub ImageToMePicture()
Dim hCopy&: OpenClipboard 0&
' Bitmap = 2 / Metafile = 14
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
CloseClipboard

If hCopy = 0 Then Exit Sub
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim IPic As IPicture, tIID As GUID, tPICTDEST As PICTDESC, Ret&
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
If Ret Then Exit Sub
With tPICTDEST
.cbSize = Len(tPICTDEST)
' Bitmap = 1 / Metafile = 4
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, IPic)
If Ret Then Exit Sub


Set Dosya_Sistemi = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path & "\Resimler\"
If Not Dosya_Sistemi.FolderExists(yol) Then
Dosya_Sistemi.CreateFolder (yol)
End If

say = CreateObject("Scripting.FileSystemObject").getfolder(yol).Files.Count + 1
SavePicture IPic, yol & "\Resim " & say & ".bmp"
Set IPic = Nothing
End Sub
Sub RESİM_KAYDET()
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
sat = ActiveWindow.RangeSelection.Row
sut = ActiveWindow.RangeSelection.Column
Set Adres2 = ActiveSheet.Range("B2:C8") ' ActiveSheet.Range(ActiveWindow.RangeSelection.Address)
ActiveSheet.Range(Adres2.Address).CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Call ImageToMePicture
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
MsgBox "İşlem tamam"
End Sub

 

[igultekin2000]

Bu kodları bir madüle kopyala ve RESİM_KAYDET makro kodunu çalıştır.

Teşekkür ederim, sorunsuz çalışıyor, iyi çalışmalar

 

[halit3]

Yukarıdaki kodu yeniden güncelledim.

 

[igultekin2000]

Yukarıdaki kodu yeniden güncelledim.

yanlış algılamadıysam, ilk sayfaya kopyalama silme kalkmış, görüntü daha net hale gelmiş, teşekkürler iyi çalışmalar.

 

[halit3]

yanlış algılamadıysam, ilk sayfaya kopyalama silme kalkmış, görüntü daha net hale gelmiş, teşekkürler iyi çalışmalar.

Evet Aynen öyle

Bu kod da makroların birleştirilmiş hali

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(8) As Byte
End Type

Private Type PICTDESC
cbSize As Long
picType As Long
hImage As Long
End Type


#If Win64 Then
Private Declare PtrSafe Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare PtrSafe Function EmptyClipboard& Lib "user32" ()
Private Declare PtrSafe Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Private Declare PtrSafe Function CloseClipboard& Lib "user32" ()
Private Declare PtrSafe Function CopyImage& Lib "user32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare PtrSafe Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
#Else
Private Declare Function OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare Function EmptyClipboard& Lib "user32" ()
Private Declare Function GetClipboardData& Lib "user32" (ByVal wFormat%)
Private Declare Function CloseClipboard& Lib "user32" ()
Private Declare Function CopyImage& Lib "user32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
#End If

Sub deneme2_Click()

Set Adres2 = ActiveSheet.Range("B2:C8") ' ActiveSheet.Range(ActiveWindow.RangeSelection.Address)
ActiveSheet.Range(Adres2.Address).CopyPicture Appearance:=xlScreen, Format:=xlBitmap

Dim hCopy&: OpenClipboard 0&
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
CloseClipboard

If hCopy = 0 Then Exit Sub
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Dim IPic As IPicture, tIID As GUID, tPICTDEST As PICTDESC, Ret&
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
If Ret Then Exit Sub
With tPICTDEST
.cbSize = Len(tPICTDEST)
.picType = 1
.hImage = hCopy
End With
Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, IPic)
If Ret Then Exit Sub

Set fl = CreateObject("Scripting.FileSystemObject")
yol = ThisWorkbook.Path & "\Resimler\"
If Not fl.FolderExists(yol) Then
fl.CreateFolder (yol)
End If

say = fl.getfolder(yol).Files.Count + 1
SavePicture IPic, yol & "\Resim " & say & ".bmp"
Set IPic = Nothing


OpenClipboard (0&)
EmptyClipboard
CloseClipboard

MsgBox "İşlem tamam"
End Sub