< návrat zpět

MS Excel


Téma: Vyhledávání souboru rss

Zaslal/a 26.7.2020 10:33

Dobrý den,
chtěl bych se zeptat mám kód:

Sub seznam()

Dim FSO As Object
Dim NalezenoF As Long
Dim NalezenoS As Long

Set FSO = CreateObject("Scripting.fileSystemObject")
Set START = FSO.getfolder(Range("C1"))
Set Subfold = START.subfolders

For Each f In START.subfolders
For Each soubor In f.Files
On Error Resume Next
NalezenoF = Range("a:a").Find(what:=soubor.Name, lookat:=xlWhole).Row
If Err.Number = 91 Then
Cells(Cells(65000, 1).End(xlUp).Row + 1, 1) = soubor.Name
End If
On Error GoTo 0
Next soubor
Next f

For Each s In START.Files
On Error Resume Next
NalezenoS = Range("a:a").Find(what:=s.Name, lookat:=xlWhole).Row
If Err.Number = 91 Then
Cells(Cells(65000, 1).End(xlUp).Row + 1, 1) = s.Name
End If
On Error GoTo 0
Next s

End Sub

A potřebuji, aby to vyhledalo soubory jen .jpg

A za druhé, aby to vyhledalo a nezobrazovalo to koncovky .jpg , .docx apod...

Moc Vám děkuji

Zaslat odpověď >

#047479
Fantasyk
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 vybrali
citovat
#047494
avatar
Dobrý den,
Mě to nefunguje.
Můžete mi prosím poslat přílohu.

Děkujicitovat
#047496
Fantasyk

Mati napsal/a:

Dobrý den,
Mě to nefunguje.
Můžete mi prosím poslat přílohu.

Děkuji

viz příloha

EDIT:
teď jsem si přečetl, že budeš chtít asi něco jiného..
pošli přílohu
Příloha: zip47496_vyhledavani-souboru.zip (18kB, staženo 20x)
citovat
#047497
elninoslov
Tu je príklad. Vzhľadom na pokročilú hodinu viac nerobím ...
Příloha: zip47497_dopln-zoznam-suborov-urciteho-typu.zip (20kB, staženo 21x)
citovat
#047499
avatar
Děkuji to je ono.

elninoslov napsal/a:

Tu je príklad. Vzhľadom na pokročilú hodinu viac nerobím ...Příloha: 47497_dopln-zoznam-suborov-urciteho-typu.zip (20kB, staženo 4x)


--------

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
#047500
elninoslov
A kde máte cesty k tým súborom? V predošlom makre ste nechcel, ani prípony, a teraz ich chcete. Treba uchovávať aj cesty. Ďalej, odkiaľ sa berie parameter "\obrazek1.jpg" ?...citovat
#047501
avatar

elninoslov napsal/a:

A kde máte cesty k tým súborom? V predošlom makre ste nechcel, ani prípony, a teraz ich chcete. Treba uchovávať aj cesty. Ďalej, odkiaľ sa berie parameter "\obrazek1.jpg" ?...


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ěkuji
Příloha: zip47501_ukazka.zip (33kB, staženo 17x)
citovat
#047503
elninoslov
Čítal ste čo píšem?
1. Odkiaľ má vedieť makro adresu obrázku, keď ju nikde nemáte uloženú ?
2. Priložte reálne vyzerajúcu prílohu ! Aj s pár obrázkami. Reálne rozloženie v liste!

Ja mám dojem, že máte skupiny buniek po 24 riadkoch a 7 stĺpcoch, a to pre každý obrázok. A tomu zodpovedajú zlúčené bunky v B:B. To je typ. To ale nekorešponduje s prvým makrom, čo som Vám dal na hľadanie obrázkov, lebo to ich zapisuje pod seba (nie každý 24. riadok).

Reálnu prílohu, šup.citovat
#047505
avatar
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ěkuji
Příloha: zip47505_ukazka-1.zip (384kB, staženo 19x)
citovat

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Helios iNuvio

Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.

On-line nástroje