MS-Office-Forum
Google
   

Zurück   MS-Office-Forum > Microsoft Office > Microsoft Word
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads Der Renner, 11 Entwicklertools für Access, Tipps & Trick und offene Datenbanken zum einzigartigen Preis.
Themen-Optionen Ansicht
Alt 17.11.2016, 09:38   #31
haklesoft
MOF Koryphäe
MOF Koryphäe
Standard

Zitat: von MicMay Beitrag anzeigen

gibt es hier eine Lösung das er auch wenn man neue Ordner erstelt die mit durchsucht ohne sie hinzuzufügen? sowas wie "*\"

Klar könnte man das machen. Entspricht aber nicht Deiner Aufgabenstellung in #27. Solche Umstellungen werden hier nicht gern gesehen, denn es bedeutet oft, dass Helfer eine Lösung umsonst entwickelt haben.

Zum Durchsuchen ganzer Verzeichnisbäume gibt es hier reichlich Beispiele, die Du adaptieren könntest. Ich bin heute nicht am PC. Da müsstest Du ggf. warten, wenn Du es nicht selbst hinkriegst.

__________________

Hang loose, haklesoft

Geändert von haklesoft (17.11.2016 um 09:41 Uhr).
haklesoft ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 18.11.2016, 12:34   #32
haklesoft
MOF Koryphäe
MOF Koryphäe
Standard

Hier nun eine Variante, die alle existierenden Unterordner zum Ermitteln der nächsten freien Dateinummer mit durchsucht:
Code:

Option Explicit

Sub Document_New()
    ' das Array nimmt den Fullname und die Kern-Angebotsnummer auf
    Dim sFileName(0 To 1) As String
    ' diese Function füllt das Array
    If nextFilename(sFileName()) <> True Then Exit Sub
    
    ' wenn man Vertrauen in den Ablauf bekommen hat,
    ' kann man getrost auf diese Kontrolle verzichten:
    MsgBox "Dokumentenname: " & sFileName(0) & vbLf & _
        "Angebotsnummer: " & sFileName(1), vbInformation, _
        "Dokumentenname und Angebotsnummer"
    
    With ActiveDocument
        ' Dateiname und Kernnummer in Tabelle eintragen - ggf. aktivieren
        ' .Tables(1).Rows(1).Range.Text = sFileName(0)
        .Tables(1).Rows(2).Range.Text = sFileName(1)
        
        ' Dokument unter dem erzeugten Dateinamen im Basispfad speichern
        .SaveAs sFileName(0)
    End With
End Sub

' füllt das übergebene String-Array mit den gesuchten Werten
' liefert True bei fehlerfreiem Durchlauf
Private Function nextFilename(ByRef saFile() As String) As Boolean
On Error GoTo nextFilenameErr
    Dim sAblage As String, sJahr As String, sDocExt As String
    Dim c As Integer, i As Integer
    Dim sName As String, iNr As Integer
    Dim objFSO As Object
    Dim colOrdner As New Collection
    
    Const csRE As String = "Angebotsnummer-"
    
    ' Basisablagepfad für zu durchsuchende Verzeichnisse benennen (ohne abschließenden Backslash)
    sAblage = Environ("USERPROFILE") & "\Desktop\Angebote"
    
    ' aktuelles Jahr feststellen
    sJahr = Year(Date) & "-"
    ' Dateiextender bestimmen
    sDocExt = IIf(Val(Application.Version) > 11, ".docx", ".doc")
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    listFolders objFSO, sAblage, colOrdner
    
    ' höchste Nummer über Basis- und Unterpfade ermitteln
    For i = 1 To colOrdner.Count
        sName = Dir(colOrdner(i) & "\" & csRE & sJahr & "????" & sDocExt)
        Do While sName <> vbNullString
            iNr = CInt(Mid$(sName, InStr(1, sName, sDocExt, vbTextCompare) - 4, 4))
            If iNr > c Then c = iNr
            sName = Dir
        Loop
    Next
    
    c = c + 1   'freie Nummer festlegen
    If c < 1001 Then c = c + 1000
    ' Basisablagepfad und ermittelten freien Dateinamen eintragen
    saFile(0) = sAblage & "\" & csRE & sJahr & c & sDocExt
    ' Kern-Angebotsnummer eintragen
    saFile(1) = sJahr & c
    nextFilename = True

Exit Function

nextFilenameErr:
    MsgBox Err.Description & vbCrLf & vbCrLf & _
    sAblage & sJahr & c & sDocExt, vbCritical, _
    "Dateifehler " & Err.Description

End Function

' listet in einer Collection alle Verzeichnisse auf
Private Sub listFolders(ByRef oFSO As Object, ByVal sPath As String, ByRef colFolders As Collection)
    Dim vSuFo As Variant
    colFolders.Add sPath
    For Each vSuFo In oFSO.GetFolder(sPath).SubFolders
        Call listFolders(oFSO, vSuFo.Path, colFolders)
    Next
    Set vSuFo = Nothing
End Sub

__________________

Hang loose, haklesoft
haklesoft ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 22.11.2016, 14:16   #33
MicMay
Neuer Benutzer
Neuer Benutzer
Standard

Super Danke für die Lösung ist perfekt damit ich beruhigt in Urlaub gehen kann.
Entschuldige das ich jetzt erst antworte
MicMay ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 12.10.2017, 19:19   #34
officesnoopy
Neuer Benutzer
Neuer Benutzer
Standard Rechnungsnummern generieren

Ich denke, der Test von "Word-Print-Buttons Add-In" auf http://jrsoft.de/wordprbu.htm zahlt sich auf jeden Fall aus.
Kann seit neuestem auch einmalige Rechnungsnummern etc. einfügen.
officesnoopy ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 15:45 Uhr.


Partner und Co.
Access-Paradies -Alles rund um die Datenbank Microsoft Access -Code -Programme-Tools -Tipps   Kostenlose Tipps & Tricks, Downloads und Programme   www.kulpa-online.com - Tipps - Tricks - Tutorials - Meinungen - Downloads uvm...   vb@rchiv · Willkommen in der Welt der VB Programmierung   Access-Garhammer - Hier finden Sie jede Menge Beispiel-Datenbanken zu Access und mehr ...   mcseboard.de   Die Top Seite für Excel-VBA-Makros uvm.

Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.

Copyright ©2000-2010 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günther Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.
Beachten Sie bitte auch unsere Nutzungsbedingungen.