Archive Browser
Download matrixscreensaver.zip, last updated 07/07/2000 (34.72 KB)
Download- md5: 26afc89285581880adcea85741a89874
Attribute VB_Name = "modFontCommonDialogs"
Attribute VB_HelpID = 3216
'--------------------------------------'
' Ariad Development Library '
' Version 3.0 '
'--------------------------------------'
' API Font Common Dialogs '
' Version 1.0 '
'--------------------------------------'
'Copyright � 1999 by Ariad Software. All Rights Reserved.
'Based on original code by Steve McMahon
'of vbAccelerator (http://www.vbaccelerator.com)
'Created : 24/09/1999
'Completed : 24/09/1999
'Last Updated :
Option Explicit
DefInt A-Z
Private Declare Sub CopyMemoryStr Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, ByVal lpvSource As String, ByVal cbCopy As Long)
Private Declare Function ChooseFont Lib "COMDLG32" Alias "ChooseFontA" (chfont As TCHOOSEFONT) As Long
Private Declare Function CommDlgExtendedError Lib "COMDLG32.DLL" () As Long
Private Const LF_FACESIZE = 32
Private Type TCHOOSEFONT
lStructSize As Long ' Filled with UDT size
hWndOwner As Long ' Caller's window handle
hDC As Long ' Printer DC/IC or NULL
lpLogFont As Long ' Pointer to LOGFONT
iPointSize As Long ' 10 * size in points of font
Flags As Long ' Type flags
rgbColors As Long ' Returned text color
lCustData As Long ' Data passed to hook function
lpfnHook As Long ' Pointer to hook function
lpTemplateName As Long ' Custom template name
hInstance As Long ' Instance handle for template
lpszStyle As String ' Return style field
nFontType As Integer ' Font type bits
iAlign As Integer ' Filler
nSizeMin As Long ' Minimum point size allowed
nSizeMax As Long ' Maximum point size allowed
End Type
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Enum FDFontFlags
CF_SCREENFONTS = &H1
CF_PRINTERFONTS = &H2
CF_BOTH = &H3
CF_FONTSHOWHELP = &H4
CF_USESTYLE = &H80
CF_EFFECTS = &H100
CF_ANISONLY = &H400
CF_NOVECTORFONTS = &H800
CF_NOOEMFONTS = CF_NOVECTORFONTS
CF_NOSIMULATIONS = &H1000
CF_LIMITSIZE = &H2000
CF_FIXEDPITCHONLY = &H4000
CF_WYSIWYG = &H8000 ' Must also have ScreenFonts And PrinterFonts
CF_FORCEFONTEXIST = &H10000
CF_SCALABLEONLY = &H20000
CF_TTONLY = &H40000
CF_NOFACESEL = &H80000
CF_NOSTYLESEL = &H100000
CF_NOSIZESEL = &H200000
End Enum
Public Const CF_INITTOLOGFONTSTRUCT = &H40
Public Const CF_FONTNOTSUPPORTED = &H238
Public ApiReturn As Long, ExtendedError As Long
Attribute ApiReturn.VB_VarHelpID = 3219
Attribute ExtendedError.VB_VarHelpID = 3220
'----------------------------------------------------------------------
'Name : SelectFont
'Created : 24/09/1999 21:11
'----------------------------------------------------------------------
'Author : Richard James Moss
'Organisation: Ariad Software
'----------------------------------------------------------------------
'Description : Allows the user to select a font from an API create
' common dialog.
'----------------------------------------------------------------------
'Returns : Returns True on success
'----------------------------------------------------------------------
'Updates :
'
'----------------------------------------------------------------------
' Ariad Procedure Builder Add-In 1.00.0027
Public Function SelectFont(ByVal hWndOwner As Long, CurFont As StdFont, Optional Colour As OLE_COLOR = -1, Optional MinSize As Long = 0, Optional MaxSize As Long = 0, Optional Flags As FDFontFlags = CF_FORCEFONTEXIST Or CF_SCREENFONTS) As Boolean
Attribute SelectFont.VB_HelpID = 3221
Dim CF As TCHOOSEFONT
Dim Fnt As LOGFONT
ApiReturn = 0
ExtendedError = 0
If Colour <> -1 Then Flags = Flags Or CF_EFFECTS
If MinSize Then Flags = Flags Or CF_LIMITSIZE
If MaxSize Then Flags = Flags Or CF_LIMITSIZE
Flags = (Flags Or CF_INITTOLOGFONTSTRUCT) And Not CF_FONTNOTSUPPORTED
' Initialize LOGFONT variable
Fnt.lfHeight = -(CurFont.Size * ((1440 / 72) / Screen.TwipsPerPixelY))
Fnt.lfWeight = CurFont.Weight
Fnt.lfItalic = CurFont.Italic
Fnt.lfUnderline = CurFont.Underline
Fnt.lfStrikeOut = CurFont.Strikethrough
' Other fields zero
StrToBytes Fnt.lfFaceName, CurFont.Name
' Initialize TCHOOSEFONT variable
CF.lStructSize = Len(CF)
CF.hWndOwner = hWndOwner
CF.lpLogFont = VarPtr(Fnt)
CF.iPointSize = CurFont.Size * 10
CF.Flags = Flags
CF.rgbColors = Colour
CF.nSizeMin = MinSize
CF.nSizeMax = MaxSize
' All other fields zero
ApiReturn = ChooseFont(CF)
Select Case ApiReturn
Case 1
' Success
SelectFont = -1
Flags = CF.Flags
Colour = CF.rgbColors
CurFont.Bold = CF.nFontType And &H100
'CurFont.Italic = cf.nFontType And Italic_FontType
CurFont.Italic = Fnt.lfItalic
CurFont.Strikethrough = Fnt.lfStrikeOut
CurFont.Underline = Fnt.lfUnderline
CurFont.Weight = Fnt.lfWeight
CurFont.Size = CF.iPointSize / 10
CurFont.Name = BytesToStr(Fnt.lfFaceName)
Case 0
' Cancelled
SelectFont = 0
Case Else
' Extended error
ExtendedError = CommDlgExtendedError()
SelectFont = 0
End Select
End Function '(Public) Function SelectFont () As StdFont
Private Function BytesToStr(ab() As Byte) As String
Attribute BytesToStr.VB_HelpID = 3222
BytesToStr = StrConv(ab, vbUnicode)
End Function
Private Sub StrToBytes(ab() As Byte, s As String)
Attribute StrToBytes.VB_HelpID = 3223
Dim Cab As Long
If IsArrayEmpty(ab) Then
' Assign to empty array
ab = StrConv(s, vbFromUnicode)
Else
' Copy to existing array, padding or truncating if necessary
Cab = UBound(ab) - LBound(ab) + 1
If Len(s) < Cab Then s = s & String$(Cab - Len(s), 0)
CopyMemoryStr ab(LBound(ab)), s, Cab
End If
End Sub
Private Function IsArrayEmpty(Arr As Variant) As Boolean
Attribute IsArrayEmpty.VB_HelpID = 3224
Dim V As Variant
On Error Resume Next
V = Arr(LBound(Arr))
IsArrayEmpty = (Err <> 0)
On Error GoTo 0
End Function
Donate
This software may be used free of charge, but as with all free software there are costs involved to develop and maintain.
If this site or its services have saved you time, please consider a donation to help with running costs and timely updates.
Donate