出题：开发一个选区、图形导入批注的宏

楼主罗刚君	1.如果选择单元格，将另一个选区导入当前单元格批注中 2.如果选择图形对象，将图形对象导入活动单元格批注中 3.用快捷键“Ctrl+Q”调用完成以上功能加分图片与批注.gif
2楼 fāi	加分题我试试图片批注(fāi).rar
3楼 fāi	图像质量…… 期待罗老师的…… Sub 图片批注() Application.ScreenUpdating = False On Error Resume Next s = ActiveCell.Address t = ActiveSheet.Shapes.Count Selection.Copy ActiveSheet.Paste If ActiveSheet.Shapes.Count = t Then Application.CutCopyMode = False Application.ScreenUpdating = True Set rs = Application.InputBox("请选择区域", "区域", s, Type:=8) If rs.Address = Empty Then Exit Sub Set r = Range(rs.Address) Application.ScreenUpdating = False r.CopyPicture Appearance:=xlScreen, Format:=xlPicture ActiveSheet.Paste End If Set Shp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count) fn = ThisWorkbook.Path & "\" & Shp.Name & ".jpg" Shp.Copy With ActiveSheet.ChartObjects.Add(0, 0, Shp.Width, Shp.Height + 6).Chart .Paste .Export fn, "jpg" .Parent.Delete End With Range(s).Select Range(s).ClearComments With Range(s).AddComment .Visible = True .Text Text:="" .Shape.Width = Shp.Width .Shape.Height = Shp.Height .Shape.Select True Selection.ShapeRange.Fill.UserPicture fn .Visible = False End With Shp.Delete Kill fn Application.ScreenUpdating = True End Sub
4楼罗刚君	终于有人回答我的问题了加个支持分不过答案中有两个问题： 1.清晰度不够 2.变形 3.产生了后遗症，工作表中多出个图片望改进
5楼 fāi	Private Declare Function OpenClipboard Lib "User32" _ (ByVal hWnd As Long) As Long Private Declare Function CloseClipboard Lib "User32" () As Long Private Declare Function GetClipboardData Lib "User32" _ (ByVal uFormat As Long) As Long Private Declare Function CopyEnhMetaFileA Lib "Gdi32" _ (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long Private Declare Function DeleteEnhMetaFile Lib "Gdi32" _ (ByVal hdc As Long) As Long Sub 图片批注() s = ActiveCell.Address: f = ThisWorkbook.Path & "\pz.JPG" If TypeName(Selection) = "Range" Then Set rs = Application.InputBox("请选择区域", "区域", s, Type:=8) If rs.Address = Empty Then Exit Sub Application.ScreenUpdating = False Range(rs.Address).CopyPicture ActiveSheet.Paste Set Shp = ActiveSheet.Shapes(ActiveSheet.Shapes.Count) w = Shp.Width: h = Shp.Height Selection.Delete ElseIf TypeName(Selection) = "Picture" Then Application.ScreenUpdating = False Selection.CopyPicture Set Shp = ActiveSheet.Shapes(Selection.Name) w = Shp.Width: h = Shp.Height Else Exit Sub End If OpenClipboard 0 DeleteEnhMetaFile CopyEnhMetaFileA(GetClipboardData(14), f) CloseClipboard Application.CutCopyMode = False Range(s).Select Range(s).ClearComments With Range(s).AddComment .Visible = True .Text Text:="" .Shape.Width = w .Shape.Height = h .Shape.Select True Selection.ShapeRange.Fill.UserPicture f .Visible = False End With Kill f Application.ScreenUpdating = True Set Shp = Nothing End Sub
6楼 fāi	空闲再做了一下不知是否符合要求请明示