• Revista PROGRAMAR: Já está disponível a edição #53 da revista programar. Faz já o download aqui!

KiNgPiTo

Alterar Fonte com o Common Dialog

4 mensagens neste tópico

Boas

numa aplicação que estou a construir, tenho um botão que dá para alterar o tipo de letra das labels do programa...

e para isso pensei em usar o código por exemplo para a label1:

commondialog3.showfont

Label1.font  = CommonDialog3.fontname

até aqui tudo bem.. não dá erro ao compilar, mas ao executar, dá me este erro no showfont:

erroap4.png

e depois este erro na linha com o codigo: commondialog3.showfont

errovy3.png

o problema e que ja executei o programa m vários pcs e tenho a certeza absoluta que tem fontes instaladas, daí eu não saber o porquê de este erro me está a dar...

Se alguém me puder ajudar...

Obrigado

0

Partilhar esta mensagem


Link para a mensagem
Partilhar noutros sites

Amigo antigamente eu também tinha esse problema e não o consegui resolver, porém encontrei isto na net:

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

Não sei se dá, mas é uma questão de veres.

Cumprimentos.

0

Partilhar esta mensagem


Link para a mensagem
Partilhar noutros sites

yah... mas esse codigo esta a fazer o que apenas a linha commondialog1.showfont faz ...

após uma pesquisa mais alargada descobri a resposta para a minha questão, para quem quiser saber...

basta antes de fazer o showfont, definir o valor da propriedade flags como cdlCFScreenFonts

ex:

commondialog1.Flags = cdlCFScreenFonts

commondialog1.showfont

text1.font = commondialog1.fontname

simples até... lol

link onde encontrei isto

http://www.jamajm.com/e-books/vb6/promsvb6/ch12c.htm

0

Partilhar esta mensagem


Link para a mensagem
Partilhar noutros sites

Eu sei KiNgPiTo este modulo é que já podia ter o bug fix da coisa, mas fico contente por teres encontrado a solução.

Cumprimentos

0

Partilhar esta mensagem


Link para a mensagem
Partilhar noutros sites

Crie uma conta ou ligue-se para comentar

Só membros podem comentar

Criar nova conta

Registe para ter uma conta na nossa comunidade. É fácil!


Registar nova conta

Entra

Já tem conta? Inicie sessão aqui.


Entrar Agora