4 - |
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