Solved

font dialog in office 64bit

Posted on 2016-10-22
12
29 Views
Last Modified: 2016-10-24
I am looking for a working 64 bit font dialog box.i would like to attache it to a command button to display as a popup from a ms access form.
Thanks
0
Comment
Question by:Svgmassive
  • 6
  • 6
12 Comments
 
LVL 26

Accepted Solution

by:
MacroShadow earned 500 total points
ID: 41855546
Try this:
Option Explicit

' Original Code by Terry Kreft
' Modified by Stephen Lebans
' Contact Stephen@lebans.com

'************  Code Start  ***********
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

#If VBA7 And Win64 Then
Private Type FONTSTRUC
    lStructSize As LongPtr
    hWnd As LongPtr
    hDC As LongPtr
    lpLogFont As LongPtr
    iPointSize As LongPtr
    Flags As LongPtr
    rgbColors As LongPtr
    lCustData As LongPtr
    lpfnHook As LongPtr
    lpTemplateName As String
    hInstance As LongPtr
    lpszStyle As String
    nFontType As LongPtr
    MISSING_ALIGNMENT As Integer
    nSizeMin As LongPtr
    nSizeMax As LongPtr
End Type
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "USER32" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As FONTSTRUC) As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As LongPtr)
#Else
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 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 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 Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As FONTSTRUC) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
#End If

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 frm As Form
    Dim f As FormFontInfo
    With f
        .Color = 0
        .Height = 12
        .Weight = 700
        .Italic = False
        .UnderLine = False
        .Name = "Arial"
    End With
    Call DialogFont(f)
    With f
        Debug.Print "Font Name: "; .Name
        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.FontName = .Name
        ctl.FontSize = .Height
        ctl.FontWeight = .Weight
        ctl.FontItalic = .Italic
        ctl.FontUnderline = .UnderLine
        'ctl = .Name & " - Size:" & .Height
    End With
    test_DialogFont = True
End Function
'************  Code End  ***********

Open in new window

0
 

Author Comment

by:Svgmassive
ID: 41855571
macroshadow,it din't work.
thanks
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 41855594
How about a little more information ;-)
How did you use the code? On which line do you get a error? What is the error number?
0
 

Author Comment

by:Svgmassive
ID: 41855601
it ran but the dialog never showed
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 41855603
How did you run the code?

Run this code (obviously, you must change TextBoxName to a name of a textbox on your form):
Sub Demo()
    Dim blnRet As Boolean
    blnRet = test_DialogFont(Me.TextBoxName)
End Sub
0
 

Author Comment

by:Svgmassive
ID: 41855608
yep i did that bu it does work in ms access 64bit system and that is what i am looking for
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
LVL 26

Expert Comment

by:MacroShadow
ID: 41855612
can you upload a sample file?
0
 

Author Comment

by:Svgmassive
ID: 41855702
It fails here it returns 0
  lLogFontAddress = GlobalLock(lMemHandle)
  If lLogFontAddress = 0 Then
    DialogFont = False
    Exit Function
  End If
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 41855762
Replace line 170 with this:
#If VBA7 And Win64 Then
	Dim lLogFontAddress As LongPtr, lMemHandle As LongPtr
#Else
    Dim lLogFontAddress As Long, lMemHandle As Long
#End If

Open in new window


You may also have to replace line 139 (of the original code with this:
#If VBA7 And Win64 Then
	Dim dwBytePoint As LongPtr, dwByteVal As LongPtr
#Else
    Dim dwBytePoint As Long, dwByteVal As Long
#End If
	Dim szOut As String

Open in new window

0
 

Author Comment

by:Svgmassive
ID: 41856384
Macro,I tried but it still fails at the same line of code.I just cant get it to work in 64bit vba have been searching the web for an alternative.

Thanks
0
 

Author Comment

by:Svgmassive
ID: 41857132
hi macro i am up to the  if  ChooseFont(FS)=1
it fails to open any suggestion.THanks
0
 
LVL 26

Expert Comment

by:MacroShadow
ID: 41858017
Is this issue solved?
0

Featured Post

6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

Join & Write a Comment

This article is a continuation or rather an extension from Cascading Combos (http://www.experts-exchange.com/A_5949.html) and builds on examples developed in detail there. It should be understandable alone, but I recommend reading the previous artic…
I originally created this report in Crystal Reports 2008 where there is an option to underlay sections. I initially came across the problem in Access Reports where I was unable to run my border lines down through the entire page as I was using the P…
Familiarize people with the process of utilizing SQL Server views from within Microsoft Access. Microsoft Access is a very powerful client/server development tool. One of the SQL Server objects that you can interact with from within Microsoft Access…
Familiarize people with the process of utilizing SQL Server stored procedures from within Microsoft Access. Microsoft Access is a very powerful client/server development tool. One of the SQL Server objects that you can interact with from within Micr…

760 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

21 Experts available now in Live!

Get 1:1 Help Now