VisualBasic Nur bestimmte Dateitypen moven

[tullm]

Hi,

habe hier ein Script was an sich gut läuft, nur verschiebt es alle Dateien die es findet. Was müßte da enthalten sein damit er z.B. nur *.tif Dateien oder *.TIF Dateien nimmt?

Bin hier leider gar nicht firm und mit dem was ich bei Google so gefunden habe kamen nur Fehler...

Kann mir das einer bitte genau erklären und bestenfalls das Skript entsprechend anpassen?

Danke!

Option Explicit

'Hier die Pfade anpassen
Const ClientPfad= "C:\temp\scanning"

Const ServerPfad = "S:\"
'Const ServerPfad = "C:\temp\Server"

Function DPM_OnCreate(DCRoot)
End Function


Function DPM_OnOpenBatch(DCBatch)
  Dim objFSO
  Dim objFolder
  Dim objFolderClient
  Dim objFile
  Dim NewFilename
  Dim Fileanzahl
  Dim Abfrage

  Set objFSO=CreateObject("Scripting.FileSystemObject")
  If (objFSO.FolderExists(ServerPfad)) Then
    'Verzeichnis vorhanden?
    If (objFSO.FolderExists(ClientPfad)) Then
      'Clientverzeichnis vorhanden
      Set objFolder=objFSO.getfolder(ServerPfad)
      Set objFolderClient=objFSO.getfolder(ClientPfad)
      'Prüfen ob Verzeichnis leer, wenn ja, dann ABBRUCH
        Fileanzahl = objFolderClient.Files.Count
      if Fileanzahl = 0 then
        'Fehlerhandling, wenn move nicht klappt!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        For Each objFile in objFolder.Files
          NewFilename=ClientPfad & "\"&objFile.name 
          objFile.move NewFilename
        Next
        if Err.Number <> 0 then
          msgbox "Beim Holen der Tiff-Dokumente ist ein Fehler aufgetreten!",4096
        end if
      else
        Abfrage = msgbox ("Das lokale Verzeichnis ist nicht leer, sollen die Dokumente gelöscht werden?",vbYesNo,"Löschabfrage")
        If Abfrage = "6" then
          'Löschen der Dokumente im lokalen Verzeichnis
            'Clientverzeichnis vorhanden
          For Each objFile in objFolderClient.Files
            objFile.Delete
          Next
          ' und moven
          For Each objFile in objFolder.Files
        
            NewFilename=ClientPfad & "\"&objFile.name 
            objFile.move NewFilename
           Next
          else
          DCBatch.DeleteBatch
        end if
      end if
    else
      MSGBox "ClientVerzeichnis nicht vorhanden. Bitte wenden Sie Sich an Ihren Administrator."
      'eventuell erstellen
    end if
  else
    MSGBox "ClientVerzeichnis nicht vorhanden. Bitte wenden Sie Sich an Ihren Administrator."
    DCBatch.DeleteBatch
  end if
  Set objFSO=Nothing
End Function


Function DPM_OnProcessDocument(DCDocument)
End Function


Function DPM_OnCloseBatch()
End Function


Function DPM_OnDestroy()
End Function

 

[Darlis]

Eine simple Methode wäre der String-Vergleich, also prüfen, ob die letzten 4 Stellen des Dateinames ".tif" oder ".tiff" entsprechen. Mit RegEx wäre es auch möglich, ist aber overkill für diese simple Aufgabe.
Evtl. gibt es in VB auch ein äquivalent zur C# FileInfo-Klasse, die dir direkt die "Extension" der Datei liefert.

 

[1668mib]

Eine Möglichkeit: Einfach den Dateinamen in Klein- bzw. Großbuchstaben bei Vergleich betrachten

 

[tullm]

Hi,
danke schon mal für die Antworten. Vergass ich aber zu sagen das das Skript nicht von mir ist und ich nicht wirklich Ahnung davon habe! Somit bringen mir die Antworten so leider nicht so viel.

Vielleicht ein wenig genauer, oder reineditiert? Das wär toll!

Danke

 

[Syberdoor]

angenommen du hättest eine zusätzliche Funktion contains (case insensitive)

' Funktion um zu prüfen ob ein string einen anderen enthält
Function contains(sourceStr, checkStr)	
	contains=InStr(1, sourceStr, checkStr, vbTextCompare) > 0
End Function

dann musst halt aus jedem move ein

If contains(Right(objFile.name, 4), ".tiff") OR contains(Right(objFile.name, 3), ".tif") Then
   NewFilename=ClientPfad & "\"&objFile.name
   objFile.move NewFilename
End If

machen. Dann werden nur noch die TIFFs gemoved. Aber das Script macht ja auch noch irgendwas andres vonwegen lokale Files löschen? Da musst dir dann halt auch überlegen ob da dann alles gelöscht werden soll oder nur die Tiffs oder nur die andern oder kA und halt abfragen einbauen

 

[tullm]

Hi, danke für Deine Mühe. Klingt ganz gut, nur leider bekomme ich das nicht eingebaut, da er dann immer irgendwelche NEXT Zeilen anmekcert wenn ich das reinkopiere und austausch.

Könntest Du das einmal in den kompletten Code reinhauen von oben?

Danke

Gruß

TUllm

 

[Syberdoor]

Ich hatte einen Fehler drin, weil ichs falsch zusammenkopiert hab, das hab ich mal jetzt korrigiert.
Ich will das eigentlich nicht alles zusammen einfügen weil wenn ich so einen kompletten code poste würd cih gern sicher gehen dass es funktioniert und ich hab nicht die zeit mein system so zu bauen, dass ich das wirklich austesten kann.

Aber wenns immer noch nicht geht kann ichs dir schon nochmal so posten wie ich meine dass es gehören würde, ohne gewähr halt dann

 

[tullm]

Hey, das wär toll, weil wie gesagt meckert er das next dann danach an wenn ich das so übernehme. Denke mal weil hier noch ein If Then drin ist, was vorher nicht da war paßt die Struktur so nicht mehr ganz da rein. Posten wäre toll. Testen kann ich hier ja dann udn Rückmeldung geben.
DANKE!

 

[Syberdoor]

 Option Explicit
 
'Hier die Pfade anpassen
Const ClientPfad= "C:\temp\scanning"
 
Const ServerPfad = "S:\"
'Const ServerPfad = "C:\temp\Server"
 
Function DPM_OnCreate(DCRoot)
End Function
 
 
Function DPM_OnOpenBatch(DCBatch)
  Dim objFSO
  Dim objFolder
  Dim objFolderClient
  Dim objFile
  Dim NewFilename
  Dim Fileanzahl
  Dim Abfrage
 
  Set objFSO=CreateObject("Scripting.FileSystemObject")
  If (objFSO.FolderExists(ServerPfad)) Then
    'Verzeichnis vorhanden?
    If (objFSO.FolderExists(ClientPfad)) Then
      'Clientverzeichnis vorhanden
      Set objFolder=objFSO.getfolder(ServerPfad)
      Set objFolderClient=objFSO.getfolder(ClientPfad)
      'Prüfen ob Verzeichnis leer, wenn ja, dann ABBRUCH
        Fileanzahl = objFolderClient.Files.Count
      if Fileanzahl = 0 then
        'Fehlerhandling, wenn move nicht klappt!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        For Each objFile in objFolder.Files
          If contains(Right(objFile.name, 4), ".tiff") OR contains(Right(objFile.name, 3), ".tif") Then
            NewFilename=ClientPfad & "\"&objFile.name
            objFile.move NewFilename
          End If
        Next
        if Err.Number <> 0 then
          msgbox "Beim Holen der Tiff-Dokumente ist ein Fehler aufgetreten!",4096
        end if
      else
        Abfrage = msgbox ("Das lokale Verzeichnis ist nicht leer, sollen die Dokumente gelöscht werden?",vbYesNo,"Löschabfrage")
        If Abfrage = "6" then
          'Löschen der Dokumente im lokalen Verzeichnis
            'Clientverzeichnis vorhanden
          For Each objFile in objFolderClient.Files
            objFile.Delete
          Next
          ' und moven
          For Each objFile in objFolder.Files
        
            If contains(Right(objFile.name, 4), ".tiff") OR contains(Right(objFile.name, 3), ".tif") Then
              NewFilename=ClientPfad & "\"&objFile.name
              objFile.move NewFilename
            End If
           Next
          else
          DCBatch.DeleteBatch
        end if
      end if
    else
      MSGBox "ClientVerzeichnis nicht vorhanden. Bitte wenden Sie Sich an Ihren Administrator."
      'eventuell erstellen
    end if
  else
    MSGBox "ClientVerzeichnis nicht vorhanden. Bitte wenden Sie Sich an Ihren Administrator."
    DCBatch.DeleteBatch
  end if
  Set objFSO=Nothing
End Function
 
 
Function DPM_OnProcessDocument(DCDocument)
End Function
 
 
Function DPM_OnCloseBatch()
End Function
 
 
Function DPM_OnDestroy()
End Function

' Funktion um zu prüfen ob ein string einen anderen enthält
Function contains(sourceStr, checkStr)
  contains=InStr(1, sourceStr, checkStr, vbTextCompare) > 0
End Function

 

[tullm]

Großartig, DANKE!

Mußte die Funktion contains noch mit reinhauen und unten das If contains war zu viel, aber dann wie gewollt!

Herzlichen Dank!

Gruß

TUllm

 

[Syberdoor]

Ja stimmt. Ich war so genervt dass es mir dauernd die formatierung zerstört hat dass ich das dann beim 3. mal neuposten wohl übersehen hab.

Funktioniert das jetzt so wie du willst oder wie?

 

[tullm]

Ja, dank Deiner Hilfe jetzt alles so wie es soll. 1000 Dank für die Mühe!!

Gruß

TUllm