[Iska]

хочу "Точечные шрифты" и размером 10х18. »

Anton04, посмотрел. Примерно так:

читать дальше »

Код:

Option Explicit

Const SSFMOpenReadWrite = 1

Const strConsoleDataBlockSignature = "CC000000020000A0"
Const lngFontSizePosition          = 24


Dim objFSO
Dim objSpeechFileStream

Dim strLnkFileName
Dim lngConsoleDataBlockPosition

Dim arrContent

Dim byteValue
Dim strFontName
Dim i

'strLnkFileName = "E:\Песочница\0063\Far2.lnk"
strLnkFileName = WScript.Arguments.Item(0)

Set objFSO                = WScript.CreateObject("Scripting.FileSystemObject")
Set objSpeechFileStream   = WScript.CreateObject("SAPI.spFileStream")

With objFSO
	If .FileExists(strLnkFileName) Then
		If UCase(.GetExtensionName(strLnkFileName)) = UCase("lnk") Then
			.GetFile(strLnkFileName).Copy strLnkFileName & ".bak", True
			
			With objSpeechFileStream
				.Open strLnkFileName, SSFMOpenReadWrite
				.Read arrContent, objFSO.GetFile(strLnkFileName).Size
				
				lngConsoleDataBlockPosition = InStr(ConvertByteArray2HexString(arrContent), strConsoleDataBlockSignature)
				
				If lngConsoleDataBlockPosition <> 0 Then
					.Seek lngConsoleDataBlockPosition \ 2 + Len(strConsoleDataBlockSignature) / 2 + lngFontSizePosition
					
					' FontSize: 10x18
					.Write CByte(&H0A)
					.Write CByte(&H00)
					.Write CByte(&H12)
					.Write CByte(&H00)
					
					' FontFamily: FF_MODERN
					.Write CByte(&H30)
					.Write CByte(&H00)
					.Write CByte(&H00)
					.Write CByte(&H00)
					
					' FontWeight: 400
					.Write CByte(&H90)
					.Write CByte(&H01)
					.Write CByte(&H00)
					.Write CByte(&H00)
					
					' Face Name: Terminal
					strFontName = Left("Terminal" & String(32, Chr(0)), 32)
					
					For i = 1 To Len(strFontName)
						.Write Asc(Mid(strFontName, i, 1))
					Next
				Else
					WScript.Echo "Can't find ConsoleDataBlock section in [" & strLnkFileName & "]"
				End If
				
				.Close()
			End With
		Else
			WScript.Echo "File [" & strLnkFileName & "] is not *.lnk file"
		End If
	Else
		WScript.Echo "File [" & strLnkFileName & "] not found"
	End If
End With

Set objSpeechFileStream   = Nothing
Set objFSO                = Nothing

WScript.Quit 0
'=============================================================================

'=============================================================================
Function ConvertByteArray2HexString(arrByteArray)
	Dim i
	Dim strValue
	
	strValue = ""
	
	For i = 1 To LenB(arrByteArray)
		strValue = strValue & Right("00" & Hex(AscB(MidB(arrByteArray, i, 1))), 2)
	Next
	
	ConvertByteArray2HexString = strValue
End Function
'=============================================================================