|
|
本帖最后由 andyleeq 于 2018-9-7 18:45 编辑
用野路子做了个图片复制并存为图片的函数，但图片质量不高，怎么破
以下同代码，能运行，但请大侠指定
Function mycopypict(copyrng As Range, Optional targetrng, Optional pictname As String = "N")
'
' 参数：copyrng 要复制的区域range ; targetrng 要粘贴到的目标区域 ；range，pictname 要保存的文件名
'
'
Dim mytest, mytt, fd, Xfd As Byte
On Error GoTo err_go1 '判断copyrng是否存在单元格，报错就是没有,野路子
mytest = copyrng.Address
On Error GoTo err_go4
mytt = Sheets("TOPshow").Range("AJ3").Value 'AJ3 是一个单元格，上面可以写入文件路径到mytt
If Dir(mytt & "\") = "" Then
MsgBox (mytt & "\" & "不存在，请检查网络，或重新选择文件夹")
Set fd = Application.FileDialog(msoFileDialogFolderPicker) '允许用户选择一个文件夹
If fd.Show = -1 Then
'On Error Resume Next
MsgBox fd.SelectedItems(1)
mytt = fd.SelectedItems(1) '选择之后就记录这个文件夹名称
Else
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit Function '否则就退出程序
End If
End If
On Error GoTo err_go2 '判断targetrng是否存在单元格，报错就是没有,野路子
If Not IsMissing(targetrng) Then
mytest = targetrng.Address
End If
On Error GoTo err_go3
'MsgBox VarType(pictname)
'On Error Resume Next
Dim ls, ts, w, h As Single
w = copyrng.Width: h = copyrng.Height
If pictname = "N" Then pictname = Format(Now(), "yyyymmddhhmm") '判断pictname 缺省时，用时间为文件名
With copyrng '复制区域
.Parent.Activate
.CopyPicture
End With
'a = Format(Now(), "yyyymmddhhmm")
If IsMissing(targetrng) Then '没有粘贴目标区域时，就将左上边界设为0
ls = 0
ts = 0
'Range("zz1").Select
'MsgBox "no"
Else
'MsgBox "tar yes"
With targetrng '有粘贴目标区域时，就将左上边界设为区域边界
ls = .Left
ts = .top
.Parent.Activate
.Select
End With
'delect pict________________________________________将粘贴区域上的现存的图片删除
For Each shp In ActiveSheet.Shapes
Set theCell = shp.TopLeftCell
'a1 = shp.Name
'a2 = "Rectangle"
'a3 = InStr(a1, a2)
'If a3 = 1 Then shp.Delete
If Not Intersect(targetrng, theCell) Is Nothing Then shp.Delete
Next shp
'copy pict________________________________________
Set theCell = Nothing
End If
Set ownshp = ActiveSheet.Pictures.Paste '在目标区域粘贴第一个图片
With ActiveSheet.ChartObjects.Add(ls, ts, w, h).Chart '临时加一个绘图对象并复制，导出，并删除
.Paste
.Export mytt & "\" & pictname & ".jpg"
.Parent.Delete
End With
If IsMissing(targetrng) Then ownshp.Delete '如果没有目标对象参数，就将第一个图片也删除
If Not Dir(mytt & "\" & pictname & ".jpg") = "" Then
MsgBox "成功保存到：" & mytt & "\" & pictname & ".jpg"
Else
MsgBox "未保存成功"
End If
Exit Function
err_go1:
MsgBox ("复制区域参数不是RANGE对象")
Exit Function
err_go2:
MsgBox ("粘贴区域参数不是RANGE对象")
Exit Function
err_go3:
MsgBox ("不知名错误")
Exit Function
err_go4:
MsgBox ("文件保存问题")
Exit Function
Exit Function
err_go6:
MsgBox ("not here 6")
Exit Function
End Function
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2018-9-7 18:41
楼主
