Сайт Алексея Муртазина (Star Cat) E-mail: starcat-rus@yandex.ru
Мои программы Новости сайта Мои идеи Мои стихи Форум Об авторе Мой ЖЖ
VB коды Статьи о VB6 API функции Самоучитель по VB.NET
Собрания сочинений Обмен ссылками Все работы с фото и видео
О моём деде Муртазине ГР Картинная галерея «Дыхание души»
Звёздный Кот

50 Стандартное окно Windows для выбора шрифта
Private Sub EditFont_Click()
If ShowFont > 0 Then NewFont
End Sub

Private Sub Form_Load()
Dim T As String
'Открыттие файла настройки
On Error Resume Next
Open NameFileINI For Input As #1
If Err > 0 Then
mFontName = "MS Sans Serif"
mFontSize = 12
mFontBold = True
Else
Input #1, mFontName
Input #1, mFontSize
Input #1, T: mFontBold = T
Input #1, T: mFontItalic = T
Input #1, mFontColor
Input #1, T: mFontUnderline = T
Input #1, T: mFontStrikethru = T
End If
Close #1
NewFont
End Sub

Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
Open NameFileINI For Output As #1
If Err = 0 Then
Print #1, mFontName
Print #1, mFontSize
Print #1, mFontBold
Print #1, mFontItalic
Print #1, mFontColor
Print #1, mFontUnderline
Print #1, mFontStrikethru
End If
Close #1
End Sub

Module Name="Declare"
Public Const NameFileINI As String = "Font.ini"
Public mFontItalic As Boolean 'True - Наклон текста
Public mFontName As String 'Имя шрифта
Public mFontSize As Long 'Размер
Public mFontBold As Boolean 'True - Жирный шрифт
Public mFontColor As Long 'Цвет
Public mFontUnderline As Boolean 'True - подчёркнутый
Public mFontStrikethru As Boolean 'True - зачёркнутый

Module Name="apiFont"
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

Const cdlCFEffects = &H100 'Атрибуты
Const CF_INITTOLOGFONTSTRUCT = &H40&
Const SCREEN_FONTTYPE = &H2000
Const BOLD_FONTTYPE = &H100
Const FW_BOLD = 700
Const LOGPIXELSY = 90
Const cdlCFScreenFonts = &H1

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 Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (p1 As Any, p2 As Any) As Long
Private Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" _
(pChoosefont As ChooseFont) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hOwner As Long) As Long
Private Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" _
(lpLogFont As LOGFONT) As Long
Private Declare Function GetTextFace Lib "gdi32" Alias "GetTextFaceA" (ByVal hDC As Long, ByVal nCount As Long, ByVal lpFacename As String) As Long
Private Declare Function SelectObject Lib "gdi32" _
(ByVal hDC As Long, ByVal hObject As Long) As Long

Public Function ShowFont() As Long
Dim CF As ChooseFont
Dim LF As LOGFONT
Dim TempByteArray() As Byte
Dim ByteArrayLimit As Long
Dim OldhDC As Long
Dim FontToUse As Long
Dim tbuf As String * 80
Dim X As Long
TempByteArray = StrConv(mFontNget& vbNullChar, vbFromUnicode)
ByteArrayLimit = UBound(TempByteArray)
With LF
For X = 0 To ByteArrayLimit
.lfFaceName(X) = TempByteArray(X)
Next
X = Form1.hWnd
.lfHeight = mFontSize / 72 * GetDeviceCaps(GetDC(X), LOGPIXELSY)
.lfItalic = mFontItalic * -1
.lfUnderline = mFontUnderline * -1
.lfStrikeOut = mFontStrikethru * -1
If mFontBold Then .lfWeight = FW_BOLD
End With
With CF
.lStructSize = Len(CF)
.hwndOwner = X
.hDC = GetDC(X)
.lpLogFont = lstrcpy(LF, LF)
.flags = cdlCFScreenFonts
.flags = .flags Or cdlCFEffects Or CF_INITTOLOGFONTSTRUCT
.rgbColors = mFontColor
.lCustData = 0
.lpfnHook = 0
.lpTemplateName = 0
.hInstance = 0
.lpszStyle = 0
.nFontType = SCREEN_FONTTYPE
.nSizeMin = 0
.nSizeMax = 0
.iPointSize = mFontSize * 10
End With
ShowFont = ChooseFont(CF)
If ShowFont > 0 Then
With LF
mFontItalic = .lfItalic * -1
mFontUnderline = .lfUnderline * -1
mFontStrikethru = .lfStrikeOut * -1
End With
With CF
mFontSize = .iPointSize \ 10
mFontColor = .rgbColors
If .nFontType And BOLD_FONTTYPE Then
mFontBold = True
Else
mFontBold = False
End If
End With
FontToUse = CreateFontIndirect(LF)
If FontToUse = 0 Then Exit Function
OldhDC = SelectObject(CF.hDC, FontToUse)
X = GetTextFace(CF.hDC, 79, tbuf)
mFontName = Mid$(tbuf, 1, X)
End If
End Function

Module Name="NewFontM"
Public Sub NewFont()
With Form1.Text1
.FontName = mFontName
.FontSize = mFontSize
.FontBold = mFontBold
.FontItalic = mFontItalic
.ForeColor = mFontColor
.FontUnderline = mFontUnderline
.FontStrikethru = mFontStrikethru
End With
End Sub

Инфо
Сайт создан: 20 июня 2015 г.
Рейтинг@Mail.ru
Главная страница