VPF::API для вызова диалога выбора шрифтов

Rostik Ultra

Дата 4.1.2005, 06:25 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 201
Регистрация: 16.12.2004

Репутация: нет
Всего: нет

Подскажите плз API для вызова диалога выбора шрифтов

ЗЫ : желательно чтоб ещё и работал в win 9x

--------------------

Naghual

Дата 4.1.2005, 10:08 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1893
Регистрация: 15.5.2004
Где: Украина, Днепр

Репутация: 26
Всего: 49

Вот не хочеш ты сам подумать.
Принципиально не хочеш!

Код

Option Explicit

Const FW_NORMAL = 400
Const DEFAULT_CHARSET = 1
Const OUT_DEFAULT_PRECIS = 0
Const CLIP_DEFAULT_PRECIS = 0
Const DEFAULT_QUALITY = 0
Const DEFAULT_PITCH = 0
Const FF_ROMAN = 16
Const CF_PRINTERFONTS = &H2
Const CF_SCREENFONTS = &H1
Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Const CF_EFFECTS = &H100&
Const CF_FORCEFONTEXIST = &H10000
Const CF_INITTOLOGFONTSTRUCT = &H40&
Const CF_LIMITSIZE = &H2000&
Const REGULAR_FONTTYPE = &H400
Const LF_FACESIZE = 32
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40

Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
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 As String * 31
End Type
Private Type CHOOSEFONT
       lStructSize As Long
       hwndOwner As Long          '  caller's window handle
       hDC As Long                '  printer DC/IC or NULL
       lpLogFont As Long          '  ptr. to a LOGFONT struct
       iPointSize As Long         '  10 * size in points of selected font
       flags As Long              '  enum. type flags
       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
                                      '    contains cust. dlg. template
       lpszStyle As String          '  return the style field here
                                      '  must be LF_FACESIZE or bigger
       nFontType As Integer          '  same value reported to the EnumFonts
                                      '    call back with the extra FONTTYPE_
                                      '    bits added
       MISSING_ALIGNMENT As Integer
       nSizeMin As Long           '  minimum pt size allowed &
       nSizeMax As Long           '  max pt size allowed if
                                      '    CF_LIMITSIZE is used
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 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 Sub Command4_Click()
   MsgBox ShowFont
End Sub

Private Sub Form_Load()
   'Set the captions
   Command4.Caption = "ShowFont"
End Sub

Private Function ShowFont() As String
   Dim cf As CHOOSEFONT, lfont As LOGFONT, hMem As Long, pMem As Long
   Dim fontname As String, retval As Long
   lfont.lfHeight = 0  ' determine default height
   lfont.lfWidth = 0  ' determine default width
   lfont.lfEscapement = 0  ' angle between baseline and escapement vector
   lfont.lfOrientation = 0  ' angle between baseline and orientation vector
   lfont.lfWeight = FW_NORMAL  ' normal weight i.e. not bold
   lfont.lfCharSet = DEFAULT_CHARSET  ' use default character set
   lfont.lfOutPrecision = OUT_DEFAULT_PRECIS  ' default precision mapping
   lfont.lfClipPrecision = CLIP_DEFAULT_PRECIS  ' default clipping precision
   lfont.lfQuality = DEFAULT_QUALITY  ' default quality setting
   lfont.lfPitchAndFamily = DEFAULT_PITCH Or FF_ROMAN  ' default pitch, proportional with serifs
   lfont.lfFaceName = "Times New Roman" & vbNullChar  ' string must be null-terminated
   ' Create the memory block which will act as the LOGFONT structure buffer.
   hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(lfont))
   pMem = GlobalLock(hMem)  ' lock and get pointer
   CopyMemory ByVal pMem, lfont, Len(lfont)  ' copy structure's contents into block
   ' Initialize dialog box: Screen and printer fonts, point size between 10 and 72.
   cf.lStructSize = Len(cf)  ' size of structure
   cf.hwndOwner = Form1.hwnd  ' window Form1 is opening this dialog box
   cf.hDC = Printer.hDC  ' device context of default printer (using VB's mechanism)
   cf.lpLogFont = pMem   ' pointer to LOGFONT memory block buffer
   cf.iPointSize = 120  ' 12 point font (in units of 1/10 point)
   cf.flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE
   cf.rgbColors = RGB(0, 0, 0)  ' black
   cf.nFontType = REGULAR_FONTTYPE  ' regular font type i.e. not bold or anything
   cf.nSizeMin = 10  ' minimum point size
   cf.nSizeMax = 72  ' maximum point size
   ' Now, call the function.  If successful, copy the LOGFONT structure back into the structure
   ' and then print out the attributes we mentioned earlier that the user selected.
   retval = CHOOSEFONT(cf)  ' open the dialog box
   If retval <> 0 Then  ' success
       CopyMemory lfont, ByVal pMem, Len(lfont)  ' copy memory back
       ' Now make the fixed-length string holding the font name into a "normal" string.
       ShowFont = Left(lfont.lfFaceName, InStr(lfont.lfFaceName, vbNullChar) - 1)
       Debug.Print  ' end the line
   End If
   ' Deallocate the memory block we created earlier.  Note that this must
   ' be done whether the function succeeded or not.
   retval = GlobalUnlock(hMem)  ' destroy pointer, unlock block
   retval = GlobalFree(hMem)  ' free the allocated memory
End Function

Это сообщение отредактировал(а) Naghual - 4.1.2005, 10:12

--------------------

Я желаю всем Счастья!

korob2001

Дата 4.1.2005, 14:21 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Комодератор
Сообщений: 2871
Регистрация: 29.12.2002

Репутация: нет
Всего: 61

А почему не воспользуешься Microsoft Common Dialog Control 6.0?

--------------------

"Время проходит", - привыкли говорить вы по неверному пониманию.
"Время стоит - проходите вы".

Naghual

Дата 4.1.2005, 14:48 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1893
Регистрация: 15.5.2004
Где: Украина, Днепр

Репутация: 26
Всего: 49

korob2001 А ты почитай предыдущие его посты. Это целая предистория.

--------------------

Я желаю всем Счастья!

korob2001

Дата 4.1.2005, 15:04 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Комодератор
Сообщений: 2871
Регистрация: 29.12.2002

Репутация: нет
Всего: 61

Цитата

korob2001 А ты почитай предыдущие его посты. Это целая предистория.

Да я читал. Только странно как-то, у меня все работает.

--------------------

"Время проходит", - привыкли говорить вы по неверному пониманию.
"Время стоит - проходите вы".

Gannibal

Дата 4.1.2005, 20:44 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 742
Регистрация: 15.4.2003
Где: 010101

Репутация: 18
Всего: 17

Код


Private Sub Form_Load()
      ' определить количество экранных шрифтов. 
       For I = 0 To Screen.FontCount - 1
               ' засунуть все шрифты в листбокс. 
               cboFont.AddItem Screen.Fonts(I)
       Next I
End Sub

Private Sub cboFont_Click()
       ' сделать выбранный FontName шрифтом combobox 
       cboFont.FontName = cboFont.Text
       Text1.Font = cboFont.Text
End Sub

да вот типо такого чтото.. обычный комбобокс вызываеш писал вот в этом посту...

http://forum.vingrad.ru/index.php?showtopic=37985

Добавлено @ 20:45
может непонял что ты хочешь но по теме ясно что выбор шрифтов.. вот тебе и пример

--------------------

Я родился в этом безумном мире - и Я сделаю всё чтобы в нём выжить!

Rostik Ultra

Дата 5.1.2005, 03:14 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 201
Регистрация: 16.12.2004

Репутация: нет
Всего: нет

Цитата(korob2001 @ 4.1.2005, 15:04)

Цитата

korob2001 А ты почитай предыдущие его посты. Это целая предистория.

Да я читал. Только странно как-то, у меня все работает.

У меня иногда не работало , когда был vb5 , недавно скачал vb 6 - теперь всё работает

ЗЫ : с api оно надёжнее - вдруг у кого-то не окажется нужно файла
Добавлено @ 03:17

Цитата(Naghual @ 4.1.2005, 10:08)

Вот не хочеш ты сам подумать.
Принципиально не хочеш!

Код

Option Explicit

Const FW_NORMAL = 400
Const DEFAULT_CHARSET = 1
Const OUT_DEFAULT_PRECIS = 0
Const CLIP_DEFAULT_PRECIS = 0
Const DEFAULT_QUALITY = 0
Const DEFAULT_PITCH = 0
Const FF_ROMAN = 16
Const CF_PRINTERFONTS = &H2
Const CF_SCREENFONTS = &H1
Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
Const CF_EFFECTS = &H100&
Const CF_FORCEFONTEXIST = &H10000
Const CF_INITTOLOGFONTSTRUCT = &H40&
Const CF_LIMITSIZE = &H2000&
Const REGULAR_FONTTYPE = &H400
Const LF_FACESIZE = 32
Const GMEM_MOVEABLE = &H2
Const GMEM_ZEROINIT = &H40

Private Type POINTAPI
   x As Long
   y As Long
End Type
Private Type RECT
   Left As Long
   Top As Long
   Right As Long
   Bottom As Long
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 As String * 31
End Type
Private Type CHOOSEFONT
       lStructSize As Long
       hwndOwner As Long          '  caller's window handle
       hDC As Long                '  printer DC/IC or NULL
       lpLogFont As Long          '  ptr. to a LOGFONT struct
       iPointSize As Long         '  10 * size in points of selected font
       flags As Long              '  enum. type flags
       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
                                      '    contains cust. dlg. template
       lpszStyle As String          '  return the style field here
                                      '  must be LF_FACESIZE or bigger
       nFontType As Integer          '  same value reported to the EnumFonts
                                      '    call back with the extra FONTTYPE_
                                      '    bits added
       MISSING_ALIGNMENT As Integer
       nSizeMin As Long           '  minimum pt size allowed &
       nSizeMax As Long           '  max pt size allowed if
                                      '    CF_LIMITSIZE is used
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 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 Sub Command4_Click()
   MsgBox ShowFont
End Sub

Private Sub Form_Load()
   'Set the captions
   Command4.Caption = "ShowFont"
End Sub

Private Function ShowFont() As String
   Dim cf As CHOOSEFONT, lfont As LOGFONT, hMem As Long, pMem As Long
   Dim fontname As String, retval As Long
   lfont.lfHeight = 0  ' determine default height
   lfont.lfWidth = 0  ' determine default width
   lfont.lfEscapement = 0  ' angle between baseline and escapement vector
   lfont.lfOrientation = 0  ' angle between baseline and orientation vector
   lfont.lfWeight = FW_NORMAL  ' normal weight i.e. not bold
   lfont.lfCharSet = DEFAULT_CHARSET  ' use default character set
   lfont.lfOutPrecision = OUT_DEFAULT_PRECIS  ' default precision mapping
   lfont.lfClipPrecision = CLIP_DEFAULT_PRECIS  ' default clipping precision
   lfont.lfQuality = DEFAULT_QUALITY  ' default quality setting
   lfont.lfPitchAndFamily = DEFAULT_PITCH Or FF_ROMAN  ' default pitch, proportional with serifs
   lfont.lfFaceName = "Times New Roman" & vbNullChar  ' string must be null-terminated
   ' Create the memory block which will act as the LOGFONT structure buffer.
   hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(lfont))
   pMem = GlobalLock(hMem)  ' lock and get pointer
   CopyMemory ByVal pMem, lfont, Len(lfont)  ' copy structure's contents into block
   ' Initialize dialog box: Screen and printer fonts, point size between 10 and 72.
   cf.lStructSize = Len(cf)  ' size of structure
   cf.hwndOwner = Form1.hwnd  ' window Form1 is opening this dialog box
   cf.hDC = Printer.hDC  ' device context of default printer (using VB's mechanism)
   cf.lpLogFont = pMem   ' pointer to LOGFONT memory block buffer
   cf.iPointSize = 120  ' 12 point font (in units of 1/10 point)
   cf.flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE
   cf.rgbColors = RGB(0, 0, 0)  ' black
   cf.nFontType = REGULAR_FONTTYPE  ' regular font type i.e. not bold or anything
   cf.nSizeMin = 10  ' minimum point size
   cf.nSizeMax = 72  ' maximum point size
   ' Now, call the function.  If successful, copy the LOGFONT structure back into the structure
   ' and then print out the attributes we mentioned earlier that the user selected.
   retval = CHOOSEFONT(cf)  ' open the dialog box
   If retval <> 0 Then  ' success
       CopyMemory lfont, ByVal pMem, Len(lfont)  ' copy memory back
       ' Now make the fixed-length string holding the font name into a "normal" string.
       ShowFont = Left(lfont.lfFaceName, InStr(lfont.lfFaceName, vbNullChar) - 1)
       Debug.Print  ' end the line
   End If
   ' Deallocate the memory block we created earlier.  Note that this must
   ' be done whether the function succeeded or not.
   retval = GlobalUnlock(hMem)  ' destroy pointer, unlock block
   retval = GlobalFree(hMem)  ' free the allocated memory
End Function

У меня нет времени думать ( чё трудно сразу подсказать - знаешь ведь )

ЗЫ : благодарствую за API , только как там изменять шрифт объекта ( где то самое волшебное слово smile

)

--------------------

Naghual

Дата 5.1.2005, 10:22 (ссылка)

(нет голосов)

Загрузка ...

Эксперт

Профиль
Группа: Завсегдатай
Сообщений: 1893
Регистрация: 15.5.2004
Где: Украина, Днепр

Репутация: 26
Всего: 49

Цитата

У меня нет времени думать ( чё трудно сразу подсказать - знаешь ведь )

Ну тогда не ко мне!

--------------------

Я желаю всем Счастья!

Gannibal

Дата 5.1.2005, 10:27 (ссылка)

(нет голосов)

Загрузка ...

Опытный

Профиль
Группа: Участник
Сообщений: 742
Регистрация: 15.4.2003
Где: 010101

Репутация: 18
Всего: 17

а чем вам мой пример ненравится?

--------------------

Я родился в этом безумном мире - и Я сделаю всё чтобы в нём выжить!

Rostik Ultra

Дата 6.1.2005, 03:36 (ссылка)

(нет голосов)

Загрузка ...

Бывалый

Профиль
Группа: Участник
Сообщений: 201
Регистрация: 16.12.2004

Репутация: нет
Всего: нет

M.E.G.U.S Код хороший но мне надо чтобы была стандартная панель выбора шрифтов

Всё , уже не надо

Сам нарыл здесь http://www.vb.kiev.ua/code/xtras/mhart/choose_fnt.zip

Это сообщение отредактировал(а) Rostik Ultra - 6.1.2005, 06:55

--------------------

0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема \| VB6 \| Следующая тема »