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

zhaogang1960

1.答题前请先阅读最新规则:正式竞赛区运行规则说明
2.可跟贴直接发答案、上传答案附件

任选一题，方法不限，答案正确者可得分，欢迎广大VBA爱好者答题

评分：
1.总分2分。
2.精彩答案另加分。

截至日期：2011－11－21前



效果：





该贴已经同步到 zhaogang1960的微博

hjj0451

占住一楼，研究研究。

AVEL

1. Private Sub TextBox1_Change()
   
2.     Dim i%
   
3.     Dim rng As Range
   
4.     For i = 2 To Sheet1.[a65536].End(3).Row
   
5.         If Sheet1.Cells(i, 1).Value = VBA.Val(Me.TextBox1.Value) Then
   
6.             Application.ScreenUpdating = False
   
7.             Set rng = Sheet1.Cells(i, 1)
   
8.             rng(1, 2).CopyPicture
   
9.             With Sheet1.ChartObjects.Add(0, 0, rng(1, 2).Width, rng(1, 2).Height).Chart
   
10.                 .Paste
    
11.                 .Export ThisWorkbook.Path & "" & "tupian" & ".jpg", "JPG"
    
12.                 .Parent.Delete
    
13.             End With
    
14.             Me.Image1.Picture = LoadPicture(ThisWorkbook.Path & "" & "tupian.jpg")
    
15.             Application.ScreenUpdating = True
    
16.             Kill ThisWorkbook.Path & "" & "tupian.jpg"
    
17.         End If
    
18.     Next
    
19. End Sub

复制代码

AVEL

1. Private Sub TextBox1_Change()
   
2.     Dim i%
   
3.     Dim rng As Range
   
4.     For i = 1 To Sheet1.[a65536].End(3).Row
   
5.         If Sheet1.Cells(i, 1).Value = VBA.Val(Me.TextBox1.Value) Then
   
6.             Application.ScreenUpdating = False
   
7.             Application.DisplayCommentIndicator = xlCommentAndIndicator
   
8.             Set rng = Sheet1.Cells(i, 1)
   
9.            rng.Comment.Shape.CopyPicture
   
10.             With Sheet1.ChartObjects.Add(0, 0, rng.Comment.Shape.width, rng.Comment.Shape.height).Chart
    
11.                 .Paste
    
12.                 .Export ThisWorkbook.Path & "" & "tupian" & ".jpg", "JPG"
    
13.                 .Parent.Delete
    
14.             End With
    
15.             Me.Image1.Picture = LoadPicture(ThisWorkbook.Path & "" & "tupian.jpg")
    
16.             Application.DisplayCommentIndicator = xlCommentIndicatorOnly
    
17.             Application.ScreenUpdating = True
    
18.             Kill ThisWorkbook.Path & "" & "tupian.jpg"
    
19.         End If
    
20.     Next
    
21. End Sub

复制代码

附件有点大。。。

wcymiss

边查帮助边做的，老师看看这样符合要求不：

xmyjk

均API直接访问剪贴板，读取图片至图片控件中。采用这种方法的好处是，不需要导出图片成文件，再导入控件，另外直接从剪贴板访问图片，图片的质量也比较清晰。

题一：使用(BottomRightCell+TopLeftCell)/2确定图片准确的单元格位置，避免由于不小心移动了图片导致报错。

题二：程序使用了，如果rng.Comment.Shape.Fill.Type = msoFillPicture，来判断批注里面是否植入了自定义图片作为背景，保证了程序的稳定性。

oyzhjr

题一与题二基本一致，知道另存为的方法就可以了。

以下是代码，请高手指导

Private Sub TextBox1_Change()
Rem   ++++++++++++++++++++++++++算法说明++++++++++++++++++++++++++++++
'如果textbox1.text 不为空，则进行查找
'查找所在行的行号，选中整行
'另存temp为网页文件
'Image1的路径设定为图片文件的路径
'删除TEMP文件

Dim FSO
Dim row_get As Integer
Dim xuehao As String
Dim rnga As Range
Dim js_a As Integer

xuehao = TextBox1.Text
If xuehao = "" Then Exit Sub
With ThisWorkbook.ActiveSheet
    js_a = 1
    Do
        If .Cells(js_a, 1).Value = xuehao Then
            row_get = js_a
            Exit Do
        End If
        js_a = js_a + 1
        If js_a = 1000 Then                 '防错
            Exit Sub
        End If
    Loop
   
    Set rnga = .Range(.Cells(row_get, 1), .Cells(row_get, 3))
    rnga.Select
End With

ThisWorkbook.PublishObjects.Delete
With ThisWorkbook.PublishObjects.Add(xlSourceRange, ThisWorkbook.Path & "\temp.htm", "Sheet1", rnga.Address, xlHtmlStatic, "temp", "")
    .Publish (True)
    .AutoRepublish = False
End With

Image1.Picture = LoadPicture(ThisWorkbook.Path & "\temp.files\temp_image002.jpg")

On Error Resume Next
Set FSO = CreateObject("Scripting.FileSystemObject")            '用FSO删除多余的文件及目录
FSO.DeleteFolder ThisWorkbook.Path & "\temp.files", True
FSO.DeleteFile ThisWorkbook.Path & "\temp.htm", True

Rem ==============================================================
End Sub

小fisher

请问楼主，Image控件调用工作表单元格图片，是指调用单元格内包含的shape还是单元格在屏幕上显示的图片？

zm0115

这题似乎比多表查询简单，但为什么答题人这么少？是不是我哪里做的不符合要求？

1. Private Sub TextBox1_Change()
   
2. Dim t
   
3. Dim rng As Range
   
4. Me.Image1.Picture = LoadPicture()
   
5. For Each rng In Range("a2:a4")
   
6.     If Me.TextBox1.Text = rng Then
   
7.         t = ThisWorkbook.Path & "\test.gif"
   
8.         rng.Offset(0, 1).CopyPicture xlScreen, xlPicture
   
9.         With Sheet1.ChartObjects.Add(0, 0, Me.Image1.Width, Me.Image1.Height).Chart
   
10.         .Paste
    
11.         .Export t, "gif"
    
12.         .Parent.Delete
    
13.         End With
    
14.         Me.Image1.Picture = LoadPicture(t)
    
15.         Kill t
    
16.     Exit For
    
17.     End If
    
18. Next
    
19. End Sub
    

复制代码

wyf22006

交上答案在附件中