VBScript für Fonts-Abfrage

[Majce 10]

Hallo ihr Lieben

 

Leider komme ich hier nicht mehr weiter:

 

Dim oFSO, oApp, oFolderCopy, oShell
Dim strFontsPath, strScriptPath

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oShell = CreateObject("WScript.Shell")
Set oApp = CreateObject("Shell.Application")

strScriptPath = Replace(WScript.ScriptFullName, WScript.ScriptName, "")

strFontsPath = oShell.ExpandEnvironmentStrings("%WINDIR%") & "\Fonts"

Set oFolderCopy = oApp.Namespace(strScriptPath & "FontsToInstall")

For Each oFont In oFolderCopy.Items


IF  oFSO.FileExists(strFontsPath & "\" & oFont.Name) = True Then
oApp.Namespace(strFontsPath).Delete oFont
oApp.Namespace(strFontsPath).CopyHere oFont
Else
oApp.Namespace(strFontsPath).CopyHere oFont
End If



Next

' Cleanup Objects
Set oFolderCopy = Nothing
Set oApp = Nothing
Set oShell = Nothing

 

Ich will eigentlich NUR, wenn die Schriftart vorhanden ist, dass er zur nächsten Geht und wenn nicht, dass er Sie in den Ordner Kopiert.

 

Leider klappt das nicht, denn wenn eine Schriftart vorhanden ist, dann Fragt er mich immer wieder, willst du die Schriftart ersetzen.

 

Bei 1 Schriftart ja noch ok, aber nicht wenn ich 500 Schriftarten habe und vielleicht 200 bereits auf meinem Computer.

 

Ich danke euch viel mal für eure Hilfe.

 

PS: Ich Scripte das erste mal mit VB, also bitte verzeiht wenn es nicht gut aussieht.

 

LG Majce

[mamamia 13]

Naja ist ja auch logisch, dass er das macht.

Wenn File vorhanden, dann lösche erst und kopiere neu, ansonsten kopiere.

 

Ohne Else wäre es richtig:

For Each oFont In oFolderCopy.Items
If  oFSO.FileExists(strFontsPath & "\" & oFont.Name) = True Then
	oApp.Namespace(strFontsPath).Delete oFont
	oApp.Namespace(strFontsPath).CopyHere oFont
End If
Next

[Majce 10]

Hallo Mamamia

 

Danke für die Antwort.

 

Doch was ist, wenn es die Schrift nicht hat, dann macht er ja gar nichts, und er soll Sie ja kopieren.

 

Ich sag es mal so:

 

Schrift im Ordner suchen.

Wenn Schrift vorhanden:

Dann mach gar nichts

ansonsten installiere Schrift.

 

Das will ich eigentlich mit diesem Script erreichen.

Doch ich weiss nicht wie ich im sagen soll, er soll garnichts machen, deshalb lasse ich sie vorher löschen.

 

Doch ich bin blutige Anfängerin im VBS.

 

Danke und Gruss

Majce

[mamamia 13]

Gut, dann machen wir es anders:

 

For Each oFont In oFolderCopy.Items
If  [b]NOT[/b] oFSO.FileExists(strFontsPath & "\" & oFont.Name) Then
	oApp.Namespace(strFontsPath).CopyHere oFont
End If
Next

 

Damit sagen wir, wenn der Font nicht in dem Ordner ist, kopiere den Font!

Möchtest du damit eine zentrale Verteilung im Netzwerk machen?

 

Dann musst du noch ein paar andere Sachen beachten. Ich habe hier ein fertiges Script (von mir) was das alles macht.

 

Bei Interesse, einfach melden.

[Majce 10]

Hallo Mamamia

 

Ja, das mit dem NOT hatte ich auch schon, doch leider stellt er mir auch die Frage mit dem Ersetzen, deswegen probiere ich es über einen Umweg.

 

Gerne würde ich es sonst mit deinem Script mal ausprobieren, vielleicht funktioniert das bei mir. Und ja, ich dachte mir, ich lege es als Startscript auf jeden Computer, so habe ich dann keine Meldungen mehr, mir fehlt diese Schrift und mir diese.

 

Danke dir viel mal für deine Hilfe.

[mamamia 13]

Okay hier:

 

' Region Description
'
' Name:	deployFonts.vbs
' Author:	mamamia
' Version:	0.3
'		0.3 | Installationsprozess geändert, Fonts werden jetzt über objShellApp kopiert und installiert
'		0.2 | Registrierung der Schriftarten hinzugefügt
'		0.1 | initiale Version
' Description:	kopiert Fonts von $Fontspath zu den Systemfonts
' 
' 
' EndRegion

Set objNetwork 	= CreateObject("WScript.Network")
Set objShellApp	= CreateObject("Shell.Application")
Set WSHShell	= CreateObject("WScript.Shell")
Set oFileSys	= CreateObject("Scripting.FileSystemObject")
Computer		= UCase(objNetwork.ComputerName)

Function deplyFonts (FontsPath)
Set objFolder 	= objShellApp.Namespace(FontsPath)
SystemFonts		= WSHShell.ExpandEnvironmentStrings("%Systemroot%") & "\Fonts\"
Set Folder 		= oFileSys.GetFolder(FontsPath)	
For Each File In objFolder.Items
	' Nur Files mit der Endung "ttf" lesen
	If UCase(Right(File.Path, 3)) = "TTF" Then
		' bei XP ist File.Name mit Endung, bei Windows 2003 ohne, daher angleichen des Formats			
		If UCase(Right(File.Name, 3)) = "TTF" Then
			FontName = File.Name
		Else
			FontName = File.Name & ".TTF"
		End If 	
		' wenn Font auf dem System noch nicht vorhanden ist, kopieren
		If Not oFileSys.FileExists(UCase(SystemFonts & FontName)) Then
			objShellApp.Namespace(SystemFonts).CopyHere File
		Else
			'prüfen ob eine neuere Version auf dem Server liegt	
			Set DestFile	= oFileSys.GetFile(File.Path)
			Set SourceFile 	= oFileSys.GetFile(SystemFonts & FontName)

			If SourceFile.DateCreated <> DestFile.DateCreated Then
				oFileSys.DeleteFile File.Path
				objShellApp.Namespace(SystemFonts).CopyHere File.Path
			End If	
		End If
	End If
Next
End Function

deployFonts("\\Server\Freigabe\Fonts")

[Majce 10]

Hallo Mamamia

 

Ich habe das Script 1 zu 1 kopiert, lediglich deployFonts in:

deployFonts("Z:\Avanon_Intern\Fonts\FontsToInstall")

geändert.

Jetzt kommt mir die Meldung:

Zeile 50

Zeichen 1

Fehler Typen unverträglich: 'deployFonts'

 

:(

 

Auch ohne " " geht es nicht.

 

Kannst du mir bitte noch einmal helfen :s

[mamamia 13]

Auf was für einem System testest du das denn eigentlich?

Probier mal bitte den UNC Pfad, mappings gehen hier eh nicht, da das Script vom Starten ausgeführt wird.

[Majce 10]

Auf einem Windows 7 Betriebssystem, der Server ist ein 2008 R2.

 

Nein, geht auch leider mit

\\avan-dc-01\avanon\Avanon_Intern\Fonts\FontsToInstall nicht. kommt die gleiche Fehlermeldung.

 

An den Rechten kann es nicht liegen, da ich Domänenadmin bin.

 

Ich sag ja, aaalllleees k***e :) Bei mir funktioniert nie was. :(