Access-o-Mania

Hallo liebe "Access"-Gemeinde,

in meinem 32bit Access (Avccess 2016) klappt der Aufruf der Dialogbox.
"(lngString = Font_DialogFont(Me.XFont)"

Private Sub Agenturname_DblClick(Cancel As Integer)
Dim lngString As Boolean
Dim AFX As String
Dim AFN As String
Dim AFS As String
Dim AFW As String
Dim AFI As String
Dim AFU As String
Dim LString As String
Dim LArray() As String
    lngString = Font_DialogFont(Me.XFont)
    XFN = Me.XFont
LString = XFN
LArray = Split(LString, ";")

AFN = LArray(0)
AFS = LArray(1)
AFW = LArray(2)
AFI = LArray(3)
AFU = LArray(4)

CurrentDb.Execute "UPDATE tab_int_Daten SET [FontNameAgentur] = '" & AFN & _
"',[FontSizeAgentur] = '" & AFS & "',[FontWeightAgentur] = " & AFW & _
",[FontItalicAgentur] = '" & AFI & "',[FontUnderlineAgentur] = '" & AFU & "'"
Font_Change ' Funktion

End Sub

Aufgerufen wird: "Font_DialogFont"

Function Font_DialogFont(ctl As Control) As Boolean
    Dim F As FormFontInfo
    With F
      .Color = 0
      .Height = Nz(DLookup("FontSizeAgentur", "tab_int_Daten", ""))
      .Weight = Nz(DLookup("FontWeightAgentur", "tab_int_Daten", ""))
      .Italic = Nz(DLookup("FontItalicAgentur", "tab_int_Daten", ""))
      .UnderLine = Nz(DLookup("FontUnderlineAgentur", "tab_int_Daten", ""))
      .Name = Nz(DLookup("FontNameAgentur", "tab_int_Daten", ""))
    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 & ";" & .Height & ";" & .Weight & ";" & .Italic & ";" & .UnderLine
       
    End With
    Font_DialogFont = True
End Function

In einem 64bit Access (Access 365) klappt es nicht. Es kommt keine Fehlermeldung.
Die Dialogbox wird nicht aufgerufen.

Hat jemand eine Lösung, die für beide Systeme funtioniert.
Also so etwas wie "Declare PtrSafe Function"

Vielen Dank im Voraus
jagger

Zitat von: jagger am März 25, 2019, 09:07:27In einem 64bit Access (Access 365) klappt es nicht. Es kommt keine Fehlermeldung.
Die Dialogbox wird nicht aufgerufen.

Hat jemand eine Lösung, die für beide Systeme funtioniert.
Also so etwas wie "Declare PtrSafe Function"

Die wirklich interessante Funktion, DialogFont, zeigst du leider in deinem Code nicht.

Aber ja, der Ansatz mit PtrSafe geht in die richtige Richtung. Zusätzlich sind aber auch die Datentypen zu beachten.
Ich habe die Grundlagen für Windows API mit 64bit (https://codekabinett.com/rdumps.php?Lang=2&targetDoc=windows-api-declaration-vba-64-bit) bisher nur auf Englisch beschrieben. - Meinen Vortrag zu dem Thema auf der AccessDevCon (http://www.donkarl.com/devcon/) 2018 gibt es übrigens auch auf Video (https://www.youtube.com/watch?v=B4U9CBgqE_U).

Du hast aber besonderes Glück, speziell für den Sachverhalt des Font-Dialoges habe ich auch ein fertiges Beispiel. ->
64-Bit-Font-Dialog-API for VBA (https://codekabinett.com/page.php?Theme=10&Lang=2#choosefont-dialog-vba-api-x64)

Hallo PhilS,

ZitatDie wirklich interessante Funktion, DialogFont, zeigst du leider in deinem Code nicht.

sorry!  ???
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)

    ' To be modal must be valid Hwnd
    fs.hwnd = Application.hWndAccessApp
   
  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


ZitatIch habe die Grundlagen für Windows API mit 64bit bisher nur auf Englisch beschrieben. - Meinen Vortrag zu dem Thema auf der AccessDevCon 2018 gibt es übrigens auch auf Video.

Du hast aber besonderes Glück, speziell für den Sachverhalt des Font-Dialoges habe ich auch ein fertiges Beispiel. ->
64-Bit-Font-Dialog-API for VBA

Das werde ich mir anschauen. Mal sehen, ob ich das dann selber hinbekomme.

Danke!
LG
jagger

Hallo PhilS,

was sind das für Dateien in dem ModFontDialog.zip?
Die enden auf ".bas" Womit kann man die öffnen?

Ich stehe gerade mächtig auf allen Schläuchen.

LG
jagger

Zitat von: jagger am März 25, 2019, 11:37:39
was sind das für Dateien in dem ModFontDialog.zip?
Die enden auf ".bas" Womit kann man die öffnen?

Mit Access.  ;D

Im VBA-Editor Menü Einfügen - Datei

Aber Danke für den Hinweis. Ich hatte das als Allgemeinwissen vorausgesetzt. Ich werde einen Hinweis dazu ergänzen.

Hallo PhilS,

ich habe mein Modul "Modul_FontPicker" nach der Vorlage aus Deiner "ModFontDialog.zip" überarbeitet.

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

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 PtrSafe Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" _
(pChoosefont As FONTSTRUC) As Long
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 Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
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 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)

    ' To be modal must be valid Hwnd
    fs.hwnd = Application.hWndAccessApp
   
  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 Font_DialogFont(ctl As Control) As Boolean
    Dim F As FormFontInfo
    With F
      .Color = 0
      .Height = Nz(DLookup("FontSizeAgentur", "tab_int_Daten", ""))
      .Weight = Nz(DLookup("FontWeightAgentur", "tab_int_Daten", ""))
      .Italic = Nz(DLookup("FontItalicAgentur", "tab_int_Daten", ""))
      .UnderLine = Nz(DLookup("FontUnderlineAgentur", "tab_int_Daten", ""))
      .Name = Nz(DLookup("FontNameAgentur", "tab_int_Daten", ""))
    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 & ";" & .Height & ";" & .Weight & ";" & .Italic & ";" & .UnderLine
    End With
    Font_DialogFont = True
End Function

Function Font_Change()

Dim FT As String
Dim fs As String
Dim FI As String
Dim FW As String
Dim FU As String
FT = Nz(DLookup("FontNameAgentur", "tab_int_Daten", ""))
fs = Nz(DLookup("FontSizeAgentur", "tab_int_Daten", ""))
FI = Nz(DLookup("FontItalicAgentur", "tab_int_Daten", ""))
FW = Nz(DLookup("FontWeightAgentur", "tab_int_Daten", ""))
FU = Nz(DLookup("FontUnderlineAgentur", "tab_int_Daten", ""))
Forms![mnu_Hauptmenue]![Agenturname].FontName = FT
Forms![mnu_Hauptmenue]![Agenturname].FontSize = fs
If FI = "Falsch" Then
FI = -1
Else
FI = 0
End If
Forms![mnu_Hauptmenue]![Agenturname].FontItalic = FI
Forms![mnu_Hauptmenue]![Agenturname].FontWeight = FW
If FU = "Falsch" Then
FU = -1
Else
FU = 0
End If
Forms![mnu_Hauptmenue]![Agenturname].FontUnderline = FU

End Function

Function FontKuDaBl_Change()

Dim FT As String
Dim fs As String
Dim FI As String
Dim FW As String
Dim FU As String
FT = Nz(DLookup("FontNameAgentur", "tab_int_Daten", ""))
fs = Nz(DLookup("FontSizeAgentur", "tab_int_Daten", ""))
FI = Nz(DLookup("FontItalicAgentur", "tab_int_Daten", ""))
FW = Nz(DLookup("FontWeightAgentur", "tab_int_Daten", ""))
FU = Nz(DLookup("FontUnderlineAgentur", "tab_int_Daten", ""))
If fs > 30 Then fs = 30

Reports![rep_Kundendatenblatt]![Agenturname].FontName = FT
Reports![rep_Kundendatenblatt]![Agenturname].FontSize = fs
Reports![rep_Kundendatenblatt]![Agenturname].FontItalic = FI
Reports![rep_Kundendatenblatt]![Agenturname].FontWeight = FW
Reports![rep_Kundendatenblatt]![Agenturname].FontUnderline = FU

End Function

'************  Code End  ***********


Jetzt bekomme ich die Fehlermeldung "Fehler beim Kompilieren" und es wird in

ZitatlMemHandle = 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

"GlobalAlloc" und "GlobalLock" markiert.
Wenn ich bei
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

das "As LongPtr" auf "As Long" ändere, kommt keine Fehlermeldung, es funktioniert aber eben auch nicht.

Was muss ich noch ändern?  :-[

LG
jagger

Hallo
Die Variablen lLogFontAddress und lMemHandle  die müssen ebenfalls als longptr definiert sein.

Dim lLogFontAddress As Longptr, lMemHandle As Longptr


zudem müsstest du u.U auch die Struckturen anpassen z.B.
Private Type FONTSTRUC
  lStructSize As Long
  hwnd As LongPTR
  hdc As LongPTR
  lpLogFont As LongPTR
  iPointSize As Long
  Flags As Long
  rgbColors As Long
  lCustData As Long
  lpfnHook As LongPTR
  lpTemplateName As String
  hInstance As Long
  lpszStyle As String
  nFontType As Integer
  MISSING_ALIGNMENT As Integer
  nSizeMin As Long
  nSizeMax As Long
End Type

Zitat von: jagger am März 27, 2019, 20:52:45
ich habe mein Modul "Modul_FontPicker" nach der Vorlage aus Deiner "ModFontDialog.zip" überarbeitet.

Es wäre vermutlich einfacher gewesen, es einfach komplett zu übernehmen. Deine APIs stammen relativ sicher eh aus der gleichen Quelle (Kreft/Lebans) wie das Modul, das ich überarbeitet habe.

Bei der Gelegenheit könntest du auch deinen Code sinnvoller strukturieren und die generische Funktionalität (Font-Dialog des Betriebssystems aufrufen) von der anwendungsspezifischen (Font für einen bestimmten Bericht einstellen) trennen.

Hallo PhliS,

ZitatDeine APIs stammen relativ sicher eh aus der gleichen Quelle (Kreft/Lebans) wie das Modul, das ich überarbeitet habe.

Ja, das ist die selbe Quelle. Das steht auch ganz oben in meinem Modul drin.
Ich hatte es hier nur nicht mit in den Code kopiert. ;-)

ZitatOption Compare Database
Option Explicit

' Original Code by Terry Kreft
' Modified by Stephen Lebans (http://lebans.com/)
'
' This code was revised on 2019-01-26 in a hurry
' by Philipp Stiefel (http://codekabinett.com) to
' make it run in x64 VBA-Applications.
' This is just the code that "worked for me" with
' a few superficial tests. I did not conduct a
' serious code review and do not take any
' responsibility for any defects in the code.


'************  Code Start  ***********

ZitatBei der Gelegenheit könntest du auch deinen Code sinnvoller strukturieren und die generische Funktionalität (Font-Dialog des Betriebssystems aufrufen) von der anwendungsspezifischen (Font für einen bestimmten Bericht einstellen) trennen.

Meinst Du immer jeweils für jeden Bericht?
Momentan ist es so, dass man im Hauptformular sich eine Schriftart
für den eigenen Firmennamen aussucht und diese Schrift wird dann für alle Berichte und Auswertungen für den Firmennamen benutz.
So wurde es von den Kollegen gewünscht.

LG
jagger

Hallo daolix,

muss ich bei
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


auch Änderungen vornehmen?
Ich kann leider nicht testen, da ich kein 64 bit Access habe.
Ich schicke das nur meinem Kollegen und der sagt dann,
ob es geht oder eben nicht.

Dim lLogFontAddress As Longptr, lMemHandle As Longptr

Private Type FONTSTRUC
  lStructSize As Long
  hwnd As LongPTR
  hdc As LongPTR
  lpLogFont As LongPTR
  iPointSize As Long
  Flags As Long
  rgbColors As Long
  lCustData As Long
  lpfnHook As LongPTR
  lpTemplateName As String
  hInstance As Long
  lpszStyle As String
  nFontType As Integer
  MISSING_ALIGNMENT As Integer
  nSizeMin As Long
  nSizeMax As Long
End Type

habe ich geändert. Ein Fehler kommt da nicht, aber es passiert auch nix.  :o

LG
jagger

Hallo
wie der Phil es schon erwähnte, wäre es einfacher gewesen seinen Code komplett zu übernehmen, denn da sind wohl alle UDT's (LOGFONT,FONTSTRUC, etc), DeklarationsProtos, Variablen und die richtige Bestimmung der UDT-Sizes (die Funktion LenB() verwenden statt der Funktion Len())  für 64bit enthalten. So müsstest du in deiner Funktion "DialogFont" z.B. die Zeile fs.lStructSize = Len(fs) durch fs.lStructSize = LenB(fs) ersetzen. Ich hab jetzt auch kein 64bit Office aber ich bin mir sicher das der Code von Phil funktioniert.

Hallo daolix,

ich habe jetzt das Modul von PhilS genommen und nur
"Test_DialogFont" zu "Font_DialogFont" geändert.

Die Dialogbox wird (kann nur in Access 32bit testen) wird geöffnet.

Beim Schließen der Dialogbox (mit ok) kommt jetzt die Fehlermeldung
"Laufzeitfehler 9 - Index außerhalb des gültigen Bereichs"

Private Sub Agenturname_DblClick(Cancel As Integer)
Dim lngString As Boolean
Dim AFX As String
Dim AFN As String
Dim AFS As String
Dim AFW As String
Dim AFI As String
Dim AFU As String
Dim LString As String
Dim LArray() As String
    lngString = Font_DialogFont(Me.XFont)
    XFN = Me.XFont
LString = XFN
LArray = Split(LString, ";")
MsgBox LString
AFN = LArray(0)
AFS = LArray(1)
AFW = LArray(2)
AFI = LArray(3)
AFU = LArray(4)

CurrentDb.Execute "UPDATE tab_int_Daten SET [FontNameAgentur] = '" & AFN & _
"',[FontSizeAgentur] = '" & AFS & "',[FontWeightAgentur] = " & AFW & _
",[FontItalicAgentur] = '" & AFI & "',[FontUnderlineAgentur] = '" & AFU & "'"
Font_Change ' Funktion

End Sub

"AFS = LArray(1)" wird dann markiert.

Über die msgbox habe ich festgestellt, dass das alte
"32ger Modul" z.B. "Empire BT;28;400;Falsch;Falsch"
Mit den neuen "64er Modul" kommt "Empire BT - Size:28"
Mit "LArray = Split(LString, " - ") wird "AFW = LArray(2)" markiert.

Es werden also offensichtlich nicht alle Parameter angezeigt und nicht durch ";" getrennt, sondern durch " - ".
Woran kann das liegen?

LG
jagger

Ok, fangen wir erstmal mit der Antwort auf die ältere Rückfrage an...

Zitat von: jagger am März 28, 2019, 13:31:13

ZitatBei der Gelegenheit könntest du auch deinen Code sinnvoller strukturieren und die generische Funktionalität (Font-Dialog des Betriebssystems aufrufen) von der anwendungsspezifischen (Font für einen bestimmten Bericht einstellen) trennen.

Meinst Du immer jeweils für jeden Bericht?

Die konkrete Funktionalität, auf deine Anwendung bezogen, ist hier erstmal irrelevant.

Du solltest dein Modul "Modul_FontPicker" aufteilen. Es vermischt zwei völlig unterschiedliche Abstraktionsebenen.
1.) Generischer Code um Funktionalität des Betriebssystems (den Font-Dialog) aufzurufen. - Dieser Code kann so in allen Anwendungen verwendet werden. Er hat nichts was nur speziell für deine Anwendung gedacht ist.
2.) Anwendungspezifischer Code, der nur in deiner ganz speziellen Anwendung funktionieren kann. Das ist mindestens alles was eine Referenz auf ein Formular oder Bericht deiner Anwendung enthält, aber im weiteren Sinne auch anderes, was nicht allgemeingültig ist.

Zitat von: jagger am März 29, 2019, 13:04:13ich habe jetzt das Modul von PhilS genommen und nur
"Test_DialogFont" zu "Font_DialogFont" geändert.

Geändert?Du meinst vermutlich umbenannt.
Deine Prozedur Font_DialogFont ist aber eine ganz klar eine rein anwendungsspezifische Funktionalität (Punkt 2. oben). Sie enthält Zugriff auf deine Tabellen und verwendet ein von dir definiertes Datenformat (Semikolon-getrennter String).  - Dies kann von generischer Funktionalität nicht abgedeckt werden.


Die Test_DialogFont Prozedur in dem meinem Modul war nur aus dem ursprünglichen Beispiel übernommen und zeigt eine Anwendungsmöglichkeit. Sie hat mit deiner Prozedur Font_DialogFont nichts zu tun, auch wenn deine Prozedur vermutlich aus dem ursprünglichen Beispielcode entstanden ist.


Vorgehen:
- Importiere mein Modul.
- Lösche aus deinem Modul Modul_FontPicker alles raus, was sich direkt auf die API-Aufrufe bezieht.
- Kompilieren.
Jetzt sollte deine Anwendung funktionieren.

Hallo PhilS,

okay, ich werde das nachher mal alles machen.
Eine Frage habe ich noch. Was meinst Du mit

ZitatSie enthält Zugriff auf deine Tabellen und verwendet ein von dir definiertes Datenformat (Semikolon-getrennter String).

also welche Stelle in meinem Code?

ZitatGeändert?Du meinst vermutlich umbenannt.

Ja, ich meine umbenannt. :)

LG
jagger

Hallo PhilS,

ich habe jetzt in der Funktion "Font_DialogFont"
"ctl=..." geändert.

        ctl = .Name & ";" & .Height & ";" & .Weight & ";" & .Italic & ";" & .UnderLine

Jetzt läuft es zumindest mit 32bit.

Deine Hinweise bezüglich der Vermischung werde ich jetzt auch noch umsetzten.

Danke Dir
LG
jagger

@alle,

also jetzt läuft es auch auf einem Access 64bit.
Vielen Dank an alle Mitwirkenden!

... übrigens, wenn man die Werte von dem Fontpicker zur weiteren Verwendung in einer Tabelle speichern will, z.B:
Private Sub txtFeld_DblClick(Cancel As Integer)
Dim lngString As Boolean
Dim AFX As String
Dim AFN As String
Dim AFS As String
Dim AFW As String
Dim AFI As Boolean
Dim AFU As Boolean
Dim LString As String
Dim LArray() As String
    lngString = Font_DialogFont(Me.XFont)
    XFN = Me.XFont
LString = XFN

LArray = Split(LString, ";")

AFN = LArray(0)
AFS = LArray(1)
AFW = LArray(2)
AFI = LArray(3)
AFU = LArray(4)

CurrentDb.Execute "UPDATE tab_Font_Daten SET [FontName] = '" & AFN & "',[FontSize] = '" & AFS & "',[FontWeight] = " & AFW & _
",[FontItalic] = " & BoolToString(AFI) & ",[FontUnderline] = " & BoolToString(AFU) & ""
End Sub

braucht man noch für "As Boolean"-Werte (Ja/Nein) eine kleine Funktion:
Public Function BoolToString(bol As Boolean) As String
If bol = True Then
BoolToString = "True"
Else
BoolToString = "False"
End If
End Function

==>... ,[FontItalic] = " & BoolToString(AFI) & " ...

Habe ich nach einigem Ausprobieren bei http://www.access-im-unternehmen.de/268.0.html (http://www.access-im-unternehmen.de/268.0.html) gefunden.

LG
jagger