' A script to demonstrate the Font Select dialog available in COMDLG32.OCX
' Written by Rob van der Woude
' http://www.robvanderwoude.com

Option Explicit

Dim arrFont, blnBold, blnItalic, blnStrikeThrough, blnUnderlined, strAttributes

arrFont = FontSelectDialog( )
If arrFont(0) = True Then
	blnBold          = arrFont(3) And 1
	blnItalic        = arrFont(3) And 2
	blnStrikeThrough = arrFont(3) And 4
	blnUnderlined    = arrFont(3) And 8
	strAttributes    = ""
	If blnBold          Then strAttributes = strAttributes & " bold"
	If blnItalic        Then strAttributes = strAttributes & " italic"
	If blnStrikeThrough Then strAttributes = strAttributes & " strikethrough"
	If blnUnderlined    Then strAttributes = strAttributes & " underlined"
	WScript.Echo "Selected font: " & arrFont(1) & " " & arrFont(2) & "pt" & strAttributes
Else
	WScript.Echo "No font selected"
End If


Function FontSelectDialog( )
' This function pops up a Font Select dialog and returns an array of
' properties for the selected font.
' The array has the following values:
' index 0 = [bool] True if a font was successfully selected, otherwise False
' index 1 = [str]  Font name
' index 2 = [int]  Font size in pt
' index 3 = [int]  Font attributes:
'                  4 bits for Bold (bit 0), Italic (bit 1),
'                  Strikethrough (bit 2) and Underlined (bit 3)
'                  E.g. if index 3 equals 4, Strikethrough is true,
'                  if index 3 equals 3 then Bold and Italic are both true

	Dim intAttrib, objDialog

	FontSelectDialog = Array( False, "", 0, 0 )

	On Error Resume Next
	Set objDialog = CreateObject( "MSComDlg.CommonDialog" )
	If Err Then
		MsgBox Err.Description & vbCrLf & vbCrLf _
		     & "This script requires COMDLG32.OCX." & vbCrLf & vbCrLf _
		     & "Please make sure it is installed and registered.", , "COMDLG32 not registered"
	Else
		objDialog.ShowFont
		intAttrib = 0
		If objDialog.FontBold       Then intAttrib = intAttrib + 1
		If objDialog.FontItalic     Then intAttrib = intAttrib + 2
		If objDialog.FontStrikeThru Then intAttrib = intAttrib + 4
		If objDialog.FontUnderLine  Then intAttrib = intAttrib + 8
		If objDialog.FontName <> "" Then
			FontSelectDialog = Array( True, objDialog.FontName, objDialog.FontSize, intAttrib )
		End If
	End If

	On Error Goto 0
	Set objDialog = Nothing
End Function