Const ImgFileFormat = "Image Files (*.bmp;*.gif;*.tif;*.jpg;*.jpeg)," & "*bmp;*gif;*.tif;*.jpg;*.jpeg"
Sub AddPicturesToComments3()
Dim HasCom
Dim Pict As String
Dim Ans As Integer
Dim octl As CommandBarControl
Dim objTemp As Object
Dim chtMyChart As Chart
Dim rngImg As Range
Set HasCom = ActiveCell.Comment
If Not HasCom Is Nothing Then ActiveCell.Comment.Delete
Set HasCom = Nothing
GetPict:
Pict = Application.GetOpenFilename(ImgFileFormat)
If Pict = "False" Then End
Ans = MsgBox("Open : " & Pict, vbYesNo + vbExclamation, "bu resim mi kullanılsın?")
If Ans = vbNo Then GoTo GetPict
x = 4
ActiveSheet.Pictures.Insert(Pict).Name = "onder1"
ActiveSheet.Shapes("onder1").Select
With Selection
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Height = 280
.ShapeRange.Width = 315#
.ShapeRange.Rotation = 0#
End With
With Selection
Set octl = Application.CommandBars.FindControl(ID:=6382)
Application.SendKeys "%w~"
Application.SendKeys "%a~"
octl.Execute
End With
ActiveSheet.Shapes("onder1").Select
With Selection
.CopyPicture 1, 2
Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
With chtMyChart
.Paste
.Export "C:\Temp.jpg"
.Parent.Delete
End With
.Delete
End With
Set rngImg = Nothing
Set objTemp = Nothing
Pict = "C:\Temp.jpg"
With ActiveCell
.AddComment
.Comment.Visible = False
.Comment.Shape.Fill.Transparency = 0#
.Comment.Shape.Fill.UserPicture Pict
.Comment.Shape.ScaleWidth x, msoFalse, msoScaleFromTopLeft
.Comment.Shape.ScaleHeight x, msoFalse, msoScaleFromTopLeft
End With
Kill Pict
End Sub
BU SİTEDEKİ USTADLARIN KODLARINDAN BIRAZ DA INTERNETTE BASKA SITELERDEN BULDUGUM BASKA KODLARLA YUKARIDAKI CALIŞMAYI YAPTIM
BIRAZ SEKILSIZ OLDU KUSURA BAKMAYIN USTA KODCULARIN DOKUNUSU BIRAZ TOPARLAR UMARIM AMA EXCEL 2003 INGILIZCE DE CALISIYOR.
ACIKLAMA EKLER GIBI RESIM EKLEMEYI SAGLIYOR FAKAT AYNI ZAMANDA YUKSEK COZUNURLUKTE CEKILEN RESIMLER SEBEBI ILE KISA SUREDE EXCEL DOSYASINI 100 MB LARA ULAŞTIRDIGINDAN BİR DE EXCELDEKİ RESIM SIKISTIRMA OZELLİĞİNİ KULLANDIM.
UMARIM İŞE YARAR...
EXCEL.WEB.TR YI HEMEN HEMEN HERGUN KULLANIYORUM KATKIMIZ OLDUYSA NE ALA...
Sub AddPicturesToComments3()
Dim HasCom
Dim Pict As String
Dim Ans As Integer
Dim octl As CommandBarControl
Dim objTemp As Object
Dim chtMyChart As Chart
Dim rngImg As Range
Set HasCom = ActiveCell.Comment
If Not HasCom Is Nothing Then ActiveCell.Comment.Delete
Set HasCom = Nothing
GetPict:
Pict = Application.GetOpenFilename(ImgFileFormat)
If Pict = "False" Then End
Ans = MsgBox("Open : " & Pict, vbYesNo + vbExclamation, "bu resim mi kullanılsın?")
If Ans = vbNo Then GoTo GetPict
x = 4
ActiveSheet.Pictures.Insert(Pict).Name = "onder1"
ActiveSheet.Shapes("onder1").Select
With Selection
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Height = 280
.ShapeRange.Width = 315#
.ShapeRange.Rotation = 0#
End With
With Selection
Set octl = Application.CommandBars.FindControl(ID:=6382)
Application.SendKeys "%w~"
Application.SendKeys "%a~"
octl.Execute
End With
ActiveSheet.Shapes("onder1").Select
With Selection
.CopyPicture 1, 2
Set chtMyChart = ActiveSheet.ChartObjects.Add(1, 1, .Width, .Height).Chart
With chtMyChart
.Paste
.Export "C:\Temp.jpg"
.Parent.Delete
End With
.Delete
End With
Set rngImg = Nothing
Set objTemp = Nothing
Pict = "C:\Temp.jpg"
With ActiveCell
.AddComment
.Comment.Visible = False
.Comment.Shape.Fill.Transparency = 0#
.Comment.Shape.Fill.UserPicture Pict
.Comment.Shape.ScaleWidth x, msoFalse, msoScaleFromTopLeft
.Comment.Shape.ScaleHeight x, msoFalse, msoScaleFromTopLeft
End With
Kill Pict
End Sub
BU SİTEDEKİ USTADLARIN KODLARINDAN BIRAZ DA INTERNETTE BASKA SITELERDEN BULDUGUM BASKA KODLARLA YUKARIDAKI CALIŞMAYI YAPTIM
BIRAZ SEKILSIZ OLDU KUSURA BAKMAYIN USTA KODCULARIN DOKUNUSU BIRAZ TOPARLAR UMARIM AMA EXCEL 2003 INGILIZCE DE CALISIYOR.
ACIKLAMA EKLER GIBI RESIM EKLEMEYI SAGLIYOR FAKAT AYNI ZAMANDA YUKSEK COZUNURLUKTE CEKILEN RESIMLER SEBEBI ILE KISA SUREDE EXCEL DOSYASINI 100 MB LARA ULAŞTIRDIGINDAN BİR DE EXCELDEKİ RESIM SIKISTIRMA OZELLİĞİNİ KULLANDIM.
UMARIM İŞE YARAR...
EXCEL.WEB.TR YI HEMEN HEMEN HERGUN KULLANIYORUM KATKIMIZ OLDUYSA NE ALA...
Son düzenleme:
