MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração


Participe do fórum, é rápido e fácil

MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

2 participantes

    Ajuda, peguei um módulo e não sei como adicioná-lo

    avatar
    patifreoli
    Novato
    Novato


    Respeito às regras : Respeito às Regras 100%

    Sexo : Feminino
    Localização : Brasil
    Mensagens : 9
    Registrado : 13/04/2017

    Ajuda, peguei um módulo e não sei como adicioná-lo Empty Ajuda, peguei um módulo e não sei como adicioná-lo

    Mensagem  patifreoli 25/11/2022, 18:33

    Olá, Boa tarde a todos!
    Não tenho muita experiência com VB, e preciso de um formulário com fonte maior que 127, e vi que com o módulo abaixo, isso é possível, porém não tenho ideia de como colocar no meu BD, nem como chamar... em que momento? na abertura do form? Seria copiar e colar?

    Módulo:
    Private Const GMEM_MOVEABLE = &H2
    Private Const GMEM_ZEROINIT = &H40
    Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)

    Private Const LF_FACESIZE = 32

    Private Const FW_BOLD = 700

    Private Const CF_APPLY = &H200&
    Private Const CF_ANSIONLY = &H400&
    Private Const CF_TTONLY = &H40000
    Private Const CF_EFFECTS = &H100&
    Private Const CF_ENABLETEMPLATE = &H10&
    Private Const CF_ENABLETEMPLATEHANDLE = &H20&
    Private Const CF_FIXEDPITCHONLY = &H4000&
    Private Const CF_FORCEFONTEXIST = &H10000
    Private Const CF_INITTOLOGFONTSTRUCT = &H40&
    Private Const CF_LIMITSIZE = &H2000&
    Private Const CF_NOFACESEL = &H80000
    Private Const CF_NOSCRIPTSEL = &H800000
    Private Const CF_NOSTYLESEL = &H100000
    Private Const CF_NOSIZESEL = &H200000
    Private Const CF_NOSIMULATIONS = &H1000&
    Private Const CF_NOVECTORFONTS = &H800&
    Private Const CF_NOVERTFONTS = &H1000000
    Private Const CF_OEMTEXT = 7
    Private Const CF_PRINTERFONTS = &H2
    Private Const CF_SCALABLEONLY = &H20000
    Private Const CF_SCREENFONTS = &H1
    Private Const CF_SCRIPTSONLY = CF_ANSIONLY
    Private Const CF_SELECTSCRIPT = &H400000
    Private Const CF_SHOWHELP = &H4&
    Private Const CF_USESTYLE = &H80&
    Private Const CF_WYSIWYG = &H8000
    Private Const CF_BOTH = (CF_SCREENFONTS Or CF_PRINTERFONTS)
    Private Const CF_NOOEMFONTS = CF_NOVECTORFONTS

    Public Const LOGPIXELSY = 90

    Public Type FormFontInfo
    Name As String
    Weight As Integer
    Height As Integer
    UnderLine As Boolean
    Italic As Boolean
    Color 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(LF_FACESIZE) As Byte
    End Type

    Private Type FONTSTRUC
    lStructSize As Long
    hwnd 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 FONTSTRUC) As Long
    Private Declare Function GlobalLock 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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (hpvDest As Any, hpvSource As Any, ByVal cbCopy 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 hwnd As Long) As Long


    Private Function MulDiv(In1 As Long, In2 As Long, In3 As Long) As Long
    Dim lngTemp As Long
    On Error GoTo MulDiv_err
    If In3 <> 0 Then
    lngTemp = In1 * In2
    lngTemp = lngTemp / In3
    Else
    lngTemp = -1
    End If
    MulDiv_end:
    MulDiv = lngTemp
    Exit Function
    MulDiv_err:
    lngTemp = -1
    Resume MulDiv_err
    End Function
    Private Function ByteToString(aBytes() As Byte) As String
    Dim dwBytePoint As Long, dwByteVal As Long, szOut As String
    dwBytePoint = LBound(aBytes)
    While dwBytePoint <= UBound(aBytes)
    dwByteVal = aBytes(dwBytePoint)
    If dwByteVal = 0 Then
    ByteToString = szOut
    Exit Function
    Else
    szOut = szOut & Chr$(dwByteVal)
    End If
    dwBytePoint = dwBytePoint + 1
    Wend
    ByteToString = szOut
    End Function

    Private Sub StringToByte(InString As String, ByteArray() As Byte)
    Dim intLbound As Integer
    Dim intUbound As Integer
    Dim intLen As Integer
    Dim intX As Integer
    intLbound = LBound(ByteArray)
    intUbound = UBound(ByteArray)
    intLen = Len(InString)
    If intLen > intUbound - intLbound Then intLen = intUbound - intLbound
    For intX = 1 To intLen
    ByteArray(intX - 1 + intLbound) = Asc(Mid(InString, intX, 1))
    Next
    End Sub


    Public Function DialogFont(ByRef f As FormFontInfo) As Boolean
    Dim LF As LOGFONT, FS As FONTSTRUC
    Dim lLogFontAddress As Long, lMemHandle As Long

    LF.lfWeight = f.Weight
    LF.lfItalic = f.Italic * -1
    LF.lfUnderline = f.UnderLine * -1
    LF.lfHeight = -MulDiv(CLng(f.Height), GetDeviceCaps(GetDC(hWndAccessApp), LOGPIXELSY), 72)
    Call StringToByte(f.Name, LF.lfFaceName())
    FS.rgbColors = f.Color
    FS.lStructSize = Len(FS)

    lMemHandle = GlobalAlloc(GHND, Len(LF))
    If lMemHandle = 0 Then
    DialogFont = False
    Exit Function
    End If

    lLogFontAddress = GlobalLock(lMemHandle)
    If lLogFontAddress = 0 Then
    DialogFont = False
    Exit Function
    End If

    CopyMemory ByVal lLogFontAddress, LF, Len(LF)
    FS.lpLogFont = lLogFontAddress
    FS.Flags = CF_SCREENFONTS Or CF_EFFECTS Or CF_INITTOLOGFONTSTRUCT
    If ChooseFont(FS) = 1 Then
    CopyMemory LF, ByVal lLogFontAddress, Len(LF)
    f.Weight = LF.lfWeight
    f.Italic = CBool(LF.lfItalic)
    f.UnderLine = CBool(LF.lfUnderline)
    f.Name = ByteToString(LF.lfFaceName())
    f.Height = CLng(FS.iPointSize / 10)
    f.Color = FS.rgbColors
    DialogFont = True
    Else
    DialogFont = False
    End If
    End Function

    Function test_DialogFont(ctl As Control) As Boolean
    Dim f As FormFontInfo
    With f
    .Color = 0
    .Height = 12
    .Weight = 700
    .Italic = False
    .UnderLine = False

    End With
    Call DialogFont(f)
    With f

    Debug.Print "Font Size: "; .Height
    Debug.Print "Font Weight: "; .Weight
    Debug.Print "Font Italics: "; .Italic
    Debug.Print "Font Underline: "; .UnderLine
    Debug.Print "Font COlor: "; .Color


    ctl.FontSize = .Height
    ctl.FontWeight = .Weight
    ctl.FontItalic = .Italic
    ctl.FontUnderline = .UnderLine

    End With
    test_DialogFont = True
    End Function
    Alexandre Neves
    Alexandre Neves
    Moderador Global
    Moderador Global


    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 8272
    Registrado : 05/11/2009

    Ajuda, peguei um módulo e não sei como adicioná-lo Empty Re: Ajuda, peguei um módulo e não sei como adicioná-lo

    Mensagem  Alexandre Neves 25/11/2022, 20:55

    Boa noite
    Deve colar o código num módulo padrão
    Pelo que vi, deve chamar a função test_DialogFont no formulário ou relatório, tendo como argumento o nome do controlo que pretenda alterar o tamanho


    .................................................................................
    Access 2010. Mande bd que dê para testar (indique a versão). Não peça para fazer o que já tem feito. Dê todos os detalhes.
    Não coloquem entraves como senhas, esconder controlos, etc. Disponibilizem o mais limpo possível
    Só respondo a mensagens privadas, se forem de assunto privado; às outras não respondo.
    Quem trabalha e mata a fome não come o pão de ninguém; mas quem não trabalha e come, come sempre o pão de alguém. António Aleixo

      Data/hora atual: 26/1/2023, 21:26