Ms access 将访问列宽度的字符转换为Twips

我正在维护一些旧的VB6软件，需要根据要显示的字段字符的平均数以编程方式设置MS Access列的宽度，就像在Access中的“数据表”视图中一样

然而，在VB中，该值必须在Twips中指定，并且我在“字符数”和Twips之间转换时遇到了一些困难

例如，如果字体为Arial 10pt（96 DPI），并且我在Access中指定了“50个字符”，那么该值将通过VB中的

属性（“ColumnWidth”）

方法返回为“4530 Twips”。如果我在VB中通过

CreateProperty（“ColumnWidth”）

方法指定“4530”，Access中将显示“50”

基于Office 2010的规范和规范，我使用以下代码计算以Twips为单位的列宽，但对于上面的示例，返回值“5490”：

表格

'Identify normal style's font for Access
Dim Font As New StdFont
Font.Name = "Arial"
Font.Size = 10

'Calculate longest width of digits 0-9
Dim Digit As Integer
Dim MaxDigitWidth As Single
For Digit = 0 To 9
    Dim mdw As Single
    mdw = CalcTextWidth(Digit, Font)
    If mdw > MaxDigitWidth Then MaxDigitWidth = mdw
Next Digit

Dim MaxChars As Integer
Dim Width As Single, Pixels As Long, Twips As Long

'Identify number of characters to display horizontally
MaxChars = 50

'Adjust character value based on actual font metrics
Width = Int((MaxChars * MaxDigitWidth + 5) / MaxDigitWidth * 256) / 256

'Convert into screen resolution (TwipsPerPixelX = 1440 / 96 or 120 DPI)
Pixels = Int(((256 * Width + Int(128 / MaxDigitWidth)) / 256) * MaxDigitWidth)
Twips = Pixels * Screen.TwipsPerPixelX

模块

Private Declare Function CreateCompatibleDC Lib "Gdi32" (ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "Gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "Gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "Gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetTextExtentPoint32 Lib "Gdi32" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As SIZE) As Long

Private Type SIZE
    cx As Long
    cy As Long
End Type

'Calculate width in pixels of screen text
Public Function CalcTextWidth(ByVal Source As String, ByVal Font As StdFont) As Single
    Dim myFont As IFont
    Dim hFont As Long
    Dim mySize As Size
    Dim hDC As Long

    'Clone font
    Set myFont = New StdFont
    myFont.Name = Font.Name

    'Increase precision since GetTextExtentPoint32 returns a Long
    myFont.Size = Font.Size * 1000

    'Set device context as screen display for font metrics
    hDC = CreateCompatibleDC(0)

    'Calculate string width in pixels
    hFont = SelectObject(hDC, myFont.hFont)
    GetTextExtentPoint32 hDC, Source, Len(Source), mySize
    SelectObject hDC, hFont
    DeleteObject hFont
    DeleteDC hDC

    'Restore precision
    CalcTextWidth = mySize.cx / 1000
End Function

我还看到一篇关于如何在Excel中计算列宽的文章，但提供的示例似乎与为Office公开的算法相冲突

有没有想过我做错了什么

谢谢

**更新3/20**

下面是代码块的简化版本，它使用前面定义的

Font

和

Twips

设置

ColumnWidth

属性：

Dim db As Database
Dim td As TableDef
Dim prop As Property

Set db = CreateDatabase("db1.mdb", dbLangGeneral)
Set td = db.CreateTableDef("Table1")
td.Fields.Append td.CreateField("Field1", dbMemo)
db.TableDefs.Append td

Set prop = td.CreateProperty("DatasheetFontName", dbText, Font.Name): td.Properties.Append prop
Set prop = td.CreateProperty("DatasheetFontHeight", dbInteger, Font.Size): td.Properties.Append prop
Set prop = td.Fields("Field1").CreateProperty("ColumnWidth", dbInteger, Twips): td.Fields("Field1").Properties.Append prop

db.Close

另外，不确定这是否重要，但我使用的VB6 Service Pack 6具有以下参考：

• Visual Basic For Applications
• Visual Basic运行时对象和过程
• OLE自动化
• Microsoft DAO 3.6对象库
• Microsoft ActiveX数据对象2.5库
• Microsoft VBScript正则表达式5.5

---

在尝试了几个API来计算列宽后，包括

GetTextExtentPoint32

、

GetCharABCWidths

等，以及内置的

TextWidth（）

函数，由于舍入，这些函数都不能产生精确的测量值，我找到了一种使用Excel对象精确计算列宽的方法

在Excel中，列具有两个宽度属性：

ColumnWidth

和

width

ColumnWidth

是基于正常样式字体的最大数字0-9宽度水平显示的字符单位数。因此，如果定义了“50”的值，并且在单元格A1中输入了50个零，则所有数字都将可见

Width

是重新转换为普通字体像素的

ColumnWidth

值

值得注意的是，通过VB6为Excel电子表格设置

列宽

，可以使用字符单位；相反，访问表的

ColumnWidth

必须为twips

此外，Excel的常规样式字体可以更改，而Access似乎没有这样做的方法——可以为数据表设置默认字体，但这与常规样式字体不同

例如，如果定义了Arial 10 pt，并且将在50个字符处进行换行，那么指定50个字符单位的值似乎是合乎逻辑的；但是，58.8333实际上必须在Access中定义。此外，即使注册表项

默认字体名称

和

默认字体大小

设置为所需字体，Access似乎也在使用硬编码字体度量作为其计算的基础

下面的代码显示了如何使用Excel对象通过让Excel执行字符单位到像素的转换来计算Access的

列宽

。它还显示了如何计算单元格的行高，以便在不剪裁的情况下显示一定数量的行

请注意，Excel必须与VB6安装在同一工作站上，并且引用必须包括Microsoft DAO 3.6对象库

选项显式
私有声明函数CreateCompatibleDC Lib“gdi32”（ByVal hDC作为Long）作为Long
私有声明函数DeleteDC Lib“gdi32”（ByVal hDC作为Long）作为Long
私有声明函数GetDeviceCaps Lib“gdi32.dll”（ByVal hDC为Long，ByVal nIndex为Long）为Long
私有常量LOGPIXELSX长度=88
'########################################################################
'计算MS访问单元的高度
专用函数AccessHeight（ByVal MaxLines的长度）为单个
'设置要在不剪切的情况下显示的行数（基于常规样式字体的前导）
作为整数的Dim i
以字符串形式显示文本
对于i=1到MaxLines:txt=txt&“H”和IIf（iOption Explicit

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hDC As Long, ByVal nIndex As Long) As Long

Private Const LOGPIXELSX As Long = 88

'########################################################################

'Calculate height for an MS Access cell
Private Function AccessHeight(ByVal MaxLines As Long) As Single

    'Set number of lines to display without clipping (based on leading of Normal style font)
    Dim i As Integer
    Dim txt As String
    For i = 1 To MaxLines: txt = txt & "H" & IIf(i < MaxLines, vbCrLf, ""): Next

    'Measure height of lines (in twips); compensate for gridline padding
    '(note that device context is screen display since TextHeight a property of Form1)
    AccessHeight = TextHeight(txt) + 30
End Function

'########################################################################

'Calculate width for an MS Access cell
Private Function AccessWidth(ByVal MaxChars As Long) As Long
    Dim hDC, dpiX As Long
    Dim Excel, Workbook, Worksheet As Object
    Dim pixelsX As Single

    'Set device context as screen display and calculate horizontal DPI (96 or 120)
    hDC = CreateCompatibleDC(0)
    dpiX = GetDeviceCaps(hDC, LOGPIXELSX)
    DeleteDC hDC

    '#-------------------------------------------------------------------

    'Launch Excel as a system process
    Set Excel = CreateObject("Excel.Application")
    Set Workbook = Excel.Workbooks.Add
    Set Worksheet = Workbook.Worksheets.Add

    'Initialize Normal style so that one unit of column width equals width of one character
    With Workbook.Styles("Normal").Font
        .Name = Font.Name
        .Size = Font.Size
        .Bold = Font.Bold
        .Italic = Font.Italic
        .Underline = Font.Underline
        .Strikethrough = Font.Strikethrough
    End With

    '#-------------------------------------------------------------------

    'Set number of characters to display horizontally without wrapping (based on maximum width of digits 0-9)
    Worksheet.Cells(1, 1).ColumnWidth = MaxChars

    'Instruct Excel to convert from character units into screen pixels
    pixelsX = Worksheet.Cells(1, 1).Width * dpiX / 72

    'Convert screen pixels into twips
    AccessWidth = Int(pixelsX * 1440 / dpiX)

    'Kill system process
    Workbook.Close SaveChanges:=False
    Excel.Quit
End Function

'########################################################################

Private Sub Form_Load()

    'Identify Normal style font
    With Font
        .Name = "Arial"
        .Size = 10
        .Bold = False
        .Italic = False
        .Underline = False
        .Strikethrough = False
    End With

    '#-------------------------------------------------------------------

    Dim db As Database
    Dim td As TableDef
    Dim rs As Recordset
    Dim prop As Property
    Dim i As Integer

    'Create database
    ChDrive App.Path: ChDir App.Path
    Set db = CreateDatabase("db1.mdb", dbLangGeneral)
    Set td = db.CreateTableDef("Table1")
    td.Fields.Append td.CreateField("Field1", dbMemo)
    db.TableDefs.Append td

    'Set font
    Set prop = td.CreateProperty("DatasheetFontName", dbText, Font.Name): td.Properties.Append prop
    Set prop = td.CreateProperty("DatasheetFontHeight", dbInteger, Font.Size): td.Properties.Append prop

    'Set row height
    Dim MaxLines As Long
    MaxLines = 9
    Set prop = td.CreateProperty("RowHeight", dbInteger, AccessHeight(MaxLines)): td.Properties.Append prop

    'Set column width
    Dim MaxChars As Long
    MaxChars = 50
    Set prop = td.Fields("Field1").CreateProperty("ColumnWidth", dbInteger, AccessWidth(MaxChars)): td.Fields("Field1").Properties.Append prop

    'Add a record
    Set rs = db.OpenRecordset("Table1")
    rs.AddNew
    For i = 1 To MaxLines: rs!Field1 = rs!Field1 & String$(MaxChars, CStr(i)) & IIf(i < MaxLines, vbCrLf, ""): Next
    rs.Update
    rs.Close

    db.Close
    End
End Sub