كيف يتم ضبط الكل والتمدد ولإنكماش أفقياً في مربعي النص والعنوان ؟

في خاصية العرض لمربع النص او مربع التسمية تضع القيمة لخاصية Width و اذا كنت تريد ان تناسب عدد الحروف جرب عمل مربع النص Txt1 وفي حدث الخروج تضع هذا الكود

Private Sub txt1_Exit(Cancel As Integer)
Dim TxtLen As Integer
TxtLen = Val(Len(Me.txt1)) * 115
Me.txt1.Width = TxtLen
End Sub

الاخ علي

اشكرك على الرد لقد اتبعت الطريقة التي شرحتها صحيح مربع النص يتسع إلا أنه تبقى مساحة فارغة في مربع النص0

ما أريده هو ملائمة مربع النص أو مربع التسميه لمحتواه بمعنى زاد النص يتسع حجم مربع النص ينقص النص ينقص حجم مربع النص0

""""" ملائمة مربع النص أو مربع التسميه لمحتواه """"

فهل يمكن ذلك

ألف شكر

اخي العزيز

غير في الرقم 115 الموجود في السطر

TxtLen = Val(Len(Me.txt1)) * 115

حتى تصل الي الحجم المطلوب وقد وضعت هذا المثال للتجربة ولأنه يتحكم في النتيجة حجم الخط ايضا

غير في الرقم 115 قلل منه او زد حتى يتناسب التغيير مع المحتويات

لا اعرف اذا كان يتوفر في الاكسيس وظيفة تؤدي هذا الغرض بطريقة اخرى

بالتوفيق

الأخ 5060

هذا كود يقوم بما طلبت حيث يتغير عرضه بناء على طول النص :

في حدث عند الحالي للنموذج ضع الكود التالي :

Dim intRet As Integer
Dim intHeight As Integer

intHeight = Me.txtExtraInfo.Height
intRet = CInt(fAutoSizeTextBoxS(Me.txtExtraInfo))
If intRet > 0 Then
    If intRet < Me.Width Then
        Me.txtExtraInfo.Width = intRet + (intRet * 0.01)
    Else: Me.txtExtraInfo.Width = Me.Width
    End If
End If
Me.txtExtraInfo.Height = intHeight

مع ملاحظة أن اسم مربع النص في الكود هو txtExtraInfo .

وفي الوحدة النمطية العامة ضع :

Option Compare Database
Option Explicit

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

' Declare API functions
Private Declare Function apiCreateFont Lib "gdi32" Alias "CreateFontA" _
(ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, _
ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, _
ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, _
ByVal PAF As Long, ByVal F As String) As Long

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

Private Declare Function apiDeleteObject Lib "gdi32" _
  Alias "DeleteObject" (ByVal hObject As Long) As Long

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

Private Declare Function apiMulDiv Lib "kernel32" Alias "MulDiv" (ByVal nNumber As Long, _
ByVal nNumerator As Long, ByVal nDenominator As Long) As Long

Private Declare Function apiCreateIC Lib "gdi32" Alias "CreateICA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As String, lpInitData As Any) As Long

Private Declare Function apiGetDC Lib "user32" _
  Alias "GetDC" (ByVal hwnd 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 apiDeleteDC Lib "gdi32" _
  Alias "DeleteDC" (ByVal hdc As Long) As Long

Private Declare Function apiDrawText Lib "user32" Alias "DrawTextA" _
(ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, _
lpRect As RECT, ByVal wFormat As Long) As Long

' CONSTANTS
Private Const TWIPSPERINCH = 1440
' Used to ask System for the Logical pixels/inch in Y axis
Private Const LOGPIXELSY = 90

' DrawText() Format Flags

Private Const DT_TOP = &H0
Private Const DT_LEFT = &H0
'Const DT_CENTER = &H1
'Const DT_RIGHT = &H2
'Const DT_VCENTER = &H4
'Const DT_BOTTOM = &H8
'Const DT_WORDBREAK = &H10
Private Const DT_SINGLELINE = &H20
'Const DT_EXPANDTABS = &H40
'Const DT_TABSTOP = &H80
'Const DT_NOCLIP = &H100
'Const DT_EXTERNALLEADING = &H200
Private Const DT_CALCRECT = &H400
'Const DT_NOPREFIX = &H800
'Const DT_INTERNAL = &H1000

Public Function fAutoSizeTextBoxS(ctl As Control) As Long

    ' Did we get a valid control passed to us?
    If IsNull(ctl.FontSize) Then Exit Function

    ' Did we get a valid control passed to us?
    If Len(ctl & "") = 0 Then Exit Function

    ' Structure for DrawText calc
    Dim sRect As RECT

    ' Handle to Report's window
    Dim hwnd As Long

    ' Reports Device Context
    Dim hdc As Long

    ' Holds the current screen resolution
    Dim lngYdpi As Long

    Dim newfont As Long
    ' Handle to our Font Object we created.
    ' We must destroy it before exiting main function

    Dim oldfont As Long
    ' Device COntext's Font we must Select back into the DC
    ' before we exit this function.

    ' Temporary holder for returns from API calls
    Dim lngRet As Long

    ' Calculate screen Font height
    Dim fheight As Long

    ' Get Controls Parents Window handle
    hwnd = ctl.Parent.hwnd
    If IsNull(hwnd) Then Exit Function

    ' retrieve a handle to a display device context (DC)
    ' for the client area of the specified window
    hdc = apiGetDC(hwnd)

    ' Because Access control's do not have a permanent Device Context,
    ' we cannot depend on what we find selected into the DC unless
    ' the Control has the focus. In this case we are simply using the
    ' Control's Font attributes to build our own font in whatever
    ' DC is handy. We must Save this DC's Font so we can restore
    ' the Font when we exit this function.

    ' Clear our return value
    lngRet = 0


    ' Temporary Information Context for Screen info.
    Dim lngIC As Long

    ' Modified to allow for different screen resolutions
    ' and printer output. Needed to Calculate Font size
    lngIC = apiCreateIC("DISPLAY", vbNullString, vbNullString, vbNullString)
    If lngIC <> 0 Then
        lngYdpi = apiGetDeviceCaps(lngIC, LOGPIXELSY)
        apiDeleteDC (lngIC)
    Else
        lngYdpi = 120 'Default average value
    End If

    ' Calculate/Convert requested Font Height
    ' into Font's Device Coordinate space
    fheight = apiMulDiv(ctl.FontSize, lngYdpi, 72)

    ' We use a negative value to signify
    ' to the CreateFont function that we want a Glyph
    ' outline of this size not a bounding box.

    With ctl
    newfont = apiCreateFont(-fheight, 0, _
       900, 0, .FontBold, _
      .FontItalic, .FontWeight, _
      0, 0, 0, _
       0, 0, 0, .FontName)
    End With

    ' Select the new font into our DC.
    oldfont = apiSelectObject(hdc, newfont)

    ' Use DrawText to Calculate height of Rectangle required to hold
    ' the current contents of the Control passed to this function

    With sRect
    .Left = 0
    .Top = 0
    .Bottom = ctl.Height / (TWIPSPERINCH / lngYdpi)
    .Right = ctl.Width / (TWIPSPERINCH / lngYdpi)
    lngRet = apiDrawText(hdc, ctl.Value, -1, sRect, DT_CALCRECT + DT_SINGLELINE)

    ' Cleanup
    lngRet = apiSelectObject(hdc, oldfont)
    ' Delete the Font we created
    apiDeleteObject (newfont)

    lngRet = apiReleaseDC(hwnd, hdc)
    fAutoSizeTextBoxS = (.Right - .Left) * (TWIPSPERINCH / lngYdpi)
    End With
End Function

ولإنشاء مربع نص يتمدد طولا وعرضا :

في الوحدة النمطية الخاصة بالنموذج ضع :

Private Type sRectInteger
        Left As Integer
        Top As Integer
        Right As Integer
        Bottom As Integer
End Type

وفي حدث عند الحالي للنموذج ضع :

Dim sRect As RECT
Dim sRectInt As sRectInteger

sRect = fAutoSizeTextBoxM(Me.txtExtraInfo)

' SRect's members are all LONG values.
' Let's copy to a dup structure but with
' all members as Integers
With sRectInt
.Bottom = CInt(sRect.Bottom)
.Right = CInt(sRect.Right)


If .Bottom > 0 Then
    If .Bottom < Me.Detail.Height Then
        Me.txtExtraInfo.Height = .Bottom + (.Bottom * 0.02)
    Else: Me.txtExtraInfo.Height = Me.Detail.Height
    End If
End If
If .Right > 0 Then
    If .Right < Me.Width Then
        Me.txtExtraInfo.Width = .Right + IIf((.Right * 0.02) < 50, 50, .Right * 0.02)
    Else: Me.txtExtraInfo.Width = Me.Width
    End If
End If
End With

مع ملاحظة أن اسم مربع النص هو txtExtraInfo .

وفي الوحدة النمطية العامة ضع :

Option Compare Database
Option Explicit

Public Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type


' Declare API functions
Private Declare Function apiCreateFont Lib "gdi32" Alias "CreateFontA" _
(ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, _
ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, _
ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, _
ByVal PAF As Long, ByVal F As String) As Long

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

Private Declare Function apiDeleteObject Lib "gdi32" _
  Alias "DeleteObject" (ByVal hObject As Long) As Long

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

Private Declare Function apiMulDiv Lib "kernel32" Alias "MulDiv" (ByVal nNumber As Long, _
ByVal nNumerator As Long, ByVal nDenominator As Long) As Long

Private Declare Function apiCreateIC Lib "gdi32" Alias "CreateICA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As String, lpInitData As Any) As Long

Private Declare Function apiGetDC Lib "user32" _
  Alias "GetDC" (ByVal hwnd 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 apiDeleteDC Lib "gdi32" _
  Alias "DeleteDC" (ByVal hdc As Long) As Long

Private Declare Function apiDrawText Lib "user32" Alias "DrawTextA" _
(ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, _
lpRect As RECT, ByVal wFormat As Long) As Long


' CONSTANTS
Private Const TWIPSPERINCH = 1440
' Used to ask System for the Logical pixels/inch in Y axis
Private Const LOGPIXELSY = 90

' DrawText() Format Flags

Private Const DT_TOP = &H0
Private Const DT_LEFT = &H0
'Const DT_CENTER = &H1
'Const DT_RIGHT = &H2
'Const DT_VCENTER = &H4
'Const DT_BOTTOM = &H8
'Const DT_WORDBREAK = &H10
Private Const DT_SINGLELINE = &H20
'Const DT_EXPANDTABS = &H40
'Const DT_TABSTOP = &H80
'Const DT_NOCLIP = &H100
'Const DT_EXTERNALLEADING = &H200
Private Const DT_CALCRECT = &H400
'Const DT_NOPREFIX = &H800
'Const DT_INTERNAL = &H1000






    Public Function fAutoSizeTextBoxM(ctl As Control) As RECT

    ' Did we get a valid control passed to us?
    If IsNull(ctl.fontsize) Then Exit Function

    ' Did we get a valid control passed to us?
    If Len(ctl & "") = 0 Then Exit Function

    ' Structure for DrawText calc
    Dim sRect As RECT

    ' Handle to Report's window
    Dim hwnd As Long

    ' Reports Device Context
    Dim hdc As Long

    ' Holds the current screen resolution
    Dim lngYdpi As Long

    Dim newfont As Long
    ' Handle to our Font Object we created.
    ' We must destroy it before exiting main function

    Dim oldfont As Long
    ' Device COntext's Font we must Select back into the DC
    ' before we exit this function.

    ' Temporary holder for returns from API calls
    Dim lngRet As Long

    ' Calculate screen Font height
    Dim fheight As Long

    ' Get Controls Parents Window handle
    hwnd = ctl.Parent.hwnd
    If IsNull(hwnd) Then Exit Function

    ' retrieve a handle to a display device context (DC)
    ' for the client area of the specified window
    hdc = apiGetDC(hwnd)

    ' Because Access control's do not have a permanent Device Context,
    ' we cannot depend on what we find selected into the DC unless
    ' the Control has the focus. In this case we are simply using the
    ' Control's Font attributes to build our own font in whatever
    ' DC is handy. We must Save this DC's Font so we can restore
    ' the Font when we exit this function.

    ' Clear our return value
    lngRet = 0


    ' Temporary Information Context for Screen info.
    Dim lngIC As Long

    ' Modified to allow for different screen resolutions
    ' and printer output. Needed to Calculate Font size
    lngIC = apiCreateIC("DISPLAY", vbNullString, vbNullString, vbNullString)
    If lngIC <> 0 Then
        lngYdpi = apiGetDeviceCaps(lngIC, LOGPIXELSY)
        apiDeleteDC (lngIC)
    Else
        lngYdpi = 120 'Default average value
    End If

    ' Calculate/Convert requested Font Height
    ' into Font's Device Coordinate space
    fheight = apiMulDiv(ctl.fontsize, lngYdpi, 72)

    ' We use a negative value to signify
    ' to the CreateFont function that we want a Glyph
    ' outline of this size not a bounding box.

    With ctl
    newfont = apiCreateFont(-fheight, 0, _
       900, 0, .FontBold, _
      .FontItalic, .FontWeight, _
      0, 0, 0, _
       0, 0, 0, .FontName)
    End With

    ' Select the new font into our DC.
    oldfont = apiSelectObject(hdc, newfont)

    ' Use DrawText to Calculate height of Rectangle required to hold
    ' the current contents of the Control passed to this function

    With sRect
    .Left = 0
    .Top = 0
    .Bottom = 0 'ctl.Height / (TWIPSPERINCH / lngYdpi)
    .Right = ctl.Width / (TWIPSPERINCH / lngYdpi)
    lngRet = apiDrawText(hdc, ctl.Value, -1, sRect, DT_CALCRECT + DT_TOP + DT_LEFT)

    ' Cleanup
    lngRet = apiSelectObject(hdc, oldfont)
    ' Delete the Font we created
    apiDeleteObject (newfont)

    lngRet = apiReleaseDC(hwnd, hdc)

    ' Convert RECT values to TWIPS
    .Bottom = .Bottom * (TWIPSPERINCH / lngYdpi)
    .Right = .Right * (TWIPSPERINCH / lngYdpi)
    End With
    fAutoSizeTextBoxM = sRect

End Function

علماً أنني حصلت على الكود من أحد المواقع لكن لا اتذكره الآن .

وللجميع التحية