MS Excel

Tímto si otevřeš DISK Z: a vyhledávaš na něm pozde soubory JPG

With Application.FileDialog(msoFileDialogFilePicker) 'spustí dialogové okno pro otevření
.InitialFileName = "Z:\" 'nastavení úvodní složky procházení
.Title = "Vyber adresár" 'nastavení názvu okna
.Filters.Add "Soubory pouze JPG (jpg)", "*.JPG*", 1 'nastavení filtru pro zobrazení souborů
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Nebyly nacteny žádné soubory": Exit Sub 'pokud není vybrán žádný soubor, makro vypíše hlášení a ukončí se
ElseIf .SelectedItems.Count > 1 Then
MsgBox "Vyberte pouze jeden soubor!": Exit Sub 'pokud je vybráno více, než jeden soubor, makro vypíše hlášení a ukončí se
Else
zdrojovy_soubor = .SelectedItems(1) ' načte adresu souboru do proměnné
End If
End With
Workbooks.Open (zdrojovy_soubor) ' otevření souboru, který jsme vybralicitovat

viz příloha

EDIT:
teď jsem si přečetl, že budeš chtít asi něco jiného..
pošli přílohucitovat

Děkuji to je ono.


--------

Ještě bych se chtěl zeptat na kód, který zobrazí obrázky jenomže potřebuji, aby to zobrazovalo obrázky ne jen ze složky, ale i podsložek.

Kód je:

Sub TestVlozitObrazek()

Dim rngOblastObrazek As Range
Dim strCestaSouborObrazek As String

'definice oblasti pro vložení obrázku
Set rngOblastObrazek = Worksheets("List1").Range("I2:O25")

'zdroj obrázku
strCestaSouborObrazek = ThisWorkbook.Path & "\obrazek1.jpg"
'strCestaSouborObrazek = ThisWorkbook.Path & "\obrazek2.jpg"
'strCestaSouborObrazek = ThisWorkbook.Path & "\obrazek3.jpg"
'strCestaSouborObrazek = ThisWorkbook.Path & "\obrazek4.jpg"
'strCestaSouborObrazek = ThisWorkbook.Path & "\obrazek5.jpg"
'strCestaSouborObrazek = ThisWorkbook.Path & "\obrazek6.jpg"
'strCestaSouborObrazek = ThisWorkbook.Path & "\obrazek7.jpg"
'strCestaSouborObrazek = ThisWorkbook.Path & "\obrazek8.jpg"
'strCestaSouborObrazek = ThisWorkbook.Path & "\obrazek9.jpg"
'strCestaSouborObrazek = ThisWorkbook.Path & "\obrazek10.jpg"

'vymazání případných původních obrázků v oblasti
Call OblastSmazatObjekty(rngOblastObrazek)

'vložení obrázku do oblasti
'vycentrování v obou směrech a nevynucené přizpůsobení
'tj. větší obrázky se zmenší, menší obrázky se nezvětší
Call VlozitObrazek(strCestaSouborObrazek, rngOblastObrazek, True, _
True, False)

End Sub

Sub VlozitObrazek(ByVal strSouborObrazek As String, ByVal rngOblastVlozeni As _
Range, Optional ByVal bNaStredVodorovne As Boolean = False, Optional ByVal _
bNaStredSvisle As Boolean = False, Optional ByVal bZvetsitMensi As Boolean = _
False)

Dim objObrazek As Object
Dim dOblastShora As Double
Dim dOblastZleva As Double
Dim dOblastSirka As Double
Dim dOblastVyska As Double
Dim dObrazekSirka As Double
Dim dObrazekVyska As Double
Dim dPomerSirky As Double
Dim dPomerVysky As Double
Dim dPomerMax As Double

'zamezení překreslování obrazovky
Application.ScreenUpdating = False

'vložení obrázku
Set objObrazek = ActiveSheet.Pictures.Insert(strSouborObrazek & ".jpg")
'rozměry oblasti pro vložení
With rngOblastVlozeni
dOblastShora = .Top
dOblastZleva = .Left
dOblastSirka = .Width
dOblastVyska = .Height
End With

'původní rozměry obrázku
With objObrazek
dObrazekSirka = .Width
dObrazekVyska = .Height
End With

'maximální poměr (převrácená hodnota měřítka)
dPomerSirky = dObrazekSirka / dOblastSirka
dPomerVysky = dObrazekVyska / dOblastVyska
dPomerMax = WorksheetFunction.Max(dPomerSirky, dPomerVysky)

'je potřeba obrázek zmenšit nebo je požadováno
'zvětšení malých obrázků do velikosti oblasti?
'poměr stran zachován vždy
If (dPomerMax > 1) Or (bZvetsitMensi = True) Then
'zmenšení (zvětšení)
dSirka = dObrazekSirka / dPomerMax
dVyska = dObrazekVyska / dPomerMax
Else
'ponechání rozměrů
dSirka = dObrazekSirka
dVyska = dObrazekVyska
End If

dShora = dOblastShora
dZleva = dOblastZleva

'vodorovné vycentrování?
If bNaStredVodorovne Then
dZleva = dZleva + dOblastSirka / 10 - dSirka / 10
End If

'svislé vycentrování?
If bNaStredSvisle Then
dShora = dShora + dOblastVyska / 10 - dVyska / 10
End If

'nastavení obrázku
With objObrazek
.Top = dShora
.Left = dZleva
.Width = dSirka
.Height = dVyska
End With

'odstranění proměnné z paměti
Set objObrazek = Nothing

'překreslení obrazovky
Application.ScreenUpdating = True

End Sub

Sub OblastSmazatObjekty(ByVal rngOblast As Range)

Dim shpObjekt As Shape

With rngOblast.Parent

'pro každý objekt kolekce Shapes na listu
For Each shpObjekt In .Shapes

'jestliže horní levý roh objektu leží v oblasti
If Not Application.Intersect(shpObjekt.TopLeftCell, rngOblast) Is _
Nothing Then
'a je-li objekt typu obrázek
If (shpObjekt.Type = msoPicture) Or (shpObjekt.Type = _
msoLinkedPicture) Then
'odstranění obrázku
shpObjekt.Delete
End If
End If

Next shpObjekt

End With

End Sub

Děkujicitovat

Dobrý den,
vyhledávání souborů je OK
Ale ty obrázky, aby se zobrazili musejí být v jedné složce, bohužel je mám rozdělené Hlavní složka a pak jsou podsložky v té dané složce.
Potřebuji, aby se obrázky zobrazovali i když jsou v podsložce což mi nejde.

V příloze zasílám vzor.

Děkujicitovat

V příloze zasílám ukázku.
Včetně hlavní složky a podsložek.

Samozřejmě sešit bude na ploše a obrázky umístěné ve složce na příklad G:\Rodina

To co jste mi poslal v příloze bylo na vyhledávání souboru bez koncovky to je OK.
Zapracoval jsem to makro do sešitu obrázků a podle jména obrázku by se měl daný obrázek zobrazit což funguje pokud jsou obrázky v jedné složce jenomže je mám i v podsložkách a to mi neukazuje.

Děkujicitovat