Happy Codings - Programming Code Examples
Html Css Web Design Sample Codes CPlusPlus Programming Sample Codes JavaScript Programming Sample Codes C Programming Sample Codes CSharp Programming Sample Codes Java Programming Sample Codes Php Programming Sample Codes Visual Basic Programming Sample Codes


Visual Basic Programming Code Examples

Visual Basic > Common Dialogs Code Examples

Show the 'Select a Font' Common Dialog

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125
Show the 'Select a Font' Common Dialog To show the "select a font" common dialog use the following routine: Option Explicit Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As Any) As Long Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long) Private Declare Function GetProfileString Lib "kernel32.dll" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long Private Declare Function ChooseFontA Lib "comdlg32.dll" (pChoosefont As tChooseFont) As Long Private Declare Function GetActiveWindow Lib "user32" () As Long Private Type tLogFont 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 As String * 31 End Type Private Type tChooseFont lStructSize As Long hwndOwner As Long hdc As Long 'printer DC/IC or NULL lpLogFont As Long 'Pointer to tLogFont type iPointSize As Long '10 * size in points of selected font flags As Long rgbColors As Long 'returned text color lCustData As Long 'data passed to hook fn. lpfnHook As Long 'ptr. to hook function lpTemplateName As String 'custom template name hInstance As Long 'instance handle of.EXE that lpszStyle As String 'return the style field here must be LF_FACESIZE or bigger nFontType As Integer MISSING_ALIGNMENT As Integer nSizeMin As Long nSizeMax As Long End Type 'Purpose : Shows the font common dialog 'Inputs : N/A 'Outputs : Returns the selected font Function ShowFont() As String Dim tThisFont As tChooseFont, tFont As tLogFont, lhwndMem As Long, lptrMem As Long Dim lRet As Long, sPrinterName As String Const FW_NORMAL = 400, DEFAULT_CHARSET = 1 Const OUT_DEFAULT_PRECIS = 0, CLIP_DEFAULT_PRECIS = 0 Const DEFAULT_QUALITY = 0, DEFAULT_PITCH = 0 Const FF_ROMAN = 16, tThisFont_PRINTERFONTS = &H2 Const GMEM_MOVEABLE = &H2, GMEM_ZEROINIT = &H40 Const tThisFont_SCREENFONTS = &H1, tThisFont_BOTH = (tThisFont_SCREENFONTS Or tThisFont_PRINTERFONTS) Const tThisFont_EFFECTS = &H100&, tThisFont_FORCEFONTEXIST = &H10000 Const tThisFont_INITTOLOGFONTSTRUCT = &H40&, tThisFont_LIMITSIZE = &H2000& Const REGULAR_FONTTYPE = &H400, LF_FACESIZE = 32 'Initialise Type tFont.lfHeight = 0 tFont.lfWidth = 0 tFont.lfEscapement = 0 tFont.lfOrientation = 0 tFont.lfWeight = FW_NORMAL tFont.lfCharSet = DEFAULT_CHARSET tFont.lfOutPrecision = OUT_DEFAULT_PRECIS tFont.lfClipPrecision = CLIP_DEFAULT_PRECIS tFont.lfQuality = DEFAULT_QUALITY tFont.lfPitchAndFamily = DEFAULT_PITCH Or FF_ROMAN tFont.lfFaceName = "Times New Roman" & vbNullChar lhwndMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(tFont)) lptrMem = GlobalLock(lhwndMem) 'lock and get pointer CopyMemory ByVal lptrMem, tFont, Len(tFont) tThisFont.lStructSize = Len(tThisFont) tThisFont.hwndOwner = GetActiveWindow 'or Me.Hwnd in VB sPrinterName = String(254, " ") 'Get default printer name lRet = GetProfileString("windows", "device", ",,,", sPrinterName, 254) sPrinterName = Left$(sPrinterName, InStr(sPrinterName, ",") - 1) 'Get printer Device context lRet = CreateDC(ByVal "PRINTER", ByVal sPrinterName, vbNullString, vbNullString) 'Destory DC Call DeleteDC(lRet) tThisFont.hdc = lRet tThisFont.lpLogFont = lptrMem 'pointer to tLogFont memory block buffer tThisFont.iPointSize = 120 '12 point font (in units of 1/10 point) tThisFont.flags = tThisFont_BOTH Or tThisFont_EFFECTS Or tThisFont_FORCEFONTEXIST Or tThisFont_INITTOLOGFONTSTRUCT Or tThisFont_LIMITSIZE tThisFont.rgbColors = RGB(0, 0, 0) 'black tThisFont.nFontType = REGULAR_FONTTYPE 'regular font type i.e. not bold or anything tThisFont.nSizeMin = 10 'minimum point size tThisFont.nSizeMax = 72 'maximum point size 'Show dialog lRet = ChooseFontA(tThisFont) If lRet <> 0 Then 'Selected a font CopyMemory tFont, ByVal lptrMem, Len(tFont) ShowFont = Left$(tFont.lfFaceName, InStr(tFont.lfFaceName, vbNullChar) - 1) End If lRet = GlobalUnlock(lhwndMem) 'destroy pointer lRet = GlobalFree(lhwndMem) 'free memory End Function