请大神帮忙完善一下工程进度计划监督表

逆天修炼

坛内的各位高人：

我工作中碰到需要监督工程进度，把每天的施工人数按工作内容输入到表格中并附上现场的图片，我搞了个文件但是使用不完美，请坛里的大神帮忙修改一下，谢谢！
问题如下：
1、插入图片：要求不指定单元格，在目前活动单元格里插入。其次，需要插入的图片可否自动检测当前目标单元格的行高与列宽，不需在VB代码中设定。
2、图片不清晰：我的程序中插入图片到表格中显示清晰，但文件在别的电脑打开点击放大，显示不清晰，不知何故？是否是对插入缩小的图片进行了压缩，再放大显示就不清晰的缘故？
3、移动图片：需要增加一个VB过程，点击VB删除图片按钮，即可选择任一图片移动到目标单元格，并自动适应行高列宽进行填充。
4、压缩图片：我的程序中压缩图片，每次是对工作表中所有图片进行压缩，可否改为仅对当次插入图片即压缩当前图片？插入前压缩，保证图片放大后的清晰度。
5、插入图片，压缩图片，可否放一个VB过程中？

拜谢各位大佬帮忙解决一下！

逆天修炼

有哪位大神帮忙解决一下

02761752696

逆天修炼 发表于 2022-11-24 00:19
有哪位大神帮忙解决一下

一二四条问题简单修改，供参考

02761752696

第三条和放大缩小有冲突，先研究下
如：操作方式：先点击目标单元格，再点击图片，自动已过去，这样操作比较合理，现在和放大缩小冲突了

02761752696

打了个草稿，移动和缩放  加个开关，待完善

逆天修炼

第二条有关清晰度的问题，插入时不进行压缩，但只要关闭文件再找开时，点击图片仍然不清晰

逆天修炼

02761752696 发表于 2022-11-24 11:07
第三条和放大缩小有冲突，先研究下
如：操作方式：先点击目标单元格，再点击图片，自动已过去，这样操作比 ...

大神，还有一个问题，同一行的照片放大时，不能正确关闭，就像打地鼠一样，压下这个冒起那个

逆天修炼

有关图像的清晰度问题，我查了百度，选择文件－选项－高级，勾选“不压缩文件中的图像”，excel中插入图像过程不选压缩，保存退出后再打开文件，发现图片清晰度还是很好。

逆天修炼

我把代码分享出来，供大家参考
1、关键：菜单－－选项－－高级－－勾选“不压缩文件中的图片”
2、为避免文件容量过大，可以采用iSee软件对图片进行压缩预处理，插入过程中弹出对话框，也可以勾选对插入的图片进行压缩，但没有iSee软件高效

Sub 插入图片()
Dim sh As Shape, C As Range
Application.Dialogs(xlDialogInsertPicture).Show
If TypeName(Selection) = "Picture" Then
    CommandBars("Picture").Controls(10).Execute
    'Set C = Application.InputBox("请选择单元格", Type:=8)
    'C.ColumnWidth = 5     '单元格列宽
    'C.RowHeight = 20      '单元格行高
    Set C = ActiveCell
        With Selection
            ActiveSheet.Shapes(ActiveSheet.Shapes.Count).LockAspectRatio = msoFalse
            ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Width = C.Width
            ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Height = C.Height
            ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Left = C.Left
            ActiveSheet.Shapes(ActiveSheet.Shapes.Count).Top = C.Top
            .OnAction = "test"
            .Name = ActiveCell.Address(0, 0)
        End With
End If
End Sub

Sub test()
    On Error Resume Next
    For Each a In ActiveSheet.Shapes
        nm = Application.Caller
        If nm <> "I1" Then
        If a.Name = nm Then
            If a.AlternativeText = Empty Then
                a.AlternativeText = a.Height & Chr(28) & a.Width
                a.Height = a.Height * 27
                a.Width = a.Height * 1
                a.ZOrder msoBringToFront
            Else
                a.Height = Split(a.AlternativeText, Chr(28))(0)
                a.Width = Split(a.AlternativeText, Chr(28))(1)
                a.AlternativeText = Empty
            End If
            Err.Clear
        End If
        End If
    Next
End Sub

Sub 删除图片()
Dim p As Shape
For Each p In ActiveSheet.Shapes
If p.Type = 13 Then p.Delete
Next
End Sub

Sub 隐藏图片()
For i = 1 To ActiveSheet.Shapes.Count
    ActiveSheet.Shapes(i).Visible = msoFalse
Next i
End Sub

Sub 显示图片()
For i = 1 To ActiveSheet.Shapes.Count
    ActiveSheet.Shapes(i).Visible = msoTrue
Next i
End Sub