-

   rss_sql_ru_access_programming

 - e-mail

 

 -

 LiveInternet.ru:
: 16.03.2006
:
:
: 4

:


4 -

, 13 2019 . 13:02 +
!
---------------

,
.
,
.


1( ). .
---------------
.
Option Compare Database
Option Explicit

Private Declare Function apiGetDC Lib "user32" Alias "GetDC" (ByVal hWnd As Long) As Long
Private Declare Function apiDeleteDC Lib "gdi32" Alias "DeleteDC" (ByVal hdc As Long) As Long
Private Declare Function apiDeleteObject Lib "gdi32" Alias "DeleteObject" (ByVal obj As Long) As Long

Private Declare Function apiCreateFont Lib "gdi32" Alias "CreateFontA" _
    (ByVal LH As Long, _
    ByVal LW1 As Long, _
    ByVal LE As Long, _
    ByVal LO As Long, _
    ByVal LW As Long, _
    ByVal LI As Long, _
    ByVal LU As Long, _
    ByVal LS As Long, _
    ByVal LC As Long, _
    ByVal LOP As Long, _
    ByVal LCP As Long, _
    ByVal LQ As Long, _
    ByVal LPAF As Long, _
    ByVal LFN As String) As Long

Private Declare Function apiCreateIC Lib "gdi32" Alias "CreateICA" _
    (ByVal DriverName As String, _
    ByVal DeviceName As String, _
    ByVal Output As String, _
    InitData As Any) As Long

Private Declare Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" _
    (ByVal hdc As Long, _
    ByVal Index As Long) As Long

Private Declare Function apiSelectObject Lib "gdi32" Alias "SelectObject" _
    (ByVal hdc As Long, _
    ByVal obj As Long) As Long

Private Declare Function apiReleaseDC Lib "user32" Alias "ReleaseDC" _
    (ByVal hWnd As Long, _
    ByVal hdc As Long) As Long

Private Declare Function apiMulDiv Lib "kernel32" Alias "MulDiv" _
    (ByVal Number As Long, _
    ByVal Numerator As Long, _
    ByVal Denumerator As Long) As Long
    
Private Declare Function apiDrawText Lib "user32" Alias "DrawTextA" _
    (ByVal hdc As Long, _
    ByVal str As String, _
    ByVal Count As Long, _
    Rect As Rect, _
    ByVal Format As Long) As Long

Private Const PixelsLog = 90
Private Const Twips = 1440

Private Const DT_Top = &H0
Private Const DT_Left = &H0
Private Const DT_WordBreak = &H10
Private Const DT_CalcRect = &H400

Private Type Rect
Top As Long
Left As Long
Right As Long
Bottom As Long
End Type

Public Function CanGrow(ctl As Control) As Integer
Dim Rect As Rect
Dim hWnd As Long
Dim hdc As Long
Dim Ydpi As Long
Dim FontNew As Long
Dim FontOld As Long
Dim FontHeight As Long
Dim Ret As Long
Dim Ic As Long
    If IsNull(ctl.FontSize) Then
    Exit Function
    End If
    If TypeOf ctl Is TextBox Then
    If Len(ctl & vbNullString) = 0 Then
    Exit Function
    End If
    End If
    If TypeOf ctl Is Label Then
    If Len(ctl.Caption & vbNullString) = 0 Then
    Exit Function
    End If
    End If
hWnd = ctl.Parent.hWnd
    If hWnd = 0 Then
    Exit Function
    End If
hdc = apiGetDC(hWnd)
Ret = 0
Ic = apiCreateIC("Display", vbNullString, vbNullString, vbNullString)
    If Ic <> 0 Then
    Ydpi = apiGetDeviceCaps(Ic, PixelsLog)
    apiDeleteDC (Ic)
    Else
    Ydpi = 120
    End If
FontHeight = apiMulDiv(ctl.FontSize, Ydpi, 72)
    With ctl
    FontNew = apiCreateFont(-FontHeight, 0, 0, 0, .FontWeight, .FontItalic, .FontUnderline, 0, 0, 0, 0, 0, 0, .FontName)
    End With
FontOld = apiSelectObject(hdc, FontNew)
    With Rect
    .Top = 0
    .Left = 0
    .Right = ctl.Width / (Twips / Ydpi)
    .Bottom = 0
    If TypeOf ctl Is TextBox Then
    Ret = apiDrawText(hdc, ctl, -1, Rect, DT_WordBreak + DT_CalcRect + DT_Top + DT_Left)
    End If
    If TypeOf ctl Is Label Then
    Ret = apiDrawText(hdc, ctl.Caption, -1, Rect, DT_WordBreak + DT_CalcRect + DT_Top + DT_Left)
    End If
    Ret = apiSelectObject(hdc, FontOld)
    apiDeleteObject (FontNew)
    Ret = apiReleaseDC(hWnd, hdc)
    .Bottom = .Bottom * (Twips / Ydpi)
    ctl.Height = .Bottom + (.Bottom * 0.005) + 31
    End With
CanGrow = ctl.Height
End Function


.
, ,
.
.
------------------------------------------
,

?

https://www.sql.ru/forum/1310128/zapis-4-hochu-uvidet-chudesa


: [1] []
 

:
: 

: ( )

:

  URL