функц возвр в см длину и высоту строки

[uzer_@]

есть такая функция возвращ длину и высоту строки VBA на нее ругается с помощью этой функции можно через santimetrstopoints добиться выравнивания в текстбоксе, задавая длну ширину. вопрос-сделать так чтоб VBA не ругался на нее.

Attribute VB_Name = "mdlFont"

'-----------------------------------------------------------------------
' GetTextPoint - определяет длину и высоту строки указанного шрифта
'-----------------------------------------------------------------------


Option Explicit

Public Type POINTAPI
x As Long
y As Long
End Type

'used with fnWeight
Private Const FW_DONTCARE = 0
Private Const FW_THIN = 100
Private Const FW_EXTRALIGHT = 200
Private Const FW_LIGHT = 300
Private Const FW_NORMAL = 400
Private Const FW_MEDIUM = 500
Private Const FW_SEMIBOLD = 600
Private Const FW_BOLD = 700
Private Const FW_EXTRABOLD = 800
Private Const FW_HEAVY = 900
Private Const FW_BLACK = FW_HEAVY
Private Const FW_DEMIBOLD = FW_SEMIBOLD
Private Const FW_REGULAR = FW_NORMAL
Private Const FW_ULTRABOLD = FW_EXTRABOLD
Private Const FW_ULTRALIGHT = FW_EXTRALIGHT
'used with fdwCharSet
Private Const ANSI_CHARSET = 0
Private Const DEFAULT_CHARSET = 1
Private Const SYMBOL_CHARSET = 2
Private Const SHIFTJIS_CHARSET = 128
Private Const HANGEUL_CHARSET = 129
Private Const CHINESEBIG5_CHARSET = 136
Private Const OEM_CHARSET = 255
'used with fdwOutputPrecision
Private Const OUT_CHARACTER_PRECIS = 2
Private Const OUT_DEFAULT_PRECIS = 0
Private Const OUT_DEVICE_PRECIS = 5
'used with fdwClipPrecision
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const CLIP_CHARACTER_PRECIS = 1
Private Const CLIP_STROKE_PRECIS = 2
'used with fdwQuality
Private Const DEFAULT_QUALITY = 0
Private Const DRAFT_QUALITY = 1
Private Const PROOF_QUALITY = 2
'used with fdwPitchAndFamily
Private Const DEFAULT_PITCH = 0
Private Const FIXED_PITCH = 1
Private Const VARIABLE_PITCH = 2
'used with SetBkMode
Private Const OPAQUE = 2
Private Const TRANSPARENT = 1

Private Const LOGPIXELSY = 90
Private Const MM_TEXT = 1

Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As POINTAPI) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetMapMode Lib "gdi32" (ByVal hdc As Long, ByVal nMapMode As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Boolean, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator 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 ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long


Public Function GetTextPoint(sText As String, sNameFace As String, nSize As Integer) As POINTAPI
' Определяет длину и высоту строки указанного шрифта.
' возвращает структуру POINTAPI: x-длина, y-высота строки,
' если возникла ошибка, то возвращает 0.
' [sText] - строка с текстом
' [sNameFace] - имя установленного в системе шрифта, не более 31 символа
' (например: Arial, Times New Roman, и т.д.)
' [nSize] - размер шрифта в пунктах

Dim hdc As Long, hwnd As Long
Dim PrevMapMode As Long
Dim lFont As Long, lOldFont As Long

On Error GoTo Err_
' получение дескриптора desktop
hwnd = GetDesktopWindow()
' получение device context desktop'а
hdc = GetWindowDC(hwnd)

If hdc > 0 Then
' устанавливаем режим отображ. в пикселях
PrevMapMode = SetMapMode(hdc, MM_TEXT)

' создаем лог. шрифт с задан. парам-ми
lFont = CreateMyFont(sNameFace, nSize)

If lFont > 0 Then
' выбираем его в конт. устройства
lOldFont = SelectObject(hdc, lFont)

' получаем высоту и длину строки
GetTextExtentPoint32 hdc, sText, Len(sText), GetTextPoint

' возвращаем обратно режим отображения
PrevMapMode = SetMapMode(hdc, PrevMapMode)
' возвращаем обратно шрифт по умолч.
lOldFont = SelectObject(hdc, lOldFont)
' удаляем наш шрифт
DeleteObject (lFont)
End If

' освобождаем device context
ReleaseDC hwnd, hdc
End If


Ex_:
Exit Function

Err_:
GetTextPoint.x = 0
GetTextPoint.y = 0
Resume Ex_
End Function


'--------------------------------------------------------------------
'----- Вспомогательные функции -------------------------
'--------------------------------------------------------------------
Private Function CreateMyFont(sNameFace As String, nSize As Integer) As Long
'Создает логический шрифт с заданными параметрами

If Len(sNameFace) < 32 Then
CreateMyFont = CreateFont(-MulDiv(nSize, GetDeviceCaps(GetDesktopWindow, LOGPIXELSY), 72), 0, 0, 0, FW_NORMAL, False, False, False, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, sNameFace & Chr(0))
Else
CreateMyFont = 0
End If
End Function

[Vitaly1]

А что неработает то?.. Я скопировал все, что ты написал в модуль макросов, и запустил функцию как указано ниже, и все заработало:

Код: Выделить всё

Sub nnn()
Dim p As POINTAPI
p = GetTextPoint("Не позволитеьно быть ничем!", "Times New Roman", 12)
MsgBox "Ширина:" & p.x
End Sub

[uzer_@]

после
Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As POINTAPI) As Long
пишет вот это
Only comments may appear after End Sub, End Function, or End Property

[K.Sergey]

после
пишет вот это
Only comments may appear after End Sub, End Function, or End Property

И ведь правильно пишет. Ты эту строку вставь перед ПЕРВОЙ процедурой или функцией в модуле.

[Vitaly1]

вот это все вставляю, и запускаю nnn и все работает!

Код: Выделить всё

'-----------------------------------------------------------------------
' GetTextPoint - определяет длину и высоту строки указанного шрифта
'-----------------------------------------------------------------------


Option Explicit

Public Type POINTAPI
x As Long
y As Long
End Type

'used with fnWeight
Private Const FW_DONTCARE = 0
Private Const FW_THIN = 100
Private Const FW_EXTRALIGHT = 200
Private Const FW_LIGHT = 300
Private Const FW_NORMAL = 400
Private Const FW_MEDIUM = 500
Private Const FW_SEMIBOLD = 600
Private Const FW_BOLD = 700
Private Const FW_EXTRABOLD = 800
Private Const FW_HEAVY = 900
Private Const FW_BLACK = FW_HEAVY
Private Const FW_DEMIBOLD = FW_SEMIBOLD
Private Const FW_REGULAR = FW_NORMAL
Private Const FW_ULTRABOLD = FW_EXTRABOLD
Private Const FW_ULTRALIGHT = FW_EXTRALIGHT
'used with fdwCharSet
Private Const ANSI_CHARSET = 0
Private Const DEFAULT_CHARSET = 1
Private Const SYMBOL_CHARSET = 2
Private Const SHIFTJIS_CHARSET = 128
Private Const HANGEUL_CHARSET = 129
Private Const CHINESEBIG5_CHARSET = 136
Private Const OEM_CHARSET = 255
'used with fdwOutputPrecision
Private Const OUT_CHARACTER_PRECIS = 2
Private Const OUT_DEFAULT_PRECIS = 0
Private Const OUT_DEVICE_PRECIS = 5
'used with fdwClipPrecision
Private Const CLIP_DEFAULT_PRECIS = 0
Private Const CLIP_CHARACTER_PRECIS = 1
Private Const CLIP_STROKE_PRECIS = 2
'used with fdwQuality
Private Const DEFAULT_QUALITY = 0
Private Const DRAFT_QUALITY = 1
Private Const PROOF_QUALITY = 2
'used with fdwPitchAndFamily
Private Const DEFAULT_PITCH = 0
Private Const FIXED_PITCH = 1
Private Const VARIABLE_PITCH = 2
'used with SetBkMode
Private Const OPAQUE = 2
Private Const TRANSPARENT = 1

Private Const LOGPIXELSY = 90
Private Const MM_TEXT = 1

Private Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As POINTAPI) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetMapMode Lib "gdi32" (ByVal hdc As Long, ByVal nMapMode As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal nHeight As Long, ByVal nWidth As Long, ByVal nEscapement As Long, ByVal nOrientation As Long, ByVal fnWeight As Long, ByVal fdwItalic As Boolean, ByVal fdwUnderline As Boolean, ByVal fdwStrikeOut As Boolean, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator 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 ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long


Public Function GetTextPoint(sText As String, sNameFace As String, nSize As Integer) As POINTAPI
' Определяет длину и высоту строки указанного шрифта.
' возвращает структуру POINTAPI: x-длина, y-высота строки,
' если возникла ошибка, то возвращает 0.
' [sText] - строка с текстом
' [sNameFace] - имя установленного в системе шрифта, не более 31 символа
' (например: Arial, Times New Roman, и т.д.)
' [nSize] - размер шрифта в пунктах

Dim hdc As Long, hwnd As Long
Dim PrevMapMode As Long
Dim lFont As Long, lOldFont As Long

On Error GoTo Err_
' получение дескриптора desktop
hwnd = GetDesktopWindow()
' получение device context desktop'а
hdc = GetWindowDC(hwnd)

If hdc > 0 Then
' устанавливаем режим отображ. в пикселях
PrevMapMode = SetMapMode(hdc, MM_TEXT)

' создаем лог. шрифт с задан. парам-ми
lFont = CreateMyFont(sNameFace, nSize)

If lFont > 0 Then
' выбираем его в конт. устройства
lOldFont = SelectObject(hdc, lFont)

' получаем высоту и длину строки
GetTextExtentPoint32 hdc, sText, Len(sText), GetTextPoint

' возвращаем обратно режим отображения
PrevMapMode = SetMapMode(hdc, PrevMapMode)
' возвращаем обратно шрифт по умолч.
lOldFont = SelectObject(hdc, lOldFont)
' удаляем наш шрифт
DeleteObject (lFont)
End If

' освобождаем device context
ReleaseDC hwnd, hdc
End If


Ex_:
Exit Function

Err_:
GetTextPoint.x = 0
GetTextPoint.y = 0
Resume Ex_
End Function


'--------------------------------------------------------------------
'----- Вспомогательные функции -------------------------
'--------------------------------------------------------------------
Private Function CreateMyFont(sNameFace As String, nSize As Integer) As Long
'Создает логический шрифт с заданными параметрами

If Len(sNameFace) < 32 Then
CreateMyFont = CreateFont(-MulDiv(nSize, GetDeviceCaps(GetDesktopWindow, LOGPIXELSY), 72), 0, 0, 0, FW_NORMAL, False, False, False, DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, PROOF_QUALITY, DEFAULT_PITCH, sNameFace & Chr(0))
Else
CreateMyFont = 0
End If
End Function

Sub nnn()
Dim p As POINTAPI
p = GetTextPoint("Не позволитеьно быть ничем!", "Times New Roman", 12)
MsgBox "Ширина:" & p.x
End Sub

Может ты вот эту фигню в начале написал
Attribute VB_Name = "mdlFont"
так ее писать не надо!

[uzer_@]

я жутко извиняюсь, это называется учите матчасть. с дуру не разобравшись, переменные не поместил в секцию декларейшн модуля, а скопировал после н-ого макроса (идиот). за ответ спасибо.