Разделы
Главная

Windows API
Реестр
MS Access
Visual Basic
Download
Форум
Гостевая книга
Ссылки

E-mail

Партнерская программа WWW.PORTA.RU (on-line магазин портативной аудио, видео, фототехники). Самая щедрая, самая честная, самая популярная. Приглашаем всех веб-мастеров к участию!



Submitter.ru - Free promoting
Visual Basic

вернуться назад Выбор шрифта

' выбор шрифта
' для работы необходимо добавить в форму:
' PictureBox, TextBox, Label и CommandButton

Option Explicit

Private Const LF_FACESIZE = 32
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

Private Type ChooseFont
   lStructSize As Long
   hwndOwner As Long
   hdc As Long
   lpLogFont As Long
   iPointSize As Long
   flags As Long
   rgbColors As Long
   lCustData As Long
   lpfnHook As Long
   lpTemplateName As String
   hInstance As Long
   lpszStyle As String
   nFontType As Integer
   MISSING_ALIGNMENT As Integer
   nSizeMin As Long
   nSizeMax As Long
End Type

Private Declare Function ChooseFont Lib "comdlg32.dll" Alias _
"ChooseFontA" (pChoosefont As ChooseFont) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbCopy 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 Const GMEM_FIXED = &H0
Private Const GMEM_ZEROINIT = &H40
Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)
Private Const CF_SCREENFONTS = &H1
Private Const CF_PRINTERFONTS = &H2
Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Private Const CF_SHOWHELP = &H4&
Private Const CF_ENABLEHOOK = &H8&
Private Const CF_ENABLETEMPLATE = &H10&
Private Const CF_ENABLETEMPLATEHANDLE = &H20&
Private Const CF_INITTOLOGFONTSTRUCT = &H40&
Private Const CF_USESTYLE = &H80&
Private Const CF_EFFECTS = &H100&
Private Const CF_APPLY = &H200&
Private Const CF_ANSIONLY = &H400&
Private Const CF_SCRIPTSONLY = CF_ANSIONLY
Private Const CF_NOVECTORFONTS = &H800&
Private Const CF_NOOEMFONTS = CF_NOVECTORFONTS
Private Const CF_NOSIMULATIONS = &H1000&
Private Const CF_LIMITSIZE = &H2000&
Private Const CF_FIXEDPITCHONLY = &H4000&
Private Const CF_WYSIWYG = &H8000
Private Const CF_FORCEFONTEXIST = &H10000
Private Const CF_SCALABLEONLY = &H20000
Private Const CF_TTONLY = &H40000
Private Const CF_NOFACESEL = &H80000
Private Const CF_NOSTYLESEL = &H100000
Private Const CF_NOSIZESEL = &H200000
Private Const CF_SELECTSCRIPT = &H400000
Private Const CF_NOSCRIPTSEL = &H800000
Private Const CF_NOVERTFONTS = &H1000000


Private Function CString(aStr As String) As String
CString = ""
Dim k As Long
k = InStr(aStr, Chr$(0))
If k Then
   CString = Left$(aStr, k - 1)
End If
End Function


Private Sub Command1_Click()
Dim CF As ChooseFont, hMem As Long, LF As LOGFONT, aFontName As String
hMem = GlobalAlloc(GPTR, Len(LF))
CF.hInstance = App.hInstance
CF.hwndOwner = hWnd
CF.lpLogFont = hMem
CF.lStructSize = Len(CF)
CF.flags = CF_BOTH
If ChooseFont(CF) Then
   CopyMemory LF, ByVal hMem, Len(LF)
   aFontName = Space$(LF_FACESIZE)
   CopyMemory ByVal aFontName, LF.lfFaceName(0), LF_FACESIZE

   ' вставляем текст в PictureBox
   With Picture1.Font
      .Name = CString(aFontName)
      .Bold = LF.lfWeight
      .Italic = LF.lfItalic
      .Size = CF.iPointSize / 10
      .Underline = LF.lfUnderline
      .Charset = LF.lfCharSet
      .Strikethrough = LF.lfStrikeOut
   End With
   Picture1.Cls
   Call Picture1_Paint

   ' вставляем текст в TextBox
   With Text1.Font
      .Name = CString(aFontName)
      .Bold = LF.lfWeight
         .Italic = LF.lfItalic
      .Size = CF.iPointSize / 10
      .Underline = LF.lfUnderline
      .Charset = LF.lfCharSet
      .Strikethrough = LF.lfStrikeOut
   End With

   ' вставляем текст в Label1
   With Label1.Font
      .Name = CString(aFontName)
      .Bold = LF.lfWeight
      .Italic = LF.lfItalic
      .Size = CF.iPointSize / 10
      .Underline = LF.lfUnderline
      .Charset = LF.lfCharSet
      .Strikethrough = LF.lfStrikeOut
   End With

End If
Call GlobalFree(hMem)
Me.Refresh
Me.Refresh
End Sub


Private Sub Picture1_Paint()
   Picture1.Print Picture1.Font.Name
End Sub


Выбор шрифта (2 952 байт)