[es] - promjena slike prema zadanom kriteriju

novmar

Član broj: 221598
Poruke: 30
*.novi-net.net.

Profil

promjena slike prema zadanom kriteriju

^{04.02.2015. u 14:59 - pre 124 meseci}

Pozdrav, nikako da nađem rješenje...

imam kreiranu tabelu/top listu od 40 pjesama i kad se promijeni ime izvođača da se promijeni slika i veličina slike (jpg) koja je u folderu C:\slike (slike su istog naziva kao i izvođači)
izvođači su u F9, F12, F15, itd, a slike u spojenoj čeliji G9+10, G11+12, G14+15, itd...

Prikačeni fajlovi

TOP.jpg - 112.49k

Odgovor na temu

Ivek33

Član broj: 66174
Poruke: 2898

+66 Profil

Re: promjena slike prema zadanom kriteriju

^{04.02.2015. u 23:26 - pre 124 meseci}

vidi da li ti mogu pomoći ove teme

- http://www.elitesecurity.org/t348872-0#2147089
- http://www.elitesecurity.org/t478876-0#3482839
- Automatski prikaz slike u ćeliji na osnovu vrijednosti u susjednoj ćeliji
- Prikazivanje slike sa drugog radnog lista u Excelu na osnovu šifre

Ako nije previše slika a neda ti se kopati po folderu, možeš ih insertirati na drugi Sheet pa povlačiti na glavni sheet

Odgovor na temu

novmar

Član broj: 221598
Poruke: 30
46.229.250.*

Profil

Re: promjena slike prema zadanom kriteriju

^{05.02.2015. u 19:00 - pre 124 meseci}

super. puno si pomogao. trebam još jednu stvar u codu.
kad nema slike u folderu od zadanog izvođača da uvijek koristi sliku C:\Pictures\NO ARTIST.jpg

Code:
Sub Image()
Worksheets("print").DrawingObjects.Delete

Dim picname As String

Dim pasteAt As Integer
Dim lThisRow As Long

    lThisRow = 9

    Do While (Cells(lThisRow, 6) <> "")


        pasteAt = lThisRow
        Cells(pasteAt, 1).Select 'This is where picture will be inserted


        picname = Cells(lThisRow, 6) 'This is the picture name

        present = Dir("C:\Pictures\" & picname & ".jpg")

        If present <> "" Then

            ActiveSheet.Pictures.Insert("C:\Pictures\" & picname & ".jpg").Select 'Path to where pictures are stored
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''
            ' This resizes the picture
            '''''''''''''''''''''''''''''''''''''''''''''''''''''''
            With Selection
            '.Left = Range("A6").Left
            '.Top = Range("A6").Top
            .Left = Cells(pasteAt - 1, 7).Left
            .Top = Cells(pasteAt - 1, 7).Top

            .ShapeRange.LockAspectRatio = msoFalse
            .ShapeRange.Height = 32#
            .ShapeRange.Width = 32#
            .ShapeRange.Rotation = 0#
            End With



        Else
            Cells(pasteAt, 7) = "No Picture Found"
        End If

           lThisRow = lThisRow + 3
    Loop

    Range("A10").Select
    Application.ScreenUpdating = True

    Exit Sub

ErrNoPhoto:
    MsgBox "Unable to Find Photo" 'Shows message box if picture not found
    Exit Sub
    Range("B20").Select

End Sub

_{[Ovu poruku je menjao novmar dana 05.02.2015. u 20:16 GMT+1]}

_{[Ovu poruku je menjao novmar dana 05.02.2015. u 20:43 GMT+1]}

Odgovor na temu

Jpeca
Predrag Jovanović
poslovni analitičar
Gowi
Pančevo

Moderator
Član broj: 25683
Poruke: 2286
212.200.121.*

Sajt: www.gowi.rs

+112 Profil

Re: promjena slike prema zadanom kriteriju

^{06.02.2015. u 10:32 - pre 124 meseci}

Nisam probao kod ali ako to radi onda samo između Else i End if umesto

Cells(pasteAt, 7) = "No Picture Found"

kopiraj sve redove između If i Else, pa zameni

ActiveSheet.Pictures.Insert("C:\Pictures\" & picname & ".jpg").Select

sa:
ActiveSheet.Pictures.Insert("C:\Pictures\NO ARTIST.jpg").Select

Naravno, kod bi mogao da se sredi da se izbegne dupliranje, ali probaj prvo ovako

Nije to loše Rembrante, samo što ne bi dodao još malo boje?

Odgovor na temu