title image


Smiley ähnlicher aber globaler Ansatz :-)
hier noch eine universelle Variant, wenn du in den Vorlagen nicht unbedingt Makros einbauen willst - denn gibt es mal eine Änderung, müssen alle Vorlagen angepackt und geändert werden. Mit dieser Variante kannst Du mit nur einem Makro in einer globalen Vorlage ein gleiches Arbeitsergebnis erzielen. Der Anwender selbst - der ggf eine Vorlage entwickelt - braucht noch nicht mal VBA zu können um einen solchen Speicherpfad festzulegen und kann sich mit dem Makro Speicherort_als_Dokumenteigenschaft_festlegen entsprechend behelfen. So kannst Du das Makroprojekt schützen. Weiter hat dies den Vorteil, dass die Vorlagen schlanker werden und ggf. beim Versand einer solchen per Mail mögliche Makros nicht schon an irgend einer Mailwall hängen bleiben. Noch ein Vorteil, es ist egal wo die Vorlagen liegen, wenn in den Sicherheitseinstellungen zu den Makros "globalen AddIns" vertraut wird, kann die Vorlage trotz dem sie vielleicht in einem nicht vertrauenswürdigen Ordner liegt, trotzdem die gewünschte Funktionalität der globalen Vorlage nutzen :-))







' nachfolgenden Code in ein gesondertes Modul in einer globalen Vorlage schreiben



' zum Zweck des Codes : Es soll eine Lösung geboten werden, die es

' in einer globalen Vorlage ermöglicht, einen zu einer Dokumentvorlage beliebig

' vorgegebenen Speicherpfad für den DateiSpeichernUnter-Dialog vorzuschlage

' Diese Pfad kann in der Documentvorlage in einer mit dem Wert "strPropertyName" im

' Script näher bestimmten benutzerdefinierten Eigenschaft hinterlegt und dann beim

' Dokument, welches auf der entsprechenden Vorlage beruht herangezogen werden (diese

' Dokumenteigenschaft wird von der Vorlage direkt in das Dokument vererbt



Const strPropertyName As String = "DocSavePath"

Const PropertyTypeString = 4

Const blnClearCustomDocumentPropertieValue As Boolean = False



Sub FileSave()



  ' ersetzt alleine durch den Makronamen die Wordfunktion "DateiSpeichern"



  If ActiveDocument.Path = "" Then 'Falls Dokument noch nie gespeichert wurde

    Call FileSaveWithSpecialStartFolder

    Exit Sub

  End If

  

  ActiveDocument.Save



End Sub



Sub FileSaveAs()



    ' ersetzt die Wordfunktion "DateiSpeichern"

    

    ' Aufruf einer speziell hierfür geschriebenen Routine

    Call FileSaveWithSpecialStartFolder

    

End Sub



Sub Speicherort_als_Dokumenteigenschaft_festlegen()



    ' Aufrufmakro um einen Speicherort in der persönlichen Dokumenteigenschaft

    ' festzulegen

    Call SetStartValueToSavePath

    

End Sub



Sub FileSaveWithSpecialStartFolder()



    Dim oDoc As Document

    

    On Error Resume Next

    

    ' prüft, ob ein aktives Dokument vorhanden ist

    

    Set oDoc = ActiveDocument

    If Err.Number = "4248" Then

        StatusBar = "ActiveDocument not found"

        Exit Sub

    End If

    

    ' ruft den SpeichernUnter-Dialog auf

    

    With Dialogs(wdDialogFileSaveAs)

        'setzt Pfad und Documentname als Voreinstellung

        .name = GetStartValueForSavePath & "\" & ActiveDocument.name

        'zeigt den Dialog zur Eingabe an

        .Show

    End With

    

    ' ermöglicht anhand des gloabl gesetzten Wertes "blnClearCustomDocumentPropertieValue"

    ' die Speicherpfadinformation im Document zu löschen

    

    If oDoc.Path <> "" Then

        If blnClearCustomDocumentPropertieValue = True Then

            Call SetStartValueToSavePath("")

        End If

    End If



End Sub



Function GetStartValueForSavePath()



    ' ermittelt den Eintrag zu der benutzerdefinierten Dateieigenschaft

    

    Dim oDoc As Document

    Dim strPropertyValue As String

    

    On Error Resume Next

    

    ' prüft, ob ein aktives Dokument vorhanden ist

    

    Set oDoc = ActiveDocument

    If Err.Number = "4248" Then

        StatusBar = "ActiveDocument not found"

        Exit Function

    End If



    ' liest den Wert

    

    strPropertyValue = oDoc.CustomDocumentProperties(strPropertyName)

    

    If Err.Number = 5 Then

    

        ' Dokumenteigenschaft ist nicht vorhanden und hat zu Fehler geführt

        

        StatusBar = "CustomDocumentPropertie not found : Name = " & strPropertyName

        

        ' hier wird der Speicherpfad zu den "Eigenen Dateien" festgelegt

        ' es könnte auch jeder andere Ordner als Alternative vorgeschlagen werden

        

        strPropertyValue = fct_GetSpecialFolder_MyDocuments

        

    End If

    

    Set oDoc = Nothing

    

    ' übermittelt das Prüfungsergebnis als Funktionsergebnis

    

    GetStartValueForSavePath = strPropertyValue



End Function



Function SetStartValueToSavePath(Optional strValue)



    Dim oDoc As Document

    Dim strPropertyValue As String

    Dim Dlg As Dialog

    

    On Error Resume Next

    

    ' prüft, ob ein aktives Dokument vorhanden ist

    

    Set oDoc = ActiveDocument

    If Err.Number = "4248" Then

        StatusBar = "ActiveDocument not found"

        Exit Function

    End If



    If IsMissing(strValue) Then

    

        ' es wurde bei Funktionsaufruf kein Wert für strValue übergeben

        ' es wird ein Dialog zur Auswahl eines Pfades angezeigt

        

        Set Dlg = Dialogs(wdDialogCopyFile)

        If Dlg.Show = 0 Then Exit Function    'Abbrechen wurde bestätigt

        

        ' der Pfad wird festgehalten

        

        strPropertyValue = Dlg.Directory

        

    Else

    

        ' der übergebene Wert wird übernommen

        

        strPropertyValue = strValue

    

    End If

    

    ' Dokumenteigenschaft wird hinzugefügt und der Wert gesetzt

    

    oDoc.CustomDocumentProperties.Add LinkToContent:=False, _

                                      name:=strPropertyName, _

                                      Type:=PropertyTypeString, _

                                      Value:=strPropertyValue

                                      

    If Err.Number = -2147467259 Then

    

        ' Dokumenteigenschaft war schon vorhanden

        

        StatusBar = "CustomDocumentPropertie exists : Name = " & strPropertyName

        

        ' es wird der neue Wert gesetzt

        

        oDoc.CustomDocumentProperties(strPropertyName) = strPropertyValue

        

    End If

    

    Set Dlg = Nothing

    Set oDoc = Nothing

    Exit Function



End Function



Function fct_GetSpecialFolder_MyDocuments() As String



    On Error Resume Next

    

    ' es wird der Pfad zu den "Eigenen Dateien" aus dem System ermittelt

    

    Dim strResult As String

    

    Dim WshShell As Object

    Set WshShell = CreateObject("WScript.Shell")



    If Err.Number = 429 Then

        StatusBar = "Windows-Scripting-Host not found"

        Exit Function

    End If

    

    strResult = WshShell.SpecialFolders("MyDocuments")

    

    Set WshShell = Nothing



    fct_GetSpecialFolder_MyDocuments = strResult



End Function



Code eingefügt mit Syntaxhighlighter 2.5




 
Gruß Martin




eMail und OfficeLine




geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: