resim getirme

[EXTRANET]

arkadaşlar aşağıdaki mako ile a9 hücresine kod no yazdığımda a1 hücresine resim getiriyorum. resmin birde teknik resmi var b1 hücresinede teknik resminin gelmesini istiyorum.

teknik resmin olduğu dosya "teknik resim"

yardımlarınızı bekliyorum.

Private Sub Worksheet_Change(ByVal Target As Range)
ActiveSheet.DrawingObjects.Delete
Range("a1").Select
resimadi = LoadPicture("")
resimadi = Range("A9").Text & ".jpg"
On Error Resume Next
ActiveSheet.Pictures.Insert("C:\Documents and Settings\admin\Belgelerim\Resimlerim\" & resimadi).Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 330 'yükseklik
Selection.ShapeRange.Width = 400 'genişlik
Selection.ShapeRange.Rotation = 0#
Range("a9").Select
End Sub

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim yol As String, adres1 As String, adres2 As String, rsm As Shape
 
    yol = "C:\Documents and Settings\admin\Belgelerim\Resimlerim\"
    adres1 = yol & "" & Range("A1") & ".jpg"
    adres2 = yol & "" & Range("B1") & ".jpg"
 
    Application.ScreenUpdating = False
    On Error Resume Next
 
    For Each rsm In ActiveSheet.Shapes
       If rsm.Name = "Resim 1" Or _
        rsm.Name = "Resim 2" Then rsm.Delete
    Next rsm
 
    Range("A1").Select
    With ActiveSheet.Pictures.Insert(adres1)
        .Name = "Resim 1"
        .ShapeRange.LockAspectRatio = msoFalse
        .ShapeRange.Height = 330
        .ShapeRange.Width = 400
        .ShapeRange.Rotation = 0#
    End With
 
    Range("B1").Select
    With ActiveSheet.Pictures.Insert(adres2)
        .Name = "Resim 2"
        .ShapeRange.LockAspectRatio = msoFalse
        .ShapeRange.Height = 330
        .ShapeRange.Width = 400
        .ShapeRange.Rotation = 0#
    End With
    Range("A9").Select
 
End Sub

.