[原创]图片缩放工具 （第三版）

andysky

以前发表过两个图片缩放工具。
http://club.excelhome.net/viewthread.php?tid=255785&extra=&page=1#255785
第一版
特点：单击单元格放大图片，单击其它单元格则缩小原图片
http://club.excelhome.net/viewthread.php?tid=262152&extra=&page=1#262152
第二版
特点：单击可以放大图片，单击另一个图片，原图片缩小，当前图片放大。同时单元格随图片一起缩放，不会覆盖其它图片
今天分享第三版
特点：
1.鼠标移过就可以将图片放大；
2.移到下一张图片时，则下一张图片放大，前一张缩小；
3.移到非工作区，则将所有图片恢复原来大小
4.可以指定缩放的倍数
5.制作成加载宏，可以将本工具运用在任何工作簿中。提升通用性。
开放所有代码，让每个用户可以自己修改。
安装方式：下载文件-->解压-->打开Excel-->Alt+T+I打开加载宏对话框-->浏览-->双击加载宏文件(.xla格式)即安装完毕。
请看演示：

[原创]图片缩放工具 （第三版）

andysky

代码下：

你也可以只管使用，不改代码。

Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Type POINTAPI
    X As Long
    Y As Long
End Type
Dim 开关 As Boolean
Dim 原图
Dim 当前图
Sub 停止缩放()
    开关 = True
End Sub
Sub 单击缩放图片()
    Dim 座标 As POINTAPI, temp As Byte
    temp = Application.InputBox("你希望放大几倍？", "放大选项", 3, , , , , 1)
    If temp < 2 Or temp > 10 Then MsgBox "请输入2到10 ！": Exit Sub
    On Error Resume Next
    开关 = False
    Do
        If 开关 = True Then Exit Do
        GetCursorPos 座标
        On Error Resume Next
        Set 当前图 = ActiveWindow.RangeFromPoint(座标.X, 座标.Y)
        If 当前图 Is Nothing Then
         If Not 原图 Is Nothing Then
            With 原图
                .ZOrder msoBringToFront
                .Width = 80
                .Height = 50
                .TopLeftCell.Offset(0, 1).RowHeight = 50
            End With
            End If
        Else
            If 当前图.Name <> 原图.Name Then
                With 当前图
                    .ZOrder msoBringToFront
                    .Width = 80 * temp
                    .Height = 50 * temp
                    .TopLeftCell.Offset(0, 1).RowHeight = 50 * temp
                End With
                With 原图
                    .ZOrder msoBringToFront
                    .Width = 80
                    .Height = 50
                    .TopLeftCell.Offset(0, 1).RowHeight = 50
                End With
            End If
        End If
        Set 原图 = 当前图
        On Error GoTo 0
        DoEvents
    Loop
    开关 = False
End Sub

fclyjzyk

好玩,定下_

欢欢excel

真是厉害的角色!!!excel无所不能了

 

 

BIN_YANG168

感谢罗兄分享。

gvntw

谢谢！

办公之星

不错，支持支持了。

andysky

QUOTE:

以下是引用办公之星在2008-5-6 18:25:19的发言：
不错，支持支持了。

你好久未露面了

sxz

安装方式：下载文件-->解压-->打开Excel-->Alt+T+I打开加载宏对话框-->浏览-->双击加载宏文件(.xla格式)即安装完毕。

我想能否可以进一步完善，不需要加载宏文件（不出现弹出对话框，强制启用宏），因为我想用这个做一个报表！

大家都明白行政领导的电脑水平一般比较洼！更因为领导需要更智能傻瓜点的材料

[此贴子已经被作者于2008-5-7 10:36:39编辑过]

bengdeng

呵呵，是很好玩，美中不足的是图片在放大与缩小的时候都设定为80/50，单元格的高度也是，其实多设定三个变量保存这三个原始数据，用来还原就可以了。

Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Type POINTAPI
    X As Long
    Y As Long
End Type
Dim 开关 As Boolean
Dim 原图
Dim 当前图
Dim XW As Integer, XH As Integer, XR As Integer
Sub 停止缩放()
    开关 = True
End Sub
Sub 单击缩放图片()
    Dim 座标 As POINTAPI, temp As Byte
    temp = Application.InputBox("你希望放大几倍？", "放大选项", 3, , , , , 1)
    If temp < 2 Or temp > 10 Then MsgBox "请输入2到10 ！": Exit Sub
    On Error Resume Next
    开关 = False
    Do
        If 开关 = True Then Exit Do
        GetCursorPos 座标
        On Error Resume Next
        Set 当前图 = ActiveWindow.RangeFromPoint(座标.X, 座标.Y)
        If 当前图 Is Nothing Then
            If Not 原图 Is Nothing Then
                With 原图
                    .ZOrder msoBringToFront
                    .Width = 80
                    .Height = 50
                    .TopLeftCell.Offset(0, 1).RowHeight = 50
                End With
            End If
        Else
            If 当前图.Name <> 原图.Name Then
                With 原图
                    .ZOrder msoBringToFront
                    .Width = XW
                    .Height = XH
                    .TopLeftCell.Offset(0, 1).RowHeight = XR
                End With
                With 当前图
                    XW = .Width
                    XH = .Height
                    XR = .TopLeftCell.Offset(0, 1).RowHeight
                    .ZOrder msoBringToFront
                    .Width = .Width * temp
                    .Height = .Height * temp
                    .TopLeftCell.Offset(0, 1).RowHeight = .Height
                End With
            End If
        End If
        Set 原图 = 当前图
        On Error GoTo 0
        DoEvents
    Loop
    开关 = False
End Sub

收藏!!