VFP如何调用ChooseFont（Windows API标准字体选择对话框）？ - VFP论坛

已结贴√ 问题点数：100 回复次数：11

VFP如何调用ChooseFont（Windows API标准字体选择对话框）？

因为需要为用户提供完整的系统字体选择，比如：“下划线、删除线、字体颜色”等等GetFont()得不到的选项，就想到了ChooseFont。提问DeepSeek，它倒是刷刷刷立刻实现了一大堆代码，可惜搞得有些复杂，且运行不起来。主要原因可能是LOGFONT和CHOOSEFONT两个struct（结构体）在VFP中实现的内存问题吧。感觉上，DeepSeek的代码皆是从VB6转译过来的，当中掺杂了无数幻觉错误——怎么破？

DeepSeek提供的代码（略）。

正确的代码完整版见：

https://bbs.bc-cn.net/viewthread.php?tid=514359&page=2#pid2791699

非常感谢诸位英雄对这个帖子的关注与帮助！

[此贴子已经被作者于2025-6-12 18:07编辑过]

搜索更多相关主题的帖子: 代码　 VFP　选择　字体　对话框　

第 2 楼

得分:0

以下是引用sam_jiang在2025-6-9 20:35:27的发言：

sys（2600）函数用法有问题。lnPtr = SYS(2600, 0, LEN(tcBuffer))，这句是有问题的，你没有分配内存

实在搞不懂，DeepSeek为什么要虚构出第二个参数为0的SYS(2600, 0, ...)调用方法。于是，继续提问：

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

问：vfp如何获取一个字符串变量的绝对内存地址？比如：lcLogFontBuffer = REPLICATE(CHR(0), LEN(lcLogFont))，如何得到lcLogFontBuffer的地址？

DeepSeek答：在 Visual FoxPro (VFP) 中获取字符串变量的绝对内存地址确实需要特别注意，因为 VFP 的内存管理机制与 C/C++ 等低级语言不同。
方法2：使用 WinAPI 的 GlobalAlloc 和 GlobalLock 函数
DECLARE INTEGER GlobalAlloc IN kernel32 INTEGER wFlags, INTEGER dwBytes
DECLARE INTEGER GlobalLock IN kernel32 INTEGER hMem
DECLARE INTEGER GlobalUnlock IN kernel32 INTEGER hMem
DECLARE INTEGER GlobalFree IN kernel32 INTEGER hMem

#DEFINE GMEM_FIXED 0x0000
#DEFINE GMEM_ZEROINIT 0x0040

FUNCTION AllocStringToMemAPI(tcString)
    LOCAL lnSize, hMem, lpMem
    lnSize = LEN(tcString)
    hMem = GlobalAlloc(GMEM_FIXED + GMEM_ZEROINIT, lnSize)
    IF hMem = 0
        RETURN 0
    ENDIF
    lpMem = GlobalLock(hMem)
    = SYS(2600, lpMem, lnSize, tcString)
    = GlobalUnlock(hMem)
    RETURN lpMem
ENDFUNC

FUNCTION FreeMemAPI(lnPointer)
    LOCAL hMem
    IF lnPointer != 0
        hMem = GlobalLock(lnPointer)
        = GlobalUnlock(lnPointer)
        = GlobalFree(hMem)
    ENDIF
ENDFUNC
--------------------------------
这个回答估计靠谱一些吧。

第 3 楼

得分:0

以下是引用sam_jiang在2025-6-9 22:36:32的发言：

给你改了代码，你看看！

大侠！非常感谢！至少代码总算可以运行，字体选择对话框出现啦！！

Win11+VFP9经测试可能存在一些问题：

1、lnPtr = globalalloc(0x40, LEN(tcBuffer))这一句，0x42很不稳定，可能还是要按DeepSeek的范例代码，改用0x40（GMEM_MOVEABLE|GMEM_ZEROINIT）。
2、提取的字体结果大多是错的：【字体】提取结果空白；【字号】数值古怪，非常大；粗体、斜体、下划线、删除线都不对；颜色值不对。

再次感谢！

[此贴子已经被作者于2025-6-10 06:59编辑过]

第 4 楼

得分:0

以下是引用schtg在2025-6-10 07:14:41的发言：

我收集的大侠的代码，试一试可否？
loFont = createobject('')
loFont.ShowFont()
messagebox(loFont.fontsize)

ShowFont对话框跟VFP自带的Getfont()区别不大，与ChooseFont对话框相比，少了很多选项：

图片附件: 游客没有浏览图片的权限，请登录或注册

第 5 楼

得分:0

能弹出字体选择对话框，这意味着：
前半部分错误较少，只是默认【字号】搞乱了。
测试了一下，若希望默认12号字，将ShowFontDialog()的第5个参数改为16即可（12+4=16）。具体原因暂不太清楚，不过这个小问题几乎可以忽略，因默认值不重要。

问题主要在后半部分：解析字体选择对话框的返回值，存在不少错误。

首先，之前让DeepSeek的一大堆“骚操作”给迷惑了！看了半天，才想起来：
lnPointSize = CTOBIN(SUBSTR(lcChooseFont, 17, 2), "2RS") * 65536 + ;
CTOBIN(SUBSTR(lcChooseFont, 19, 2), "2RS")
其实，DeepSeek的真实意图，无非就是：
lnPointSize = CTOBIN(SUBSTR(lcChooseFont, 17, 4), "4RS")
结果它给弄得乱七八糟！——NND！

其次，跟踪了一下ChooseFont(@lcChooseFont)的返回值，lcChooseFont的内容基本正常（即，CHOOSEFONT 结构基本没问题）；然而，lcLogFontBuffer完全空白（即，LOGFONT 结构问题大大的），难怪【字体】、【下划线】、【删除线】那些选项，全部解析错误。网上搜了一下LOGFONT 结构的字节长度，好像不是60？这么重要的东西，DeepSeek也敢胡来？！

唉，图样图森破——人生处处是陷阱啊！

第 6 楼

得分:0

以下是引用schtg在2025-6-10 11:17:15的发言：
DO decl
#DEFINE GMEM_FIXED                 0
#DEFINE LF_FACESIZE               32
#DEFINE FW_NORMAL                400
#DEFINE DEFAULT_CHARSET            1
#DEFINE OUT_DEFAULT_PRECIS         0
#DEFINE CLIP_DEFAULT_PRECIS        0
#DEFINE DEFAULT_QUALITY            0
#DEFINE DEFAULT_PITCH              0
#DEFINE CF_SCREENFONTS             1
#DEFINE CF_INITTOLOGFONTSTRUCT    64
#DEFINE CF_EFFECTS               256
#DEFINE CF_FORCEFONTEXIST      65536

LOCAL lcChooseFont, lcLogFont, hLogFont, lcFontFace
lcLogFont = num2dword(16) +;
        num2dword(0)  +;
        num2dword(0)  +;
        num2dword(0)  +;
        num2dword(FW_NORMAL) +;
        Chr(1) +;
        Chr(0) +;
        Chr(0) +;
        Chr(DEFAULT_CHARSET)     +;
        Chr(OUT_DEFAULT_PRECIS)  +;
        Chr(CLIP_DEFAULT_PRECIS) +;
        Chr(DEFAULT_QUALITY)     +;
        Chr(DEFAULT_PITCH)       +;
        PADR("Times New Roman"+Chr(0),32)

    lnLogFontSize = 60
    hLogFont = GlobalAlloc(GMEM_FIXED, lnLogFontSize)

    DECLARE RtlMoveMemory IN kernel32 As String2Heap;
        INTEGER Destination, STRING @ Source,;
        INTEGER nLength
    = String2Heap (hLogFont, @lcLogFont, lnLogFontSize)

    lcChooseFont = num2dword(60) +;
        num2dword(0) +;
        num2dword(0) +;
        num2dword(hLogFont) +;
        num2dword(0) +;
        num2dword(CF_SCREENFONTS + CF_EFFECTS +;
            CF_INITTOLOGFONTSTRUCT + CF_FORCEFONTEXIST) +;
        num2dword(0) +;
        num2dword(0) +;
        num2dword(0) +;
        num2dword(0) +;
        num2dword(0) +;
        num2dword(0) +;
        num2dword(0) +;
        num2dword(0) +;
        num2dword(0)

    IF ChooseFont (@lcChooseFont) <> 0
        DECLARE RtlMoveMemory IN kernel32 As Heap2String;
            STRING @Dest, INTEGER Source, INTEGER nLength
        = Heap2String (@lcLogFont, hLogFont, lnLogFontSize)
    ENDIF
    = GlobalFree (hLogFont)
RETURN

PROCEDURE  decl
    DECLARE INTEGER ChooseFont IN comdlg32 STRING @lpcf
    DECLARE INTEGER GlobalFree IN kernel32 INTEGER hMem
    DECLARE INTEGER GlobalAlloc IN kernel32;
        INTEGER wFlags,;
        INTEGER dwBytes

FUNCTION  num2dword (lnValue)
#DEFINE m0       256
#DEFINE m1     65536
#DEFINE m2  16777216
    LOCAL b0, b1, b2, b3
    b3 = Int(lnValue/m2)
    b2 = Int((lnValue - b3*m2)/m1)
    b1 = Int((lnValue - b3*m2 - b2*m1)/m0)
    b0 = Mod(lnValue, m0)
RETURN Chr(b0)+Chr(b1)+Chr(b2)+Chr(b3)

schtg英雄，太感谢啦！这一段代码基本等效于#5的sam_jiang英雄的代码。
区别在于，schtg英雄的代码没有bug，检测返回值LOGFONT 结构体的内部，是正确的！
虽说只有前半部分，缺失了后半部分的返回值解析，可，只要那两个结构体本身是正确的，那么，后半部分的问题就比较好办啦！

第 7 楼

得分:0

以下是引用sam_jiang在2025-6-10 11:46:45的发言：
typedef struct tagLOGFONT {
    LONG lfHeight;          // 字体高度（逻辑单位）
    LONG lfWidth;           // 字符平均宽度（0表示自动适配）
    LONG lfEscapement;      // 文本行旋转角度（单位：0.1度）
    LONG lfOrientation;     // 字符基线旋转角度（单位：0.1度）
    LONG lfWeight;          // 字体粗细（0-1000，如400为正常，700为粗体）
    BYTE lfItalic;          // 斜体标志（非零表示斜体）
    BYTE lfUnderline;       // 下划线标志（非零表示下划线）
    BYTE lfStrikeOut;       // 删除线标志（非零表示删除线）
    BYTE lfCharSet;         // 字符集（如ANSI_CHARSET、GB2312_CHARSET）
    BYTE lfOutPrecision;    // 输出精度（如OUT_DEFAULT_PRECIS）
    BYTE lfClipPrecision;   // 裁剪精度（如CLIP_DEFAULT_PRECIS）
    BYTE lfQuality;         // 输出质量（如DEFAULT_QUALITY、ANTIALIASED_QUALITY）
    BYTE lfPitchAndFamily;  // 字体间距和族（如FF_SWISS | DEFAULT_PITCH）
    TCHAR lfFaceName;   // 字体名称（如"Arial"）
} LOGFONT;

非常感谢sam_jiang英雄的帮助！
这是schtg英雄那段代码的运行结果，终于得到了CHOOSEFONT和LOGFONT两个结构体的完整返回值！
我眼瞅着那两个结果，闪闪发光，仿佛看到了美丽的耶利亚女郎！

图片附件: 游客没有浏览图片的权限，请登录或注册

第 8 楼

得分:0

简单地合并了两份代码，念去去，温一壶烧酒，酬谢诸位英雄！

程序代码：

DO decl
#DEFINE GMEM_FIXED                 0
#DEFINE LF_FACESIZE               32
#DEFINE FW_BOLD                  700
#DEFINE FW_NORMAL                400
#DEFINE DEFAULT_CHARSET            1
#DEFINE OUT_DEFAULT_PRECIS         0
#DEFINE CLIP_DEFAULT_PRECIS        0
#DEFINE DEFAULT_QUALITY            0
#DEFINE DEFAULT_PITCH              0
#DEFINE CF_SCREENFONTS             1
#DEFINE CF_INITTOLOGFONTSTRUCT    64
#DEFINE CF_EFFECTS               256
#DEFINE CF_FORCEFONTEXIST      65536

LOCAL lcChooseFont, lcLogFontBuffer, hLogFont, lcFontFace
lcLogFontBuffer = num2dword(16) +;
        num2dword(0)  +;
        num2dword(0)  +;
        num2dword(0)  +;
        num2dword(FW_NORMAL) +;
        Chr(0) +;
        Chr(0) +;
        Chr(0) +;
        Chr(DEFAULT_CHARSET)     +;
        Chr(OUT_DEFAULT_PRECIS)  +;
        Chr(CLIP_DEFAULT_PRECIS) +;
        Chr(DEFAULT_QUALITY)     +;
        Chr(DEFAULT_PITCH)       +;
        PADR("Times New Roman"+Chr(0),32)

    lnLogFontSize = 60
    hLogFont = GlobalAlloc(GMEM_FIXED, lnLogFontSize)

    DECLARE RtlMoveMemory IN kernel32 As String2Heap;
        INTEGER Destination, STRING @ Source,;
        INTEGER nLength
    = String2Heap (hLogFont, @lcLogFontBuffer, lnLogFontSize)

    lcChooseFont = num2dword(60) +;
        num2dword(0) +;
        num2dword(0) +;
        num2dword(hLogFont) +;
        num2dword(0) +;
        num2dword(CF_SCREENFONTS + CF_EFFECTS +;
            CF_INITTOLOGFONTSTRUCT + CF_FORCEFONTEXIST) +;
        num2dword(0) +;
        num2dword(0) +;
        num2dword(0) +;
        num2dword(0) +;
        num2dword(0) +;
        num2dword(0) +;
        num2dword(0) +;
        num2dword(0) +;
        num2dword(0)

    IF ChooseFont (@lcChooseFont) <> 0
        DECLARE RtlMoveMemory IN kernel32 As Heap2String;
            STRING @Dest, INTEGER Source, INTEGER nLength
        = Heap2String (@lcLogFontBuffer, hLogFont, lnLogFontSize)

    *-----------解析ChooseFont()返回值开始------------*
        LOCAL lnPointSize, lnColor, lcFaceName, lcResult
        
        * 从 CHOOSEFONT 结构中获取点大小 (单位是1/10点)
        lnPointSize = CTOBIN(SUBSTR(lcChooseFont, 17, 4), "4RS")
        lnPointSize = lnPointSize / 10
        
        * 从 CHOOSEFONT 结构中获取颜色
        lnColor = CTOBIN(SUBSTR(lcChooseFont, 25, 4), "4RS")
        
        * 从 LOGFONT 结构中获取字体名称(偏移量28开始，32字节)
        lcFaceName = SUBSTR(lcLogFontBuffer, 29, LF_FACESIZE)
        lcFaceName = LEFT(lcFaceName, AT(CHR(0), lcFaceName) - 1)
        
        * 从 LOGFONT 结构中获取样式信息
        LOCAL lnWeight, llBold, llItalic, llUnderline, llStrikeOut
        
        lnWeight = CTOBIN(SUBSTR(lcLogFontBuffer, 17, 4), "4RS")
        llBold = (lnWeight >= FW_BOLD)
        
        llItalic = (ASC(SUBSTR(lcLogFontBuffer, 21, 1)) <> 0)
        llUnderline = (ASC(SUBSTR(lcLogFontBuffer, 22, 1)) <> 0)
        llStrikeOut = (ASC(SUBSTR(lcLogFontBuffer, 23, 1)) <> 0)
        
        * 返回结果
        lcResult = lcFaceName + CHR(0) + ;
                  TRANSFORM(lnPointSize) + CHR(0) + ;
                  IIF(llBold, "1", "0") + CHR(0) + ;
                  IIF(llItalic, "1", "0") + CHR(0) + ;
                  IIF(llUnderline, "1", "0") + CHR(0) + ;
                  IIF(llStrikeOut, "1", "0") + CHR(0) + ;
                  TRANSFORM(lnColor)

    IF !EMPTY(lcResult)
        * 解析返回结果
        ALINES(laFont, lcResult, 0, CHR(0))
       
        * 显示选择结果
        lcMessage = "字体: " + laFont[1] + CHR(13) + ;
               "字号: " + laFont[2] + CHR(13) + ;
               "粗体: " + IIF(laFont[3] = "1", "是", "否") + CHR(13) + ;
               "斜体: " + IIF(laFont[4] = "1", "是", "否") + CHR(13) + ;
               "下划线: " + IIF(laFont[5] = "1", "是", "否") + CHR(13) + ;
               "删除线: " + IIF(laFont[6] = "1", "是", "否") + CHR(13) + ;
               "颜色值: " + laFont[7]
       
        MESSAGEBOX(lcMessage, 64, "字体选择结果")
    ELSE
        MESSAGEBOX("用户取消了字体选择", 64, "提示")
    ENDIF
    *-----------解析ChooseFont()返回值结束------------*

    ENDIF
    = GlobalFree (hLogFont)
RETURN

PROCEDURE  decl
    DECLARE INTEGER ChooseFont IN comdlg32 STRING @lpcf
    DECLARE INTEGER GlobalFree IN kernel32 INTEGER hMem
    DECLARE INTEGER GlobalAlloc IN kernel32;
        INTEGER wFlags,;
        INTEGER dwBytes

FUNCTION  num2dword (lnValue)
#DEFINE m0       256
#DEFINE m1     65536
#DEFINE m2  16777216
    LOCAL b0, b1, b2, b3
    b3 = Int(lnValue/m2)
    b2 = Int((lnValue - b3*m2)/m1)
    b1 = Int((lnValue - b3*m2 - b2*m1)/m0)
    b0 = Mod(lnValue, m0)
RETURN Chr(b0)+Chr(b1)+Chr(b2)+Chr(b3)

第 9 楼

得分:0

返回值当中的颜色值一项，是个整型数，经测试其数值没有问题。若不放心，可以将返回值直接赋给某个控件的forecolor属性，看一眼，核实一下。假如看不惯整数颜色值，找个函数转换为RGB表示法即可。

相关函数VfpColor2Html()，见：

https://bbs.bc-cn.net/thread-514363-1-1.html

[此贴子已经被作者于2025-6-12 18:03编辑过]

第 10 楼

得分:0

讲真，若非有DeepSeek的啰哩啰嗦代码在前，一般人是很难看懂10#代码的，异常简洁，然而以硬编码字符串模拟结构体，完全无注释，在外人眼中，等同于“天书”！借助DeepSeek的注解，就能轻易读懂了，且能欣赏到大侠代码的精妙之处。

写代码有DeepSeek帮忙，相当于一个人带了一个Team，还不花钱，纯免费！DeepSeek虽无法解决100%的问题，然而，已解决85%甚至更高的问题了！