图片处理

zjc5102

图片处理，求助大神！

3190496160

Sub 插入图片()
Application.ScreenUpdating = False    '屏幕闪烁关闭
Dim shp
With Sheets("sheet1")
    For Each shp In .Pictures
        If shp.TopLeftCell.Column < 7 Then
            shp.Delete
        End If
    Next shp
    ar = .UsedRange
    For i = 1 To UBound(ar)
        For j = 1 To UBound(ar, 2)
            If Trim(ar(i, j)) <> "" Then
                If IsNumeric(ar(i, j)) Then
                    tp = Dir(ThisWorkbook.Path & "\图片\" & ar(i, j) & ".png")
                    If tp <> "" Then
                        .Cells(i, j).Select
                        cellL = ActiveCell.Left + 3
                        cellT = ActiveCell.Top
                        Set shpPic = ActiveSheet.Shapes.AddPicture(ThisWorkbook.Path & "\图片\" & tp, msoFalse, msoTrue, cellL, cellT, 1, 1)
                        shpPic.Top = .Cells(i, j).Top + 1
                        shpPic.Left = .Cells(i, j).Left + 1
                        shpPic.Width = .Cells(i, j).Width - 1
                        shpPic.Height = .Cells(i, j).Height - 1
                        Set shpPic = Nothing
                    End If
                End If
            End If
        Next j
    Next i
End With
Application.ScreenUpdating = True '屏幕闪烁打开
MsgBox "ok"
End Sub

3190496160

求助.rar (1.98 MB, 下载次数: 22)

2023-1-6 10:25 上传

点击文件名下载附件

3190496160

只写了插入图片的代码，至于合并图片，非一时之功，等有时间再看看吧

iu950

单元格插入与导出图片

aman1516

试试：

1. Sub GetPic()
   
2.     Dim myfile$, rng As Range, na As String
   
3.     On Error Resume Next
   
4.     Application.DisplayAlerts = False
   
5.     Application.ScreenUpdating = False     '——导出空白图片，可把这句也注释掉也试试，但会闪屏
   
6.     Call DelShp
   
7.     For Each rng In Sheet1.Range("A1:E7")
   
8.         If rng <> "" Then
   
9.         na = rng.Value
   
10.         myfile = ThisWorkbook.Path & "\图片" & na & ".png"
    
11.         If Dir(myfile) <> "" Then
    
12.            Sheet1.Shapes.AddPicture(myfile, False, True, rng.Left, rng.Top, rng.Width, rng.Height).Select
    
13.                Selection.Name = na
    
14.         End If
    
15.         End If
    
16.     Next
    
17.     Call LoadPic
    
18.     Application.ScreenUpdating = True
    
19.     Application.DisplayAlerts = True
    
20. End Sub
    
21. 
    
22. Sub DelShp()
    
23.     Dim shp As Shape
    
24.     For Each shp In Sheet1.Shapes
    
25.         If shp.Type = 13 Then shp.Delete
    
26.     Next
    
27. End Sub
    
28. <blockquote>
    

复制代码

aman1516

详见附件：

aecn

aman1516 发表于 2023-1-6 12:08
详见附件：

Win10+2016(32) 合并的图片为空白图

aman1516

aecn 发表于 2023-1-6 12:16
Win10+2016(32) 合并的图片为空白图

WIN7+2007 结果
没对应系统测试，楼上附件已更新，再看下

iu950

win7+office2016 导出图片会有空白