---

StucklistemitExporttool_01.zip

Hallo ich bin ein absoluter Neuling...
Bin auf Suche nach einem Makro das folgende Voraussetzungen erfüllen soll:
Aus einer Exceldatei, wo ich die Dateinamen eingetragen habe, sollen die freigegebenen Fremdformate (PDF, DXF und Step) im PDM gesucht werden. Es funktioniert einigermaßen.
Mein Problem besteht darin. Das ich nicht alle Dateien als "Vorhanden" zurückbekomme. Die Dateien liegen alle im PDM-Ordner. Wir haben verschiedenen Hauptordner mit mehreren Unterordnern. Den einen "Weg" liest es aus aber nicht den anderen.
Schön wäre auch noch bei Zeichnungen die als einzelne DXF-Dateien abgeleitet werden. Die folge Seiten auch noch mit in Suche aufzunehmen.
Wir haben schon ein Makro aber da kommen nicht alle Infos zurück.
Wäre super, wenn mir hier jemand helfen könnte…
Den Orginalcode habe ich hierher:
https://www.herber.de/forum/archiv/1784to1788/1786970_Dateien_anhand_Liste_suchen_und_kopieren.html

Option Explicit
Public Sub CopyFiles()
'1.) Ordnerpfad definieren
  Dim strFolderPath As String
  strFolderPath = "C:\Export\"
  ' Überprüfen, ob Ordner bereits existiert
  If Dir(strFolderPath, vbDirectory) = "" Then
    ' Ordner anlegen
    MkDir (strFolderPath)
    MsgBox "Ordner wird angelegt!"
  Else
    MsgBox "Ordner ist vorhanden!"
  End If
 
'2.) Ordner befüllen
  Const INPUT_PATH As String = "C:\SWx_PDM\"  'Anpassen !!! Backslash am _
Ende nicht löschen
    Const OUTPUT_PATH As String = "C:\Export\" 'Anpassen !!! _Backslash am Ende nicht löschen
    Dim astrFolders() As String, strFilename As String
    Dim avntValues As Variant, vntItem As Variant
    Dim ialngFolders As Long, ialngIndex As Long, lngCount As Long
    Dim objDictionary As Object
    Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
    Range(Cells(2, 2), Cells(Rows.Count, 2)).ClearContents
    avntValues = Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp)).Value2
    With objDictionary
        For ialngIndex = LBound(avntValues) To UBound(avntValues)
            If Not .Exists(Key:=avntValues(ialngIndex, 1)) Then
                Call .Add(Key:=avntValues(ialngIndex, 1), Item:=ialngIndex + 1)
            Else
                Cells(ialngIndex + 1, 2).Value = ""
            End If
        Next
        astrFolders = GetFolders(INPUT_PATH)
        For Each vntItem In .Keys
            lngCount = 0                                                                            'Schleife für .PDF Export'
            For ialngFolders = LBound(astrFolders) To UBound(astrFolders)
                strFilename = Dir$(astrFolders(ialngFolders) & vntItem & "*.pdf")
                If strFilename <> vbNullString Then
                    Call FileCopy(Source:=astrFolders(ialngFolders) & strFilename, Destination:= _
OUTPUT_PATH & strFilename)
                    lngCount = 1                                                                    'Schleife für .step Export'
                End If
                strFilename = Dir$(astrFolders(ialngFolders) & vntItem & "*.step")
                If strFilename <> vbNullString Then
                    Call FileCopy(Source:=astrFolders(ialngFolders) & strFilename, Destination:= _
OUTPUT_PATH & strFilename)
                    lngCount = 2
                End If
                strFilename = Dir$(astrFolders(ialngFolders) & vntItem & "*.dxf")                    'Schleife für .dxf Export'
                If strFilename <> vbNullString Then
                    Call FileCopy(Source:=astrFolders(ialngFolders) & strFilename, Destination:= _
OUTPUT_PATH & strFilename)
                    lngCount = lngCount + 1
                End If
                If lngCount = 3 Then Exit For
            Next
            If lngCount = 0 Then
                Cells(.Item(Key:=vntItem), 2).Value = "Nicht vorhanden"
            Else
                Cells(.Item(Key:=vntItem), 2).Value = "Vorhanden"
            End If
        Next
    End With
    Set objDictionary = Nothing
End Sub
Private Function GetFolders(ByVal pvstrPath As String) As String()
    Dim astrFolders() As String
    Dim strFolder As String, strPath As String
    Dim ialngIndex1 As Long, ialngIndex2 As Long
    ReDim Preserve astrFolders(ialngIndex1)
    astrFolders(ialngIndex1) = pvstrPath
    ialngIndex1 = 1
    ialngIndex2 = 1
    strPath = pvstrPath
    Do
        strFolder = Dir$(PathName:=strPath & "*", Attributes:=vbDirectory)
        Do Until strFolder = vbNullString
            If strFolder <> "." And strFolder <> ".." Then
                If GetAttr(PathName:=strPath & strFolder) And vbDirectory Then
                    ReDim Preserve astrFolders(0 To ialngIndex1)
                    astrFolders(ialngIndex1) = strPath & strFolder & "\"
                    ialngIndex1 = ialngIndex1 + 1
                End If
            End If
            strFolder = Dir$
        Loop
        If ialngIndex1 = ialngIndex2 Then Exit Do
        strPath = astrFolders(ialngIndex2)
        ialngIndex2 = ialngIndex2 + 1
    Loop
    GetFolders = astrFolders
End Function

Viele Grüße Frank

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Hallo Frank

Die Dateien müssen auf dem lokalen Rechner vorhanden sein.
https://ww3.cad.de/foren/ubb/Forum466/HTML/000242.shtml#000001

------------------
Mit freundlichen Grüßen
Ulf-Dirk Stockburger

BiI SAP-PDM

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP