اليكم طريقة تغيير محاذاة ليست بوكس الى وسط

[Shivan Kurdi - شڤان کوردی]

السلام عليكم ورحمة الله وبركاته

في السنة الماضية ( 2017 )
كان اريد افتح موضوع و اسأل عن كيفية تغيير محاذاة النص في ليست بوكس الى الوسط العمود
تجولت في دار دار في النيت  لكن وصلت للحل لاوفيس 2003 وهو
تحويل ليست بوكس الى كومبوبوكس وبعدين اغير محاذات الى الوسط و بعدي اغير من جديد الى ليست بوكس
لكن ما نفعت مع اصدار 2010
وفي الاخير وجدت حل لاسئلتي على الرغم غير مضبوطة مع الاسماء بالعربية  كما انا اريد لكن احسن من لا شيء
و رأيت الحل هناhttp://www.tek-tips.com/viewthread.cfm?qid=1111959

وباستخدام هذا الكود في وحدة النطية

Option Compare Database
Option Explicit

'Authors:      Stephen Lebans
'              Terry Kreft
'Date:         Dec 14, 1999
'Copyright:    Lebans Holdings (1999) Ltd.
'              Terry Kreft
'Use:          Center and Right Align data in
'              List or Combo control's
'Bugs:         Please me know if you find any.
'Contact:      Stephen@lebans.com


Private Type Size
        cx As Long
        cy As Long
End Type

Private Const LF_FACESIZE = 32

Private Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As Byte
        lfUnderline As Byte
        lfStrikeOut As Byte
        lfCharSet As Byte
        lfOutPrecision As Byte
        lfClipPrecision As Byte
        lfQuality As Byte
        lfPitchAndFamily As Byte
        lfFaceName As String * LF_FACESIZE
End Type

Private Declare Function apiCreateFontIndirect Lib "gdi32" Alias _
        "CreateFontIndirectA" (lplogfont As LOGFONT) As Long

Private Declare Function apiSelectObject Lib "gdi32" _
 Alias "SelectObject" (ByVal hDC As Long, ByVal hObject As Long) 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 apiDeleteObject Lib "gdi32" _
  Alias "DeleteObject" (ByVal hObject As Long) As Long

Private Declare Function apiGetTextExtentPoint32 Lib "gdi32" _
Alias "GetTextExtentPoint32A" _
(ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, _
lpSize As Size) As Long

 ' Create an Information Context
 Declare Function apiCreateIC Lib "gdi32" Alias "CreateICA" _
  (ByVal lpDriverName As String, ByVal lpDeviceName As String, _
  ByVal lpOutput As String, lpInitData As Any) As Long
  
 ' Close an existing Device Context (or information context)
 Declare Function apiDeleteDC Lib "gdi32" Alias "DeleteDC" _
  (ByVal hDC As Long) As Long

 Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
 
 Private Declare Function GetDeviceCaps Lib "gdi32" _
 (ByVal hDC As Long, ByVal nIndex As Long) As Long
 
 ' Constants
 Private Const SM_CXVSCROLL = 2
 Private Const LOGPIXELSX = 88
 
 
 
'­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­
' 1) We now call the function with an Optional SubForm parameter. This is
' the name of the SubForm Control. If you used the Wizard to add the
' SubForm to the main Form then the SubForm control has the same name as
' the SubForm. But this is not always the case. For the benefit of those
' lurkers out there<bg> we must remember that the SubForm and the SubForm
' Control are two seperate entities. It's very straightforward, the
' SubForm Control houses the actual SubForm. Sometimes the have the same
' name, very confusing, or you can name the Control anything you want! In
' this case for clarity I changed the name of the SubForm Control to
' SFFrmJustify. Ugh..OK that's not too clear but it's late!
'
' So the adjusted SQL statement is now.
' CODENUM: JustifyString("FrmMain","List5",[code],0,True,"SFfrmJustify")
'­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­­



' ***CODE START
Function JustifyString(myform As String, myctl As String, myfield As Variant, _
 col As Integer, RightOrCenter As Integer, Optional Sform As String = "") As Variant

 ' March 21, 2000
 ' Changes RightOrCenter to Integer from Boolean
 ' -1 = Right. 0 = Center, 1 = Left

 ' Called from UserDefined Function in Query like:
 ' SELECT DISTINCTROW JustifyString("frmJustify","list4",_
 ' [code],0,False) AS CODENUM, HORTACRAFT.NAME FROM HORTACRAFT;

 ' myform = name of form containing control
 ' myctl = name of control
 ' myfield is the actual data field from query we will Justify
 ' col = column of the control the data is to appear in(0 based index)
 ' RightOrCenter True = Right. False = Center

 Dim UserControl As Control
 Dim UserForm As Form
 Dim lngWidth As Long

 Dim intSize As Integer
 Dim strText As String
 Dim lngL As Long
 Dim strColumnWidths As String
 Dim lngColumnWidth As Long
 Dim lngScrollBarWidth As Long
 Dim lngOneSpace As Long
 Dim lngFudge As Long
 Dim arrCols() As String
 Dim lngRet As Long

 ' Add your own Error Handling
 On Error Resume Next

 ' Need fudge factor.
 ' Access allows for a margin in drawing its Controls.
 lngFudge = 60

 ' We need the Control as an Object
 ' Check and see if use passed SubForm or not
If Len(Sform & vbNullString) > 0 Then
    Set UserForm = Forms(myform).Controls(Sform).Form
Else
    Set UserForm = Forms(myform)
End If

 ' Assign ListBox or Combo to our Control var
 Set UserControl = UserForm.Controls.Item(myctl)

 With UserControl
   If col > Split(arrCols(), .ColumnWidths, ";") Then Exit Function
   If col = .ColumnCount - 1 Then
     ' Add in the width of the scrollbar, which we get in pixels.
     ' Convert it to twips for use in Access.
     lngScrollBarWidth = GetSystemMetrics(SM_CXVSCROLL)
     lngScrollBarWidth = lngScrollBarWidth * (1440 / GetTwipsPerPixel())
   End If
   lngColumnWidth = Nz(Val(arrCols(col)), 1)
   lngColumnWidth = lngColumnWidth - (lngScrollBarWidth + lngFudge)
 End With

 ' Single space character will be used
 ' to calculate the number of SPACE characters
 ' we have to add to the Input String to
 ' achieve Right justification.
 strText = " "

 ' Call Function to determine how many
 ' Twips in width our String is
 lngWidth = StringToTwips(UserControl, strText)

 ' Check for error
 If lngWidth > 0 Then
       lngOneSpace = Nz(lngWidth, 0)
    
     ' Clear variables for next call
       lngWidth = 0
    
     ' Convert all variables to type string
     Select Case VarType(myfield)
    
     Case 1 To 6, 7, 14
     ' It's a number(1-6) or 7=date
     strText = Str$(myfield)
    
     Case 8
     ' It's a string..leave alone
     strText = myfield
    
     Case Else
     ' Houston, we have a problem
        Call MsgBox("Field type must be Numeric, Date or String", vbOKOnly)
    
     End Select
    
     'let's trim the string - better safe than sorry
     strText = Trim$(strText)
    
     ' Call Function to determine how many
     ' Twips in width our String is
     lngWidth = StringToTwips(UserControl, strText)
    
     ' Check for error
     If lngWidth > 0 Then
    
        ' Calculate how many SPACE characters to append
        ' to our String.
        ' Are we asking for Right or Center Alignment?
         Select Case RightOrCenter
            Case -1
            ' Right
            strText = String(Int((lngColumnWidth - lngWidth) / lngOneSpace), " ") & strText
           
            Case 0
            ' Center
            strText = String((Int((lngColumnWidth - lngWidth) / lngOneSpace) / 2), " ") & strText _
               & String((Int((lngColumnWidth - lngWidth) / lngOneSpace) / 2), " ")
           
             Case 1
            ' Left
            strText = strText
           
             Case Else
        End Select
           ' Return Original String with embedded Space characters
          JustifyString = strText
    End If
 End If
 
 ' Cleanup
 Set UserControl = Nothing
 Set UserForm = Nothing
 
 End Function



 Function Split(ArrayReturn() As String, ByVal StringToSplit As String, _
 SplitAt As String) As Integer
   Dim intInstr As Integer
   Dim intCount As Integer
   Dim strTemp As String

   intCount = -1
   intInstr = InStr(StringToSplit, SplitAt)
   Do While intInstr > 0
     intCount = intCount + 1
     ReDim Preserve ArrayReturn(0 To intCount)
     ArrayReturn(intCount) = Left(StringToSplit, intInstr - 1)
     StringToSplit = Mid(StringToSplit, intInstr + 1)
     intInstr = InStr(StringToSplit, SplitAt)
   Loop
   If Len(StringToSplit) > 0 Then
     intCount = intCount + 1
     ReDim Preserve ArrayReturn(0 To intCount)
     ArrayReturn(intCount) = StringToSplit
   End If
   Split = intCount
 End Function
 '*************  Code End   *************


Private Function StringToTwips(ctl As Control, strText As String) As Long
    Dim myfont As LOGFONT
    Dim stfSize As Size
    Dim lngLength As Long
    Dim lngRet As Long
    Dim hDC As Long
    Dim lngscreenXdpi As Long
    Dim fontsize As Long
    Dim hfont As Long, prevhfont As Long
    
    ' Get Desktop's Device Context
    hDC = apiGetDC(0&)
    
    'Get Current Screen Twips per Pixel
    lngscreenXdpi = GetTwipsPerPixel()
    
    ' Build our LogFont structure.
    ' This  is required to create a font matching
    ' the font selected into the Control we are passed
    ' to the main function.
    'Copy font stuff from Text Control's property sheet
    With myfont
        .lfFaceName = ctl.FontName & Chr$(0)  'Terminate with Null
        fontsize = ctl.fontsize
        .lfWeight = ctl.FontWeight
        .lfItalic = ctl.FontItalic
        .lfUnderline = ctl.FontUnderline
    
        ' Must be a negative figure for height or system will return
        ' closest match on character cell not glyph
        .lfHeight = (fontsize / 72) * -lngscreenXdpi
    End With
                                     
    ' Create our Font
    hfont = apiCreateFontIndirect(myfont)
    ' Select our Font into the Device Context
    prevhfont = apiSelectObject(hDC, hfont)
                
    ' Let's get length and height of output string
    lngLength = Len(strText)
    lngRet = apiGetTextExtentPoint32(hDC, strText, lngLength, stfSize)
    
    ' Select original Font back into DC
    hfont = apiSelectObject(hDC, prevhfont)
    
    ' Delete Font we created
    lngRet = apiDeleteObject(hfont)
        
    ' Release the DC
    lngRet = apiReleaseDC(0&, hDC)
        
    ' Return the length of the String in Twips
    StringToTwips = stfSize.cx * (1440 / GetTwipsPerPixel())
        
End Function


Private Function GetTwipsPerPixel() As Integer

    ' Determine how many Twips make up 1 Pixel
    ' based on current screen resolution
    
    Dim lngIC As Long
    lngIC = apiCreateIC("DISPLAY", vbNullString, _
     vbNullString, vbNullString)
    
    ' If the call to CreateIC didn't fail, then get the info.
    If lngIC <> 0 Then
        GetTwipsPerPixel = GetDeviceCaps(lngIC, LOGPIXELSX)
        ' Release the information context.
        apiDeleteDC lngIC
    Else
        ' Something has gone wrong. Assume a standard value.
        GetTwipsPerPixel = 120
    End If
 End Function

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

تسلسل: JustifyString("frmmaalomat";"List0";[id];0;False)

اسم الفاكشن ( اسم النموذج بعدين اسم ليست بوكس اللي في النموذج وبعدين اسم الحقل المطلوب و بعدين رقم صفر وبعدين فالس للوسط او ترو لليمين 

اليكم صورة لقبل استخدام و بعد استخدام الفانكشن

على الرغم ان هناك نقص في ترتيب هوامش للاسماء بالعربية لكن نقدر ان نغير في هذه الخاصية كما مبية في الصورة

وبعدين سيظهر لنا ليست بوكس هكذا

اليكم المرفق

تحياتي

شفان ريكاني
 

AlignListbox.rar

تم تعديل ديسمبر 31, 2017 بواسطه Shivan Rekany

[صالح حمادي]

برافوا ليك أخي شفان عمل ممتاز.

بس أنا 1988 ههههههه

[Shivan Kurdi - شڤان کوردی]

11 دقائق مضت, صالح حمادي said:

برافوا ليك أخي شفان عمل ممتاز.

شكرا اخي و استاذي الحبيب

11 دقائق مضت, صالح حمادي said:

بس أنا 1988 ههههههه

المواليد كان عشوائية ... هناك احتمال الخطأ في المواليد كلكم عدا مواليدي  

[kaser906]

يعطيك العافية أستاذ شفان

[jjafferr]

17 ساعات مضت, Shivan Rekany said:

شكرا اخي و استاذي الحبيب

المواليد كان عشوائية ... هناك احتمال الخطأ في المواليد كلكم عدا مواليدي  

 

لا لا لا ، لا تقول هذا ،

ولو اني صرت الاكبر سنا ، ولكني راضي بالتاريخ

وشكرا على الموضوع

 

جعفر

[ابوخليل]

47 دقائق مضت, jjafferr said:

 

لا لا لا ، لا تقول هذا ،

ولو اني صرت الاكبر سنا ، ولكني راضي بالتاريخ

وشكرا على الموضوع

جعفر

شوفت انت اكبر مني بـــ 4 سنوات  من العود الحين 

[jjafferr]

هذا الملف ، بصيغة ثانية ،

وللعلم ، هذا الملف من المشاركة الاولى

 

جعفر

 

AlignListbox.MDB.zip

[Amr Ashraf]

جزاك الله خبر استاذ شيفان