Automatsko ubacivanje jpeg-a u text box

Automatsko ubacivanje jpeg-a u text box 20.12.2011. u 15:15 · pre 181 mesec #1

Nisam najbolje nazvao temu, ali evo o čemu se radi.

Kada pokrenem macro, želim da mi se importuje neka određena fotografija i automatski resize-uje u veličinu ćelije ili text boxa, a da pri tom zadrži proporcionalne dimenzije.
Dakle u nekom folderu imam fotke 1,2,3,4,5 i 6, i one treba da se importuju i pravilno rasporede po stranici.

Ja sam pokrenuo snimanje macro-a, ručno mišem namestio dimenzije i rasporedio ih po stranici onako kako treba. Kada obrišem fotke, i pokrenem macro, to lepo radi.
Ali problem nastaje kada neke druge fotografije koje overwrite-ujem preko tih fotografija, a nisu istih dimenzija ni proporcija. Tada mi macro importuje fotke, promeni im veličinu i rasporedi ih, ali ne onako kako želim.

Rešenje problema bi možda bilo, kada bih mogao da napravim textbox ili odredim dimenzije neke ćelije, pa da se importuje slika u njih i resize-uje proporcionalno maksimalno koliko dozvoljava textbox ili celija.

Da li imate neku ideju?

Re: Automatsko ubacivanje jpeg-a u text box 20.12.2011. u 22:39 · pre 181 mesec #2

daj okaci to sto si probao da uradis, pa da vidimo sta treba doraditi

Potpis

[email protected]=

Re: Automatsko ubacivanje jpeg-a u text box 21.12.2011. u 09:36 · pre 181 mesec #3

Ovo sam samo pritisnuo na rec macro, i namestio im velicinu i rasporedio ih.
Mozda ne bi bilo lose recimo da mi širina fotke može biti najviše 10 cm, a visina 14cm.
I da se recimo prvo prati uslov visina na 14 cm, i ako proporcionalna sirina ne prelazi 10 cm onda je to to...
A ako prelazi sirina 10cm, onda da je to primarni uslov, a visina moze biti manja od 14cm.

E sad ne znam kako bi mogla pozicija na papiru. Papir je 950x650mm. Kako bi moglo to da se namesti da fotka pocinje uvek na istom mestu? Po pikselima ili?

Code:
Sub slicice()
'
' slicice Macro
' Macro recorded 20.12.2011 by deco01.st24
'

'
    ActiveSheet.Pictures.Insert("("D:\#Provereno NOVO\XLS\1.jpg"). _
        Select
    Selection.ShapeRange.IncrementLeft -375#
    Selection.ShapeRange.IncrementTop -685.5
    Selection.ShapeRange.ScaleWidth 0.46, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.46, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleWidth 0.89, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.89, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.IncrementLeft 48#
    Selection.ShapeRange.ScaleWidth 0.95, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.96, msoFalse, msoScaleFromTopLeft
    ActiveSheet.Pictures.Insert("("D:\#Provereno NOVO\XLS\2.jpg"). _
        Select
    Selection.ShapeRange.IncrementLeft 516#
    Selection.ShapeRange.IncrementTop -675.75
    Selection.ShapeRange.ScaleWidth 0.7, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.7, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleWidth 0.97, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.97, msoFalse, msoScaleFromBottomRight
    ActiveSheet.Pictures.Insert("("D:\#Provereno NOVO\XLS\3.jpg"). _
        Select
    Selection.ShapeRange.IncrementLeft -321#
    Selection.ShapeRange.IncrementTop -63.75
    Selection.ShapeRange.ScaleWidth 0.74, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.73, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.IncrementLeft 63#
    Selection.ShapeRange.IncrementTop -3.75
    ActiveSheet.Pictures.Insert("("D:\#Provereno NOVO\XLS\4.jpg"). _
        Select
    Selection.ShapeRange.ScaleWidth 2#, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleWidth 0.5, msoFalse, msoScaleFromBottomRight
    Selection.ShapeRange.ScaleWidth 0.44, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.44, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.Flip msoFlipHorizontal
    Selection.ShapeRange.IncrementLeft -393#
    Selection.ShapeRange.IncrementTop 25.5
    ActiveSheet.Pictures.Insert("("D:\#Provereno NOVO\XLS\5.jpg"). _
        Select
    Selection.ShapeRange.ScaleWidth 0.44, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.44, msoFalse, msoScaleFromBottomRight
    Selection.ShapeRange.IncrementLeft -246#
    Selection.ShapeRange.IncrementTop -6.75
    Selection.ShapeRange.IncrementLeft -24#
    Selection.ShapeRange.IncrementTop 38.25
    ActiveWindow.SmallScroll Down:=12
    ActiveSheet.Pictures.Insert("D:\#Provereno NOVO\XLS\6.jpg"). _
        Select
    Selection.ShapeRange.IncrementLeft 459#
    Selection.ShapeRange.IncrementTop 561#
    Selection.ShapeRange.ScaleWidth 0.74, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.ScaleHeight 0.74, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.IncrementLeft 39#
    Selection.ShapeRange.IncrementTop 28.5
    Selection.ShapeRange.ScaleWidth 0.86, msoFalse, msoScaleFromBottomRight
    Selection.ShapeRange.ScaleHeight 0.87, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.IncrementLeft -34.5
End Sub

Re: Automatsko ubacivanje jpeg-a u text box 21.12.2011. u 13:33 · pre 181 mesec #4

Pošto si makro snimao pretpostavljam da nisi gledao kako se zadatak rešavao u starijim temama.

Brzom pretragom sam izdvojio ove dve: automatizovano ubacivanje slika u Excelu i automatski thumbnails.

Potpis

Have you found helpful examples, solutions or ideas-in-work, please consider the
following:
• Citation of *actual page* you are going to using is welcome.
• Have you saw "Value Added" examples you are going to incorporate to your
profitable blog, daily job or any money making venture: How about online donation?
↗Ana & Vlade Divac Foundation
Hvala!

Re: Automatsko ubacivanje jpeg-a u text box 21.12.2011. u 14:17 · pre 180 meseci #5

Ima u prethodnom linku koji je 3okc naveo jedna varijanta ali ona menja dimenzije ćelije.

Evo jedna verzija koja izabranu sliku smesta na zadatu adresu i proporcionalno je menja veličinu

Code:
Sub DodajSliku()
' Dodaje izabranu sliku u celiju i
' proporcionalno menja velicinu prema celiji
'
'
    Dim PicLocation As String
    Dim MyRange As Range

    Set MyRange = Application.InputBox(prompt:="Selektuj celiju za sliku", Type:=8)
    MyRange.Cells(1, 1).Select

    PicLocation = Application.GetOpenFilename("Image Files (*.jpg),*.jpg", , "Select Image File", , "False")

    If PicLocation <> "False" Then
        ActiveSheet.Pictures.Insert(PicLocation).Select
    Else
        Exit Sub
    End If
    With Selection.ShapeRange
        .LockAspectRatio = msoTrue
        If .Width > .Height Then
            .Width = MyRange.Width
            If .Height > MyRange.Height Then .Height = MyRange.Height
        Else
            .Height = MyRange.Height
            If .Width > MyRange.Width Then .Width = MyRange.Width
        End If
    End With

End Sub

Potpis

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

Re: Automatsko ubacivanje jpeg-a u text box 21.12.2011. u 14:50 · pre 180 meseci #6

To je izgleda to. Mislim na automatski thumbnails. Ali ne mogu da se snadjem. Samo sto ja ne zelim da mi se resajzuje celija, nego fotka da se prilagodi celiji.

Sorry Jpeca, nisam video da si napisao nesto. sad cu da pogledam to

Re: Automatsko ubacivanje jpeg-a u text box 21.12.2011. u 15:02 · pre 180 meseci #7

Jpeca

izbacuje mi Debug na

Code:
ActiveSheet.Pictures.Insert(PicLocation).Select

Re: Automatsko ubacivanje jpeg-a u text box 21.12.2011. u 15:42 · pre 180 meseci #8

Izgleda da sam prilikom copy/paste nekako izbrisao "n" iz naziva promenljive PicLocation. Ispravio sam u prethodnom postu. Zbog ovakvih greski dobro je da se na početku modula stavi Option Explicit, pa će se u tom slučaju proveravati da li su sve promenljive deklarisane

Potpis

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

Re: Automatsko ubacivanje jpeg-a u text box 22.12.2011. u 08:35 · pre 180 meseci #9

Super. Ali iako merge-ujem ćelije, on meni tu jednu merge-iovanu ne vidi kao jednu, nego ga resize-uje

http://imageshack.us/photo/my-images/220/aaajc.jpg

Da li postoji mogućnost da se ubaci u textbox kojem sam već odredio veličinu?

I kako to da namestim automatski? Pošto su mi uvek iste ćelije, i uvek fotke sa istim imenom sa istog mesta.

Re: Automatsko ubacivanje jpeg-a u text box 22.12.2011. u 11:09 · pre 180 meseci #10

Evo odradio sam ti neki primer, u kome klikom na dugme "Ubaci sliku" otvarati se dijalog prozor u kome biras koju ces sliku da ubacis a zatim ti se pojavljuje Inpit box u kome upisujes adresu celije u kojoj ces ubaciti sliku, naravno srazmerno umanjenu umanjenu ako je to potrebno. Nadam se da je to to.

Potpis

[email protected]=

CoyoteKG-FOX028.xls31.5k

Re: Automatsko ubacivanje jpeg-a u text box 22.12.2011. u 13:02 · pre 180 meseci #11

Ovo što je Fox uradio čini mi se isto slično kao što sam prethodno uradio. Koliko sam razumeo ti nećeš ništa da biraš, nega da ti se slika sa neke fiksne lokacije ubaci u text box

Code:
Sub UbaciSliku2()
' Ubacuje sliku sa fiksne lokacije
' u prvi text box na aktivnom listu
' Dimenzije slike ostaju proporcionalne
' P.Jovanovic za EliteSecurity
'
    Dim textbox As Shape, Pic As IPictureDisp
    Const picfile As String = "C:\My Documents\My Pictures\TTT.JPG"  ' Ovde unesi putanju za sliku koju ubacujes

    Set Pic = LoadPicture(picfile)
    ' Pronalazenje prvog tekst boxa na aktivnom listu
    For Each textbox In ActiveSheet.Shapes
       If textbox.Type = msoTextBox Then Exit For
    Next textbox
    If textbox Is Nothing Then
       MsgBox "Na aktivnom listu ne postoji textbox", vbOK, "Greska"
       GoTo Kraj
    End If
    ' Promena dimenzije textboxa tako  da se cuvaju proporcije slike
    If Pic.Height / textbox.Height > Pic.Width / textbox.Width Then
        textbox.Width = Pic.Width / Pic.Height * textbox.Height   ' promeni sirinu
    Else
        textbox.Height = Pic.Height / Pic.Width * textbox.Width  ' promeni visinu
   End If
   With textbox.Fill
     .Visible = True
     .UserPicture picfile
     .RotateWithObject = True
    End With

Kraj:
   ' Uklanjanje slike iz memorije
   Set Pic = LoadPicture("")
   Set Pic = Nothing

End Sub

Potpis

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

Re: Automatsko ubacivanje jpeg-a u text box 27.12.2011. u 10:15 · pre 180 meseci #12

Hvala ljudi.
Pretpostavljam da je to to.
Nikako da uhvatim vremena da pokušam.
Javljam vam se!

Forum kao aplikacija na telefonu

Srodne teme