cyberdevil0815
Goto Top

Excel 2007 Wie kann ich Verknüpfungen mittels VBA an bestimmte Stellen über mehrere Netzlaufwerke anlegen und verteilen?

Hallo zusammen,

ich möchte gerne mittels eines Excel Sheets und intergrierten VBA Skript eine Ordnerstruktur erstellen, welche auf 2 Netzlaufwerken abgelegt wird. Dies funktioniert im wesentlichen auch, nur kommt nun noch eine Raffinesse hinzu, welche ich nicht weiss wie ich diese Lösen könnte.

Laufwerk G:
Ordnerstruktur, wird mittels Excel Sheet und hinterlegten VBA Skript geschrieben und angelegt:


Laufwerk I:
Ordnerstruktur, wird mittels Excel Sheet und hinterlegten VBA Skript geschrieben und angelegt, hierbei handelt es im Wesentlichen um das selbe Prozedere NUR das hier NUR ein Ordner Namens Mechnik abgelegt wird.
Kundenname und Projektbezeichnung bleiben jedoch identisch.


Was soll nun gelöst werden?
Laufwerk G (eigenständiger Server) agiert, als reine Datenablage (Fileserver), Laufwerk I ist auch ein eigenständiger Server, nur findet hier noch ein 3 D Rendering Job für CAD Modelle statt, welcher viel Leistung und Performance in Anspruch nimmt. Dies zur Definition, wieso zwei Laufwerke verwendet werden sollen.

Nun möchte ich gerne das eine Verknüpfung angelegt wird.
Beispiel: Kunden Ordner X mit Projekt Y soll angelegt werden, mittels ausführen des Skriptes, wird auf Laufwerk G und I die Ordnerstruktur inkl. Dateien und Unterordner angelegt.
Der einzelne Ordner Mechanik auf I soll aber auch auf G sichtbar sein, also hätte ich gern eine Verknüpfung.
Ordner auf I, Verknüpfung kopieren auf G (im selben Kundenordner und Kundenprojekt).
So fit in Sachen VB schreiben/programmieren bin ich nun auch nicht, und ich weiss ehrlich gesagt, nicht so ganz wie ich das machen soll.
Jemand eine Idee?


322f98ad51cf329c4647909ae3283fd4

6974d39b808d680c51c12eedbcc5c473

Sub Main()

UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 2
Dim strData1 As String
Dim strData2 As String
Dim strData3 As String
Dim strData4 As String
Dim objWord As Object


Pfad = "G:\Projekte\"  
Pfad1 = "I:\Projekte\"  

If IsError(Sheets("Tabelle1").Cells(6, "E")) Then  
    MsgBox "Die Navisionlizenz lässt keine weiteren Anwender zu." & vbCrLf & _  
     "" & vbCrLf & _  
     "Warten Sie, bis ein anderer Anwender das Programm verlassen hat.", 48 + 0, _  
     "Projekt konnte nicht angelegt werden!"  
     Unload UserForm1
     GoTo Abbruch2
End If

A = Sheets("Tabelle1").Cells(6, "E")    'Verk. An Name  
Be = Sheets("Tabelle1").Cells(8, "E")   'Anlagennummer  
C = Sheets("Tabelle1").Cells(10, "E")   'Kom. Beschreibung  
D = Sheets("Tabelle1").Cells(12, "E")   'Nr. (Auftragsnummer)  


'*******************************************************************  
'*** Für die Ordnerstruktur ungültige Zeichen werden umgewandelt ***  
'*******************************************************************  

C = Replace(C, "/", "_")  
C = Replace(C, "\", "_")  
C = Replace(C, ":", ";")  
C = Replace(C, "*", "+")  
C = Replace(C, "<", " ")  
C = Replace(C, ">", " ")  
C = Replace(C, "|", "_")  
C = Replace(C, "?", " ")  
C = Replace(C, "Chr(34)", "Chr(39)")  

A = Replace(A, "/", "_")  
A = Replace(A, "\", "_")  
A = Replace(A, ":", ";")  
A = Replace(A, "*", "+")  
A = Replace(A, "<", " ")  
A = Replace(A, ">", " ")  
A = Replace(A, "|", "_")  
A = Replace(A, "?", " ")  
A = Replace(A, "Chr(34)", "Chr(39)")  


'*******************************************************************  
'*** Die aus Navision übernommenen Daten werden konntrolliert ******  
'*******************************************************************  


'Hat die Auftragsnummer das richtige Format?  
If IsNumeric(D) = False Then
    MsgBox "Die Auftragsnummer darf nur aus Zahlen bestehen!", 48 + 0, "Ungültige Eingabe!"  
    Unload UserForm1
    GoTo Abbruch
End If

If Len(D) <> 8 Then
    MsgBox "Die Auftragsnummer muss aus genau 8 Zahlen bestehen! Es sind aber " & Len(D), 48 + 0, "Ungültige Eingabe!"  
    Unload UserForm1
    GoTo Abbruch
End If

'Ist die Auftragsnummer vergeben?  
If D = "" Then  
    MsgBox "Es wurde kein Projekt gefunden!" & vbCrLf & _  
     "Dies kann folgende Ursachen haben:" & vbCrLf & _  
     "" & vbCrLf & _  
     "1. Die Auftragsnummer wurde falsch eingegeben." & vbCrLf & _  
     "2. Es wurde ein falscher Mandant ausgewählt.", 48 + 0, "Es wurde kein Projekt gefunden!"  
     Unload UserForm1
     GoTo Abbruch
End If

'Ist die Anlagennummer vergeben?  
If Be = "" Then  
    MsgBox "Es wurde in Navision keine Anlagennummer angegeben." & vbCrLf & _  
     "" & vbCrLf & _  
     "Bitte tragen sie diese zuerst nach, bevor sie das Projekt anlegen.", 48 + 0, _  
     "Keine Anlagennummer vergeben!"  
     Unload UserForm1
     GoTo Ende
End If

'Ist die Kom. Beschreibung vergeben?  
If C = "" Then  
    MsgBox "Es wurde in Navision keine Beschreibung angegeben." & vbCrLf & _  
     "" & vbCrLf & _  
     "Bitte tragen sie diese zuerst nach, bevor sie das Projekt anlegen.", 48 + 0, _  
     "Keine Beschreibung vorhanden!"  
     Unload UserForm1
     GoTo Ende
End If

'Ist die Anlagennummer vergeben?  
If A = "" Then  
    MsgBox "In Navision wurde das Feld 'Verk. an Name' ausgefüllt." & vbCrLf & _  
     "" & vbCrLf & _  
     "Bitte füllen sie dieses zuerst aus, bevor sie das Projekt anlegen.", _  
     48 + 0, "Keine Kundenname vorhanden!"  
     Unload UserForm1
     GoTo Ende
End If

'Anlagennummer ohne Punkt  
B = Right$(Be, 6)

'Wurde ein Ordnertyp ausgewählt?  
If Sheets("Tabelle1").Cells(3, "F") = 1 Then  
    MsgBox "Es wurde kein Ordnertyp ausgewählt", 48 + 0, "Achtung!"  
    Sheets("Tabelle1").Cells(3, "F") = ""  
    Unload UserForm1
    GoTo Abbruch
End If

UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1

'*******************************************************************  
'*** Anlegen der Ordnerstruktur in Windows *************************  
'*******************************************************************  

'Erstellen des Kundenordners auf LW I  
Name = Pfad1 & A
If Dir(Name & "\", vbDirectory) = "" Then MkDir Name  

'Erstellen des Unterordners mit Anlagennummer_Beschreibung  
ANR = Pfad1 & A & "\" & B & "_" & C  
If Dir(ANR & "\", vbDirectory) = "" And Dir(Name & "\" & B & "*", vbDirectory) = "" Then  
    MkDir ANR
End If

'Erstellen der Unterordnerstruktur  
Unterordner = Pfad1 & A & "\" & B & "_" & C & "\"  

OS10 = Unterordner & "Mechanik"  
MkDir OS10




'Erstellen des Kundenordners auf LW G  
Name = Pfad & A
If Dir(Name & "\", vbDirectory) = "" Then MkDir Name  

'Erstellen des Unterordners mit Anlagennummer_Beschreibung  
ANR = Pfad & A & "\" & B & "_" & C  
If Dir(ANR & "\", vbDirectory) = "" And Dir(Name & "\" & B & "*", vbDirectory) = "" Then  
    MkDir ANR
Else:
    Ord = Name & "\" & Dir(Name & "\" & B & "*", vbDirectory)  
    ASV = Ord & "\" & "Schriftverkehr" & "\" & D & "_" & C  
    If Dir(ASV, vbDirectory) = "" Then  
        MkDir ASV
        MkDir Ord & "\" & "\" & "Doku" & "\" & "Deutsch" & "\" & "Funktionspläne" & "\" & D & "_" & C & "\"  
        MkDir Ord & "\" & "\" & "Doku" & "\" & "Deutsch" & "\" & "Datenblätter" & "\" & D & "_" & C & "\"  
        UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 7
        Unload UserForm1
        GoTo Ende
    
    Else: MsgBox "Projekt bereits vorhanden"  
          Unload UserForm1
          GoTo Abbruch
    End If
End If

'Erstellen der Unterordnerstruktur  
Unterordner = Pfad & A & "\" & B & "_" & C & "\"  

OS1 = Unterordner & "Medien"  
MkDir OS1
MkDir OS1 & "\" & "Videos"  
MkDir OS1 & "\" & "Fotos"  

OS2 = Unterordner & "Berechnung"  
MkDir OS2

OS3 = Unterordner & "Doku"  
MkDir OS3
MkDir OS3 & "\" & "Deutsch"  
MkDir OS3 & "\" & "Deutsch" & "\" & "Bedienungsanleitung"  
MkDir OS3 & "\" & "Deutsch" & "\" & "Funktionspläne"  
MkDir OS3 & "\" & "Deutsch" & "\" & "Funktionspläne" & "\" & D & "_" & C  
MkDir OS3 & "\" & "Deutsch" & "\" & "Datenblätter"  
MkDir OS3 & "\" & "Deutsch" & "\" & "Datenblätter" & "\" & D & "_" & C  
MkDir OS3 & "\" & "Englisch"  

OS4 = Unterordner & "Durchlaufplan"  
MkDir OS4

OS5 = Unterordner & "Elektro"  
MkDir OS5
MkDir OS5 & "\" & "Antriebe"  
MkDir OS5 & "\" & "Bustest"  
MkDir OS5 & "\" & "Display"  
MkDir OS5 & "\" & "E-Pläne"  
MkDir OS5 & "\" & "Sicherheitstechnik"  
MkDir OS5 & "\" & "Technische_Infos"  
MkDir OS5 & "\" & "Zubehör_Parameter"  
MkDir OS5 & "\" & "Programm"  
MkDir OS5 & "\" & "Programm" & "\" & "_Vorbereitet"  
MkDir OS5 & "\" & "Programm" & "\" & "_Vorlage"  

OS6 = Unterordner & "LLV"  
MkDir OS6

OS7 = Unterordner & "Schriftverkehr"  
MkDir OS7
MkDir OS7 & "\" & D & "_" & C  
MkDir OS7 & "\" & D & "_" & C & "\" & "Intern"  
MkDir OS7 & "\" & D & "_" & C & "\" & "Kunde"  
MkDir OS7 & "\" & D & "_" & C & "\" & "Zulieferer"  

OS8 = Unterordner & "Kalkulation"  
MkDir OS8

UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1



'*******************************************************************  
'*** Exceldokumente für Ordner Kalkulation kopieren*****************  
'*******************************************************************  

'Excelsheet mitlaufende Kalkulation.xlsx speichern  

Dim objExcel As Object
Set objExcel = CreateObject("Excel.Application")  


objExcel.Application.Workbooks.Open "G:\Vordrucke\Projekte\Kalkulation\mitlaufende_Kalkulation.xlsx"  

 With objExcel.ActiveWorkbook
        .SaveAs Filename:=Unterordner & "Kalkulation\mitlaufende_Kalkulation" & "_" & D & ".xlsx"  
        .Close
    End With


Set objExcel = Nothing


'Daten aus Exceldatei einlesen  
strData1 = A
strData2 = B
strData3 = C
strData4 = D

'Excelsheet Nachkalkulation_geschlossen.xlsx speichern  

Set objExcel = CreateObject("Excel.Application")  


objExcel.Application.Workbooks.Open "G:\Vordrucke\Projekte\Kalkulation\Nachkalkulation_geschlossen.xlsx"  

 With objExcel.ActiveWorkbook
        .SaveAs Filename:=Unterordner & "Kalkulation\Nachkalkulation_geschlossen" & "_" & D & ".xlsx"  
        .Close
    End With


Set objExcel = Nothing


'Daten aus Exceldatei einlesen  
strData1 = A
strData2 = B
strData3 = C
strData4 = D


'*******************************************************************  
'*** Die Worddokumente werden bearbeitet****************************  
'*******************************************************************  


'Kopieren des Inhaltsverzeichnisses  
FileCopy "G:\Vordrucke\VD_Inhaltsverzeichnis Projektordner.doc", Unterordner & "Inhaltsverzeichnis.doc"  

'Daten in Projektstand.xls eintragen  

Set objExcel = CreateObject("Excel.Application")  


objExcel.Application.Workbooks.Open "G:\Vordrucke\Projektstand.xls"  
objExcel.Application.Sheets("Tabelle1").Select  

 With objExcel.ActiveWorkbook
        .Sheets("Tabelle1").Cells(1, "B") = A  
        .Sheets("Tabelle1").Cells(5, "B") = D  
        .Sheets("Tabelle1").Cells(6, "B") = B  
        .Sheets("Tabelle1").Cells(7, "B") = C  
        .SaveAs Filename:=Unterordner & "Projektstand" & "_" & D & ".xlsx"  
        .Close
    End With


Set objExcel = Nothing


'Daten aus Exceldatei einlesen  
strData1 = A
strData2 = B
strData3 = C
strData4 = D


'*** Daten in "Vordruck für Ordnerrücken.doc" einfügen ***  
If Sheets("Tabelle1").Cells(2, "F") = 1 Then  
    Set objWord = CreateObject("Word.Application")  
    
   '*** Hier wird der Pfad der Wordvorlage angegeben ***  
    objWord.documents.Open "G:\Vordrucke\VD_Vordruck für Ordnerrücken_v1.doc"  
    
    'Text in die Textmarken einfügen  
    With objWord
        .ActiveDocument.Bookmarks("Firma").Range.Text = strData1  
        .ActiveDocument.Bookmarks("Beschreibung").Range.Text = strData3  
        .ActiveDocument.Bookmarks("Anlagennummer").Range.Text = strData2  
    End With
    
    'Dokument speichern unter  
    objWord.ActiveDocument.SaveAs Unterordner & "Vordruck für Ordnerrücken.doc"  

    'word beenden  
    objWord.Quit
    
    'objekt löschen  
    Set objWord = Nothing

End If

UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1

If Sheets("Tabelle1").Cells(1, "F") = 1 Then  
    Set objWord = CreateObject("Word.Application")  
    

    '*** Hier wird der Pfad der Wordvorlage angegeben ***  
    objWord.documents.Open "G:\Vordrucke\VD_Vordruck für Ordnerrücken_schmal_v1.doc"  
    
    With objWord
        .ActiveDocument.Bookmarks("Firma").Range.Text = strData1  
        .ActiveDocument.Bookmarks("Beschreibung").Range.Text = strData3  
        .ActiveDocument.Bookmarks("Anlagennummer").Range.Text = strData2  
    End With
    
'Dokument speichern unter  
objWord.ActiveDocument.SaveAs Unterordner & "Vordruck für Ordnerrücken_schmal.doc"  

'Word beenden  
objWord.Quit
    
'objekt löschen  
Set objWord = Nothing
End If

UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 2
    
'Daten in "VD_Änderungen während des laufenden Projektes_v1.doc" einfügen  
Set objWord = CreateObject("Word.Application")  



'*** Hier wird der Pfad der Wordvorlage angegeben ***  
objWord.documents.Open "G:\Vordrucke\VD_Änderungen während des laufenden Projektes_v1.doc"  
    
With objWord
    
    .ActiveDocument.Bookmarks("Firma").Range.Text = strData1  
    .ActiveDocument.Bookmarks("Beschreibung").Range.Text = strData3  
    .ActiveDocument.Bookmarks("Anlagennummer").Range.Text = strData2  
    .ActiveDocument.Bookmarks("Kommissionsnummer").Range.Text = strData4  
    End With
    

UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 2

'Dokument speichern unter  
objWord.ActiveDocument.SaveAs Unterordner & "Änderungen während des laufenden Projektes"  

'word beenden  
objWord.Quit

'objekt löschen  
Set objWord = Nothing

UserForm1.ProgressBar1.Value = UserForm1.ProgressBar1.Value + 1

Unload UserForm1

Ende:
MsgBox "Projekt wurde erfolgreich erstellt"  

Abbruch2:
Application.DisplayAlerts = False
Workbooks("Projektordner.xls").Close SaveChanges:=False  

Abbruch:
Unload UserForm1
Unload Projektdokumentation
Application.WindowState = xlMaximized

End Sub

Content-Key: 175231

Url: https://administrator.de/contentid/175231

Ausgedruckt am: 19.03.2024 um 10:03 Uhr

Mitglied: bastla
bastla 25.10.2011, aktualisiert am 18.10.2012 um 18:48:52 Uhr
Goto Top
Hallo cyberdevil0815!

Falls Du mit "Verknüpfung" wirklich "Verknüpfung" (Dateityp ".lnk") meinst, findest Du etwa im Beitrag Anlegen eines Shortcuts auf dem Desktop ein Beispiel ...

Grüße
bastla
Mitglied: cyberdevil0815
cyberdevil0815 25.10.2011 um 15:02:24 Uhr
Goto Top
Hey bastla,

vielen Dank für den Tip, aber wirklich schlau bin ich nicht daraus geworden.

Ich habe das Posting von mir, um den VBA Quelltext erweitert. Vielleicht kann mir damit ja noch jemand eher auf die Sprünge helfen.
Mitglied: bastla
bastla 25.10.2011 um 23:09:43 Uhr
Goto Top
Hallo cyberdevil0815!

Im einfachsten Fall fügst Du an passender Stelle ab Zeile 176 etwa folgendes ein:
Set oShellLink = WScript.CreateObject("WScript.Shell").CreateShortcut(Unterordner & "\Mechanik.lnk") 'Link in "Unterordner" erstellen  
oShellLink.TargetPath = OS10 'Verlinkter Ordner  
oShellLink.WorkingDirectory = OS10 'Verlinkter Ordner  
oShellLink.Save 
Grüße
bastla
Mitglied: cyberdevil0815
cyberdevil0815 27.10.2011 um 07:40:22 Uhr
Goto Top
Guten morgen zusammen,

ich bin schon mal soweit, dass ich zumindestens eine Verknüpfung generiert bekomme, welche auf das korrekte Verzeichnis verweist.
ABER:
Die Verknüpfung befindet sich am falschen Ort, hier habe ich garantiert einen kleinen Denkfehler, aber ich seh den Wald vor lauter Bäumen nicht.

Das Resultat sieht derzeit so aus:

4ffb282a781f35899293dddb83e3e760

Die Verknüpfung liegt zwar auf dem korrekten Laufwerk, aber im falschen Ordner. Da die Ordnerstruktur auf beiden Laufwerken gleich ist (ausnahme Bilden hier die Unterordner, sonst bräuchte ich die Verknüpfung nicht).

Mein aktueller Code
   Set WSHShell = CreateObject("WScript.Shell")  
        Set ProjektShortcut = WSHShell.CreateShortcut("Mechanik.lnk")  
        ProjektShortcut.TargetPath = OS10  'Mechanik  
        ProjektShortcut.Save
        Set ProjektShortcut = Nothing
        Set WSHShell = Nothing
Mitglied: bastla
bastla 27.10.2011 um 10:58:45 Uhr
Goto Top
Hallo cyberdevil0815!

Da ja Du genau wissen musst, wo die Verknüpfung liegen soll (in einem Unterordner des in der Variablen "Unterordner" festgelegten Pafdes?), kann ich nur nochmals auf die Zeile 2 hinweisen - dort wird der Speicherort (als kompletter Pfad) festgelegt ...

Grüße
bastla
Mitglied: cyberdevil0815
cyberdevil0815 27.10.2011 um 14:20:22 Uhr
Goto Top
So nun gelöst, Code an Zeilennummer 226 eingefügt:

Set WSHShell = CreateObject("WScript.Shell")  
        'Hier kommt der Verweis nach G hin  
        Set ProjektShortcut = WSHShell.CreateShortcut(ANR & "\" & "Mechanik.lnk")  
        'Wohin soll der Link verweisen  
        ProjektShortcut.TargetPath = OS10  'Mechanik  
        ProjektShortcut.Save
        Set ProjektShortcut = Nothing
        Set WSHShell = Nothing

Skript funktioniert nun wunderbar und wie gewünscht. Vielen Dank @bastla für den richtigen Schubser face-wink
Mitglied: bastla
bastla 27.10.2011 um 15:13:39 Uhr
Goto Top
Hallo cyberdevil0815!

Freut mich ... face-smile

Grüße
bastla

P.S.: Magst Du noch einen Haken an den Thread machen?