M&M" <"mikulamali2(brisi) wrote:
> Molba za B&S ili nekoga tko zna i ima vremena da prilagodi makro u
listu koje imaju nastavak JPG dodaje sliku kao hiperlink 3 reda ispod te
Evo ti u prilogu 'moj' test, pa ako ti se da pogledaj.
ps
Sretna nova godina tebi i tvojim najmilijima!
--
pozdrav!
Berislav
>
> makro je skinut s http://www.elitesecurity.org/t348872-0#2147089 i za
>
> upisanog naziva.
>
> npr. ako je naziv upisan u I1 onda thumbnails treba umetnutu u I4 (kao
> na istu...
>
> valjda sam ja to dobro objasnio, unaprijed zahvaljujem
>
>
> VBA Code:
>
> Sub Test()
> ' Za sve popunjene celije u koloni A
> ' Dodaje sliku kao hiperlink u koloni B
> Dim cl As Range
> Dim sh As Worksheet
> Dim rw As Long, rwstart As Integer, rwend As Long
> Dim path As String
>
> Set sh = ActiveSheet ' Uzima se aktivni list
> path = "F:\My Documents\My Pictures\" ' Ovde zadati folder
> rwstart = 1 ' Ovde zadati pocetni red
> rwend = sh.Cells(16555, 1).End(xlUp).Row
> sh.Columns(2).ColumnWidth = 13.57 ' Podesava se sirina
> kolone na 100 piksela
> For rw = rwstart To rwend
> Set cl = ActiveSheet.Cells(rw, 2)
> cl.Rows(1).RowHeight = 75 ' Podesava se visina reda
> na 100 piksela
> InsertPictureInRange path & cl.Offset(ColumnOffset:=-1).Text &
> ".jpg", cl
> Next
> End Sub
>
> Sub InsertPictureInRange(PictureFileName As String, TargetCells As
> ' zatim dodaje Hiperlink
> ' Prepravljeno sa exceltip.com
>
> Dim p As Object, s As Shape
> Dim t As Double, l As Double, w As Double, h As Double
> If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
> If Dir(PictureFileName) = "" Then Exit Sub
> ' Umetanje slike
> Set p = ActiveSheet.Pictures.Insert(PictureFileName)
> ' Odredjivanje pozicije
> With TargetCells
> t = .Top
> l = .Left
> w = .Offset(0, .Columns.Count).Left - .Left
> h = .Offset(.Rows.Count, 0).Top - .Top
> End With
> ' Pozicioniranje slike
> With p
> .Top = t
> .Left = l
> .Width = w
> .Height = h
> End With
> ' Kao argument Anchor za hiperlink treba da se prenese shape
> TargetCells.Worksheet.Hyperlinks.Add Anchor:=p.ShapeRange(1), _
> Address:=PictureFileName
> Set p = Nothing
> End Sub
test.txt
Sub Test()
' Za sve celije na listu koje imaju nastavak JPG
' Dodaje sliku kao hiperlink 3 reda ispod te celije
Dim cl As Range
Dim sh As Worksheet
Dim path As String
Dim cc As Range
Set sh = ActiveSheet ' Uzima se aktivni list
path = "C:\slike\" ' Ovde zadati folder
For Each cc In ActiveSheet.UsedRange
If InStr(cc, "jpg") Then
Set cl = ActiveSheet.Cells(cc.Row + 3, cc.Column)
Rows(cc.Row + 3).RowHeight = 75 ' Podesava se visina reda na 100 piksela
sh.Columns(cc.Column).ColumnWidth = 13.57 ' Podesava se sirina kolone na 100 piksela
InsertPictureInRange path & cl.Offset(-3, 0).Text, cl
End If
Next
End Sub
|
|