作者学习VBA以来搜集的操作图片的代码都在这里了。这就是我说的用到时候修修改改的源代码。
▶▶▶单元格(合并单元格)插入图片 Pictures.insert通用性不如shapes.addpicture。Excel2016用pictures.insert插入图片, 得到的是图片链接,而非嵌入图片。(虽然录制宏得到的的确是这个insert方法) Sub 插入图片() Set Rng = Range("a1") i = ThisWorkbook.Path & "\" & "图片" & "\1.jpg" Sheet1.Shapes.AddPicture i, True, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height End Sub
Sub 合并单元格插入图片() Range("d4").Select Set r = Selection i = ThisWorkbook.Path & "\" & "图片" & "\1.jpg" Sheet1.Shapes.AddPicture i, True, True, r.Left, r.Top, r.Width, r.Height End Sub ▶▶▶批注插入图片 Sub test() Dim rng As Range, com As Comment [a:a].ClearComments For Each rng In Range("a2", [a2].End(xlDown)) Set com = rng.AddComment com.Shape.Fill.UserPicture ThisWorkbook.Path & "\素材图片\" & rng.Value com.Shape.Width = 100 com.Shape.Height = 60 Next End Sub
▶▶▶导出插入的图片 Sub 保存文件中的图片() Dim ad$, m&, mc$, shp As Shape Dim nm$, n&, myFolder$ Sheet1.Activate n = 0 myFolder = ThisWorkbook.Path & "\图片\" For Each shp In ActiveSheet.Shapes If shp.Type = 13 Then If Len(Dir(myFolder, vbDirectory)) = 0 Then MkDir myFolder End If n = n + 1 m = shp.TopLeftCell.Row mc = Replace(Cells(m, 1).Address, "$", "") nm = Format(n, "00") & "-" & mc & ".jpg" shp.CopyPicture With ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height).Chart .Parent.Select .Paste .Export myFolder & nm, "JPG" .Parent.Delete End With End If Next MsgBox "完成" End Sub
▶▶▶导出选定区域为图片 导出为png格式、按位图复制(Rng.CopyPicture xlScreen, xlBitmap)不会失真 Sub 导出选定区域为图片() Call RangeToPic(Range("A1:D5")) Call RangeToPic(Selection) Call RangeToPic(Application.InputBox("Select Range", Type:=8)) End Sub Sub RangeToPic(Rng As Range, Optional Pnm = "", Optional Pth = "") If Pth = "" Then Pth = ActiveWorkbook.Path If Pnm = "" Then Pnm = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1) & "_" & Replace(Rng.Address(0, 0), ":", "_") If ActiveWindow.DisplayGridlines = True Then ActiveWindow.DisplayGridlines = False: flg = True Rng.CopyPicture Appearance:=xlScreen, Format:=xlBitmap With ActiveSheet.ChartObjects.Add(0, 0, Rng.Width + 1, Rng.Height + 1).Chart .ChartArea.Border.LineStyle = 0 .Paste .Export Pth & "\" & Pnm & ".jpg", "JPG" .Export Pth & "\" & Pnm & ".png", "PNG" .Parent.Delete End With If flg Then ActiveWindow.DisplayGridlines = True End Sub
▶▶▶导出图表为图片 Sub 导出图表为图片() Dim myChart As Chart Dim myFileName As String Set myChart = Sheet1.ChartObjects(1).Chart myFileName = "myChart.jpg" myChart.Export Filename:=ThisWorkbook.Path & "/" & myFileName, Filtername:="JPG" End Sub
▶▶▶删除图片
Sub DeletePic() Dim p As Shape For Each p In ActiveSheet.Shapes If p.Type = 13 Then p.Delete End If Next End Sub
▶▶▶求单元格中图片个数 Sub 求单元格中图片个数() For r = 2 To [a65536].End(xlUp).Row t = Range("b" & r).Top h = Range("b" & r).Height c = 0 For Each s In ActiveSheet.Shapes If s.Top >= t And s.Top <= t + h Then c = c + 1 End If Next Range("c" & r) = c Next r End Sub
看都看到最后了,如果觉得不错,希望大家分享一下,或者点一下右下角的"在看" 按钮。
|