wps表格嵌入式照片如何用代码调用

xzf_eng

求助各位大神，如何将WPS表格中的嵌入式照片调用到VBA的窗体中，再如何从VBA窗体中调用回WPS表格

user湫

WPS这个批量插入图片，应该是存储到云端的。通过函数调用，如果需要嵌入，不考虑云端调用的话，

1. Private Sub CommandButton3_Click()
   
2.     Dim arr, i&, k&, n&, b As Boolean
   
3.     Dim strPicName$, strPicPath$, strFdPath$, shp As Shape
   
4.     Dim rngData As Range, rngEach As Range, rngWhere As Range, strWhere As String
   
5.     On Error Resume Next
   
6.     '——————————————————————————————————————————————
   
7.     '用户选择图片所在的文件夹
   
8.     With Application.FileDialog(msoFileDialogFolderPicker)
   
9.         If .Show Then strFdPath = .SelectedItems(1) Else: Exit Sub
   
10.     End With
    
11.     If Right(strFdPath, 1) <> "" Then strFdPath = strFdPath & ""
    
12.     Set rngData = Application.InputBox("请选择图片名称所在的单元格区域", Type:=8)
    
13.     '用户选择需要插入图片的名称所在单元格范围
    
14.     Set rngData = Intersect(rngData.Parent.UsedRange, rngData)
    
15.     'intersect语句避免用户选择整列单元格，造成无谓运算的情况
    
16.     If rngData Is Nothing Then MsgBox "选择的单元格范围不存在数据！": Exit Sub
    
17.     strWhere = InputBox("请输入图片偏移的位置，例如上1、下1、左1、右1", , "右1")
    
18.     '用户输入图片相对单元格的偏移位置。
    
19.     If Len(strWhere) = 0 Then Exit Sub
    
20.     X = Left(strWhere, 1)
    
21.     '偏移的方向
    
22.     If InStr("上下左右", X) = 0 Then MsgBox "你未输入偏移方位。": Exit Sub
    
23.     Y = Val(Mid(strWhere, 2))
    
24.     '偏移的值
    
25.     Select Case X
    
26.     Case "上"
    
27.         Set rngWhere = rngData.Offset(-Y, 0)
    
28.     Case "下"
    
29.         Set rngWhere = rngData.Offset(Y, 0)
    
30.     Case "左"
    
31.         Set rngWhere = rngData.Offset(0, -Y)
    
32.     Case "右"
    
33.         Set rngWhere = rngData.Offset(0, Y)
    
34.     End Select
    
35.     Application.ScreenUpdating = False
    
36.     rngData.Parent.Parent.Activate '用户选定的激活工作簿
    
37.     rngData.Parent.Select
    
38.     For Each shp In ActiveSheet.Shapes
    
39.         '如果旧图片存放在目标图片存放范围则删除
    
40.         If Not Intersect(rngWhere, shp.TopLeftCell) Is Nothing Then shp.Delete
    
41.     Next
    
42.     X = rngWhere.row - rngData.row
    
43.     Y = rngWhere.Column - rngData.Column
    
44.     '偏移的坐标
    
45.     arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")
    
46.     '用数组变量记录五种文件格式
    
47.     For Each rngEach In rngData
    
48.         '遍历选择区域的每一个单元格
    
49.         strPicName = rngEach.Text
    
50.         '图片名称
    
51.         If Len(strPicName) Then
    
52.             '如果单元格存在值
    
53.             strPicPath = strFdPath & strPicName
    
54.             '图片路径
    
55.             b = False
    
56.             '变量标记是否找到相关图片
    
57.             For i = 0 To UBound(arr)
    
58.                 '由于不确定用户的图片格式，因此遍历图片格式
    
59.                 If Len(Dir(strPicPath & arr(i))) Then
    
60.                     '如果存在相关文件
    
61.                     Set shp = ActiveSheet.Shapes.AddPicture( _
    
62.                         strPicPath & arr(i), False, True, _
    
63.                         rngEach.Offset(X, Y).Left + 5, _
    
64.                         rngEach.Offset(X, Y).Top + 5, _
    
65.                         20, 20)
    
66.                     shp.Select
    
67.                     With Selection
    
68.                         .ShapeRange.LockAspectRatio = msoFalse
    
69.                         '撤销锁定图片纵横比
    
70.                         .Height = rngEach.Offset(X, Y).Height - 10 '图片高度
    
71.                         .Width = rngEach.Offset(X, Y).Width - 10 '图片宽度
    
72.                     End With
    
73.                     b = True '标记找到结果
    
74.                     n = n + 1 '累加找到结果的个数
    
75.                     Range("a1").Select: Exit For '找到结果后就可以退出文件格式循环
    
76.                 End If
    
77.             Next
    
78.             If b = False Then k = k + 1 '如果没找到图片累加个数
    
79.         End If
    
80.     Next
    
81.     Application.ScreenUpdating = True
    
82.     MsgBox "共处理成功" & n & "个图片，另有" & k & "个非空单元格未找到对应的图片。"
    
83.     Me.Label10.Caption = Sheets(Me.Label5.Caption).Shapes.Count '刷新计数
    
84.    
    
85.     '反馈
    
86.     Me.Frame1.Caption = "反馈：导入完成!"
    
87.     Me.Frame1.Font.Bold = True
    
88.     Me.Frame1.ForeColor = &HFF00&
    
89.     Me.Frame1.Font.Size = 10
    
90.    
    
91. End Sub
    
92. 
    

复制代码

user湫

1. Private Sub CommandButton4_Click()
   
2.     If ActiveSheet.ProtectContents Then MsgBox "工作表已保护,本程序拒绝执行！", 64, "提示": Exit Sub
   
3.     Dim TypeName%, str$   '用于判断图片格式的变量
   
4.     Dim fd As FileDialog, folder$ '文件路径对象和变量
   
5.     Dim rng As Range, cell As Range '选择的区域单元格对象
   
6.     Dim r As Range '选择的区域单元格对象 此处用于判断选取的区域是否为空
   
7.     Dim j%, i%, s$, n%, k%
   
8.     Dim w!, m!
   
9.     '——————————————————————————————————————————————
   
10. Restar:
    
11.     Set r = Selection.Find("*", , , , , xlPrevious)
    
12.     If r Is Nothing Then MsgBox "不能选择空白区", 64, "提示": Exit Sub
    
13.     Set r = Nothing
    
14.     TypeName = Application.InputBox("输入1：插入GIF 图片；" + Chr(10) + "输入2：插入PNG 图片；" + Chr(10) + "输入3：插入JPG 图片；" + Chr(10) + "输入4：插入JPEG图片。", "图片格式", 3, , , , , 1)
    
15.    
    
16.     If TypeName = False Then
    
17.         Exit Sub
    
18.     ElseIf TypeName < 1 Or TypeName > 4 Then
    
19.         MsgBox "输入错误": GoTo Restar
    
20.     End If
    
21.    
    
22.     str = VBA.Choose(TypeName, "*.gif", "*.png", "*.jpg", "*.jpeg") '根据输入的数字决定选用图片格式
    
23.     Set rng = Application.Intersect(ActiveSheet.UsedRange, Selection)
    
24.     Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    
25.     If fd.Show = -1 Then folder = fd.SelectedItems(1) Else Exit Sub '如果选择了路径提取路径全名否则退出程序
    
26.     On Error Resume Next
    
27.     'rng.ClearComments '清除选区的所有批注
    
28.     Err.Clear
    
29.    
    
30.     i = ActiveCell.RowHeight
    
31. star:
    
32.     j = Application.InputBox("请输入你希望照片显示的高度," & Chr(10) & "当前单元格高度为" & i & "，请根据需要按比例输入新高度。" & Chr(10) & "程序将把单元格的高度与宽度调整为同样大小。", "【确认照片高度】", i, , , , , 1)
    
33.     If Err <> 0 Then Err.Clear: MsgBox "输入不规划，请重新输入": GoTo star
    
34.     'If j = False Then Exit Sub
    
35.     If j <= 0 Then j = i
    
36.     Application.ScreenUpdating = False
    
37.    
    
38.    
    
39.     For Each cell In rng '遍历选区
    
40.         cell.Activate
    
41.         
    
42.         If cell <> "" Then
    
43.             
    
44.             If Dir(folder & "" & cell.Text & Mid(str, 2)) <> "" Then
    
45.                 'ActiveSheet.Pictures.Insert(folder & "" & cell.Text & Mid(str, 2)).Select
    
46.                 ActiveSheet.Shapes.AddPicture(folder & "" & cell.Text & Mid(str, 2), False, True, 0, 0, -1, -1).Select
    
47.                
    
48.                
    
49.                 With Selection
    
50.                     If j = 0 Then
    
51.                         .Placement = xlMoveAndSize '图片大小、位置都随单元格而变
    
52.                         .ShapeRange.LockAspectRatio = msoFalse '不锁定图片纵横比
    
53.                         
    
54.                         .Top = ActiveCell.Offset(0, 1).Top + 2
    
55.                         .Left = ActiveCell.Offset(0, 1).Left + 2
    
56.                         .Height = ActiveCell.Height - 2
    
57.                         .Width = ActiveCell.Width - 2
    
58.                         Columns(ActiveCell.Column).AutoFit
    
59.                         
    
60.                         
    
61.                     Else
    
62.                         .ShapeRange.LockAspectRatio = msoTrue '锁定图片纵横比
    
63.                         .Top = ActiveCell.Offset(0, 1).Top + 2
    
64.                         .Left = ActiveCell.Offset(0, 1).Left + 2
    
65.                         .Height = j
    
66.                         '.Width = ActiveCell.Width
    
67.                         w = .Width
    
68.                         
    
69.                         ActiveCell.RowHeight = j + 4
    
70.                         'ActiveCell.Offset(0, 1).ColumnWidth = CInt(((w + 2) * 4.374 / 27.682) + 1)
    
71.                         
    
72.                         cell.Offset(1, 0).Select '选择下一单元格
    
73.                         If w > m Then m = w
    
74.                         
    
75.                     End If
    
76.                 End With
    
77.                
    
78.                
    
79.                
    
80.                
    
81.             Else
    
82.                 s = s + cell.Text & Mid(str, 2) & Chr(10)
    
83.                 n = n + 1 '记录未找到的图片数
    
84.                 'ActiveCell.RowHeight = j + 2
    
85.                 cell.Offset(1, 0).Select '选择下一单元格
    
86.             End If
    
87.             k = k + 1  '记录非空单元格个数
    
88.         End If
    
89.     Next
    
90.    
    
91.     If m > 0 Then ActiveCell.Offset(0, 1).ColumnWidth = m / 6.016887
    
92.     '6.016887
    
93.     If n = 0 Then
    
94.         MsgBox "完成！图片已经全部导入！", 64, "提示"
    
95.     Else
    
96.         MsgBox "完成！" & Chr(10) & "需要导入图片" & k & "张" & Chr(10) & "成功导入图片" & k - n & "张" & Chr(10) & "未找到对应图片" & n & "张:" & Chr(10) & s, 64, "提示"
    
97.     End If
    
98.     Set rng = Nothing
    
99.     Application.ScreenUpdating = True
    
100.    
     
101.     '反馈
     
102.     Me.Frame1.Caption = "反馈：导入完成!"
     
103.     Me.Frame1.Font.Bold = True
     
104.     Me.Frame1.ForeColor = &HFF00&
     
105.     Me.Frame1.Font.Size = 10
     
106. End Sub
     
107. 
     

复制代码

这二个是控件调用的 稍微改一下就好了

xzf_eng

感谢大神