Telefonszámunk: 1-472-0679

[Resolved] Kép beillesztése fájlba, választott almappából minden képet

Kezdőlap Fórumok Excel programozás [Resolved] Kép beillesztése fájlba, választott almappából minden képet

Topic Resolution: Resolved
7 bejegyzés megtekintése - 1-7 / 7
  • Szerző
    Bejegyzés
  • #10337
    Laszlosala
    Felhasználó

      Sziasztok!
      Van egy vba kódom, ami egy mappából az összes képet beteszi egy új munkalapra, egy mappa mélységből. De olyan megoldásra lenne szükségem, ami több almappát is tud kezelni. Kiválasztanám a legfelső mappát pl: 2023, majd végigmegy a benne lévő mappákon 2023-01;2023-02;…2023-12. tehát minden hónapban vannak bemappázva képek, azokat tegye be B oszlopba, objektumként, hogy google sheetsbe töltve is megjelenhessenek a képek. Ott a képhez hozzászólnának a kollégák, azért fontos a google sheetsre való feltöltés. a InsertPictureInCell() sajnos google sheetsen #VALUE hibát ad.
      ez a jelenlegi állapot, de nem kezel sub directory-kat.

      Sub InsertAllPicturesInFolder()
      http://dailydoseofexcel.com/archives/2004/06/01/column-widths-in-points/
      Application.ScreenUpdating = Fal`se

      Sheets.Add After:=ActiveSheet
      Columns(„B:B”).ColumnWidth = 37.43 / 5 * 3

      Columns(„A:A”).ColumnWidth = 15.86
      Dim MyDialog As FileDialog, MyFolder As String, MyFile As String, MyPic As String
      Dim r As Integer, x As Integer, y As Integer, w As Integer, h As Integer

      r = 1
      Set MyDialog = Application.FileDialog(msoFileDialogFolderPicker)
      If MyDialog.Show = -1 Then
      MyFolder = MyDialog.SelectedItems(1) & Application.PathSeparator
      MyFile = Dir(MyFolder)

      Do While MyFile <> „”
      r = r + 1
      Cells(r, 1).Value = MyFile
      With Cells(r, 2)
      .RowHeight = 200.25 / 5 * 2
      x = .Left
      y = .Top
      w = .Width
      h = .Height
      End With

      MyPic = MyFolder & MyFile
      ActiveSheet.Shapes.AddPicture MyPic, msoFalse, msoTrue, x, y, w, h
      MyFile = Dir
      Loop
      End If
      Columns(„A:A”).AutoFit

      Application.ScreenUpdating = True
      End Sub

      Köszönöm
      Laci

      #10338
      horvimi
      Adminisztrátor

        Szia!

        Erre a feladatra rekurzív algoritmust szoktak használni, ami saját magát hívja meg, amíg talál alkönytárat.
        Ehhez úgy láttam, hogy legtöbbször az FSO objektumot használják.
        Én erről az oldalról vettem egy mintát:
        https://exceloffthegrid.com/vba-code-loop-files-folder-sub-folders/
        A konkrét megoldás:
        Using File System Object (FSO) Late Binding – Method #2
        Két Sub van benne. Az első csak egy felkészülés, adatok és pozíciók megadása, a második az, ami a rekurzió.
        Egy kicsit hozzányúltam, hogy az első sub-ban megadott mappát vegye kiindulásnak, és az aktuális munkalapon az A1-es cellától lefelé, egymás alá listázza a mappa és almappák fájl útvonalait.
        Ott nyúltam hozzá ahol magyar kommentet látsz.

        Sub loopAllSubFolderSelectStartDirectory()
        
        Dim FSOLibrary As Object
        Dim FSOFolder As Object
        Dim folderName As String
        
        'Set the folder name to a variable
        folderName = "C:\Users\DELL\Documents\NovoData-Word-Excel\"
        
        'Set the reference to the FSO Library
        Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
        
        'Az aktuális munkalap A1-es cellájától írja ki a fájlok útvonalait
        'Elsőként törli az ott lévő tartalmat
        Range("A1").Select
        ActiveCell.CurrentRegion.Clear
        
        'Another Macro must call LoopAllSubFolders Macro to start
        LoopAllSubFolders FSOLibrary.GetFolder(folderName)
        
        End Sub
        
        'Don’t run the following macro, it will be called from the macro above
        
        Sub LoopAllSubFolders(FSOFolder As Object)
        
        Dim FSOSubFolder As Object
        Dim FSOFile As Object
        
        'For each subfolder call the macro
        For Each FSOSubFolder In FSOFolder.subfolders
            LoopAllSubFolders FSOSubFolder
        Next
        
        'For each file, print the name
        For Each FSOFile In FSOFolder.Files
        
            'Insert the actions to be performed on each file
            
            'Az aktuális cellába beírja az aktuális fájl útvonalát
            'Majd lép  akövetkező sorba
            ActiveCell.Value = FSOFile.Path
            ActiveCell.Offset(1, 0).Select
        
        Next
        
        End Sub

        Ha bemásolod egy modulba, majd az első sub-ban megváltoztatod a gyökér mappát, utána futtathatod.
        A többi már összerakható az eredeti kódod alapján.

        Imre

        #10339
        Laszlosala
        Felhasználó

          Adtam neked hozzáférést, valamiért online nem jelennek meg a képek.
          https://1drv.ms/x/s!AKrCutP4NFkaonY?e=QjK25G
          Hogyan lehet ebből a kódból elérni, hogy beledrótozza a képeket a fájlba?

          #10340
          horvimi
          Adminisztrátor

            Valami miatt nem férek hozzá, a link kattintásakor be akar jelentkeztetni, de nem fogadja el a Microsoft bejelentkezési adataimat. Különben ugyanazzal simán be tudok lépni a OneDrive-ra közvetlenül.

            Szóval mi a jelenség? Mi van a képek helyén?
            Gondolom a te kódodról beszélsz, tehát ezzel lehet valami gond?
            ActiveSheet.Shapes.AddPicture MyPic, msoFalse, msoTrue, x, y, w, h

            Helyi gépen nézve megcsinálja? Beilleszti a képeket, azok láthatók, csak Onedrive-on nem jelennek meg?
            Ha kézzel teszel be képet, és feltöltöd, akkor látszódik? Ha így látszódik, akkor esetleg vedd fel rögzítővel, és próbáld az használni a makróban.
            Milyen Excel verziót használsz?

            Imre

            #10341
            Laszlosala
            Felhasználó

              most már összeraktam és működik rendesen. köszönöm szépen.

              #10344
              horvimi
              Adminisztrátor

                Esetleg megosztanád velünk, hogy mi volt a fond, és mi lett a megoldás?
                Nem az egész kód, csak a lényeg.
                Így tudsz visszasegíteni. 🙂

                #10345
                Laszlosala
                Felhasználó

                  Banális hiba, elnéztem: egyszerre több mintafájllal kísérleteztem.
                  Összekevertem a kódrészleteket, és az insertpictureincell()-t használtam, aminek szüksége van a helyi elérésre.
                  ActiveSheet.Shapes.AddPicture MyPic, msoFalse, msoTrue, x, y, w, h kód esetén beágyazza a fájlba.

                7 bejegyzés megtekintése - 1-7 / 7
                • Be kell jelentkezni a hozzászóláshoz.