【83期】Image控件调用工作表单元格图片或批注图片[已小结]

liuguansky · 发表于 2011-11-8 12:18

本帖最后由 liuguansky 于 2011-11-8 12:27 编辑

Private Declare Function OpenClipboard Lib "User32" (ByVal hWnd As Long) As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function GetClipboardData Lib "User32" (ByVal uFormat As Long) As Long
Private Declare Function CopyEnhMetaFileA Lib "Gdi32" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function DeleteEnhMetaFile Lib "Gdi32" (ByVal hdc As Long) As Long
Private Sub TextBox1_Change()
Dim rng As Range, Fp$
If Len(TextBox1.Text) Then
Set rng = Range("A:a").Find(TextBox1.Text, , , xlWhole)
If Not rng Is Nothing Then
Application.ScreenUpdating = False
Fp = "C:\Liuguansky.Bmp"
rng.Comment.Visible = True
rng.Comment.Shape.CopyPicture xlScreen, xlPicture
rng.Comment.Visible = False
OpenClipboard 0
DeleteEnhMetaFile CopyEnhMetaFileA(GetClipboardData(14), Fp)
CloseClipboard
Application.CutCopyMode = False
Image1.Picture = LoadPicture(Fp)
Image1.PictureSizeMode = fmPictureSizeModeZoom
Application.ScreenUpdating = True
Else: Image1.Picture = LoadPicture()
End If
End If
End Sub

复制代码

onthetrip2008 · 发表于 2011-11-9 14:42

一个附件太大，还传不上来

shaowu459 · 发表于 2011-11-9 23:38

跟帖答题，谢谢。

岁寒三友 · 发表于 2011-11-11 09:57

跟着赵老师学习了！

lg_cai · 发表于 2011-11-13 00:30

代码是copy的小fisher的，不会告我侵犯版权吧。

hzhb14796 · 发表于 2011-11-13 09:07

功能是达到了

minjiwei · 发表于 2011-11-19 04:14

请查阅附件。谢谢！
持续关注楼主答案。

HadesBoss · 发表于 2011-11-19 10:47

上不了大附件。
代码：
模块1：

Sub Click()
Dim x, y
Dim i As Integer
Dim gifname As String
Dim Mych As ChartObject
Dim rng As Range
With Sheet1
For Each rng In .Range(.Range("A1"), .Range("A65536").End(xlUp))
With rng.Comment
.Visible = 1
.Shape.Select
.Shape.CopyPicture xlScreen, xlPicture
.Visible = 0
x = .Shape.Width
y = .Shape.Height
End With
gifname = rng.Value
With ActiveSheet.ChartObjects.Add(0, 0, x, y).Chart
.Paste
.Export ThisWorkbook.Path & "" & gifname & ".gif", "Gif"
'这里book.path可以定义一个独立的文件夹
.Parent.Delete
End With
Next
End With
Set Mych = Nothing
End Sub

复制代码

窗体代码：
Private Sub TextBox1_Change()
Dim MyPath As String
Dim MyPic
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path & "\" & TextBox1.Value & ".Gif"
MyPic = Dir(MyPath)
If MyPic <> "" Then
Me.Image1.Picture = LoadPicture(MyPath)
End If
Application.ScreenUpdating = True
End Sub

Private Sub UserForm_Initialize()
Application.ScreenUpdating = False
Call Click
Application.ScreenUpdating = True

End Sub

HadesBoss · 发表于 2011-11-19 10:48

批注图片题，附件太大上不了。
代码：
窗体代码：Private Sub TextBox1_Change()
Dim MyPath As String
Dim MyPic
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path & "\" & TextBox1.Value & ".Gif"
MyPic = Dir(MyPath)
If MyPic <> "" Then
Me.Image1.Picture = LoadPicture(MyPath)
End If
Application.ScreenUpdating = True
End Sub

Private Sub UserForm_Initialize()
Application.ScreenUpdating = False
Call Click
Application.ScreenUpdating = True

End Sub

模块1 代码：
Sub Click()
Dim x, y
Dim i As Integer
Dim gifname As String
Dim Mych As ChartObject
Dim rng As Range
With Sheet1
      For Each rng In .Range(.Range("A1"), .Range("A65536").End(xlUp))
         With rng.Comment
            .Visible = 1
            .Shape.Select
            .Shape.CopyPicture xlScreen, xlPicture
            .Visible = 0
            x = .Shape.Width
            y = .Shape.Height
         End With
         gifname = rng.Value
         With ActiveSheet.ChartObjects.Add(0, 0, x, y).Chart
            .Paste
            .Export ThisWorkbook.Path & "\" & gifname & ".gif", "Gif"
            '这里book.path可以定义一个独立的文件夹
            .Parent.Delete
         End With
      Next
End With
Set Mych = Nothing
End Sub

zhaogang1960 · 发表于 2011-11-22 15:25

截至日期已到，谢谢各位参与答题，已测试各位代码，全部正确，恭喜所有答题会员：

		自动登录	找回密码
密码			免费注册

[Excel 程序开发] 【83期】Image控件调用工作表单元格图片或批注图片[已小结]

本帖子中包含更多资源

评分

本帖子中包含更多资源

评分

本帖子中包含更多资源

点评

评分

本帖子中包含更多资源

点评

评分

本帖子中包含更多资源

评分

本帖子中包含更多资源

评分

本帖子中包含更多资源

评分

评分

评分

本帖子中包含更多资源