|
|
本帖最后由 lss001 于 2024-9-29 09:03 编辑
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Type PicBmp
Size As Long
Type As Long
hbmp As LongPtr
hpal As Long
Reserved As Long
End Type
Private Declare PtrSafe Function OleCreatePictureIndirect _
Lib "oleaut32.dll" (PicDesc As PicBmp, RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, IPic As Any) As Long
Private Declare PtrSafe Function CLSIDFromString _
Lib "ole32" (ByVal Str As LongLong, id As GUID) As Long
Private Declare PtrSafe Function GetClipboardData _
Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
Private Declare PtrSafe Function OpenClipboard _
Lib "user32" (ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard _
Lib "user32" () As Long
Const CF_BITMAP = 2
Sub picGropTop()
Dim sht As Sheet1, tJ As GUID, pit As Object
Dim pic As PicBmp, hBp As LongPtr, ft!, tp!
Dim tName$, pName$, r$, s$, t$, p$, f$, d
Dim IPic As StdPicture, pf As PictureFormat
Set sht = ActiveSheet
p = ThisWorkbook.Path & "\原图片" '指定打开文件夹
s = ThisWorkbook.Path & "\新图片" '指定保存文件夹
f = Dir(p & "\*.jpeg") '指定图片类型
While f <> ""
sht.Range("A1").Select
Set pit = sht.Pictures.Insert(p & "\" & f)
pName = pit.Name: pit.Select
Set pf = Selection.ShapeRange.PictureFormat
pf.CropTop = 100 '上部裁剪100
r = pit.TopLeftCell.Address '地址
ft = pit.TopLeftCell.Left + 15 '位置
tp = pit.TopLeftCell.Top + 10
sht.Range(r).Select
t = "ABCD" '指定文字
With sht.Shapes.AddTextEffect( _
31, t, "宋体", 24, 0, 0, ft, tp)
.TextFrame.Characters.Font.Color = VBA.vbRed
.TextFrame.AutoSize = True
tName = .Name
.Select
End With
With sht.Shapes.Range(Array(pName, tName)).Group
Application.CutCopyMode = False
.Copy '复制图片
OpenClipboard 0& '打开剪贴板
hBp = GetClipboardData(CF_BITMAP) '获取数据
CloseClipboard '关闭剪贴板
If hBp Then
CLSIDFromString StrPtr( _
"{00020400-0000-0000-C000-000000000046}"), tJ
With pic '填充结构
.Size = Len(pic) '结构大小
.Type = 1 '图形类型
.hbmp = hBp '位图句柄
.hpal = 0 '设置Pallete
End With
d = Timer: While Timer < d + 1: DoEvents: Wend
OleCreatePictureIndirect pic, tJ, 1, IPic
SavePicture IPic, s & "\" & f '保存
End If
.Delete '删除
End With
f = Dir
Wend
Set pf = Nothing '释放
Set pit = Nothing
MsgBox "已完成！"
End Sub
|
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-9-26 22:48
楼主