我维护一些旧的VB6软件，需要根据要显示的平均字段字符数以编程方式设置MS Access列的宽度，就像在Access中的数据表视图中一样。
但是，在VB中，必须在Twips中指定该值，并且我在“＃34;字符数”和“＃34;”之间转换时遇到一些困难。和缇。
例如，如果字体是Arial 10pt（96 DPI），我指定＆＃34; 50个字符＆＃34;在Access中，该值返回为＆＃34; 4530 Twips＆＃34;通过VB中的Properties("ColumnWidth")方法。如果我指定＆＃34; 4530＆＃34;通过VB中的CreateProperty("ColumnWidth")方法，＆＃34; 50＆＃34;在Access。中显示。
根据Office 2010的Column Class规范和GetTextExtentPoint32规范，我使用以下代码计算Twips中的列宽，但对于上面的示例，值＆＃34; 5490＆＃34;而是返回：
FORM
'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
MODULE
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中计算列宽的MS Knowledge Base文章，但提供的示例似乎与Office公开的算法相冲突。
关于我做错了什么的想法？
感谢。
** 更新3/20 **
这是代码块的简化版本，它使用之前定义的ColumnWidth和Font来设置Twips属性：
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包含以下参考：
答案 0 :(得分：0)
尝试使用多个API来计算列宽，包括GetTextExtentPoint32，GetCharABCWidths和其他内容，以及内置的TextWidth()函数后，由于四舍五入，所有这些都无法生成精确的测量值，我想方设法精确地使用 Excel对象。
在Excel中，列具有两个宽度属性：ColumnWidth和Width。
ColumnWidth是根据Normal样式字体的最大数字0-9宽度水平显示的字符单元数。因此，如果值为＆＃34; 50＆＃34;已定义并在单元格A1中输入50个零，所有数字都将可见。
Width是将ColumnWidth值重新转换为Normal样式字体的像素。
值得注意的是，通过VB6为Excel电子表格设置ColumnWidth可以用字符单位完成;相反，Access表的ColumnWidth必须是缇。
此外，可以更改Excel的Normal样式字体，而对于Access来说似乎没有这样做的方法 - 可以为数据表设置默认字体，但这不是＆＃39;与普通样式字体相同。
例如，如果定义了Arial 10 pt并且将以50个字符进行换行，那么应该指定50个字符单位的值似乎是合乎逻辑的;但是，实际上必须在Access中定义 58.8333 。此外，即使注册表项Default Font Name和Default Font Size设置为所需的字体，Access似乎也使用硬编码字体指标作为其计算的基础。
下面的代码显示了如何使用Excel对象通过让Excel执行字符单位到像素的转换来计算Access的ColumnWidth。它还显示了如何计算单元格的行高，以便显示一定数量的行而不会剪切。
请注意，Excel必须与VB6安装在同一工作站上，并且引用必须包含 Microsoft DAO 3.6对象库。
Option 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