Skip to main content

AccessTr.neT


Liste Kutusunu Sayı Alanlarının Biçimlendirilmesi

Liste Kutusunu Sayı Alanlarının Biçimlendirilmesi

Çözüldü #1
Sayın Hocalarım,

Liste kutusu oluşturduğumuzda ,
1-Sayıları sağa yaslama,
2-Para birimlerini biçimlendirme,
olayını nasıl oluşturabiliriz,her hangi bir yöntemi varmı.
Saygılarımla.
Cevapla
#2
Merhaba, liste kutusundaki veride sağa veya sola yaslama özelliği modül ile yapılabiliyor.  

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:      [email protected]


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


Üstteki kodu modüle kaydedip liste kutusunun satır kaynağındaki sorguda, sağa yaslanacak alana 
JustifyString("formadi";"listekutusuadi";[alanadi];0;Doğru)

Şeklinde kod eklerseniz liste kutusundaki bu alan sağa yaslanır. 

Para birimi için liste kutusunun satır kaynağındaki sorguya format işlevi eklenebilir. 
format("[paraalani]";"currency")
Cevapla
#3
Sayın Ozan Hocam,
Verdiğiniz kodu module kaydettim

Liste kutusunun Satır kaynağındaki sorgu
SELECT tbl_Urun_Giris.URUNID, tbl_Urun_Giris.ISLEMNO, tbl_Urun_Giris.KATEGORI, tbl_Urun_Giris.URUNADI, tbl_Urun_Giris.URUNCINSI, tbl_Urun_Giris.URUNMIKTARI, tbl_Urun_Giris.URUNBIRIMI, tbl_Urun_Giris.GIRISFIYATI, tbl_Urun_Giris.SATISFIYATI, tbl_Urun_Giris.SONKULLANMATARIHI
FROM tbl_Urun_Giris;

ise bu,
örnek verdiğiniz sağa yaslama kodu ile para birimi formatını Sql kodunun neresine eklemeliyim.
Birçok denememe rağmen sonuç olumsuz.

Saygılarımla.
Cevapla
#4
Sayın Ozan hocam,

Herhangi bir kod kullanmadan,Parabirimini uyguladım,
Şöyleki,tablo tasarımda parabirimi alanlarının giriş maskesine "#.##0,00 ₺;-#.##0,00 ₺" formatını uyguladım ve para birimi liste kutusuna  geldi,ama farklı olarak tl simgesi rakamın arkasında değilde önüne geldi.

Saygılarımla,bilginize.
Cevapla
#5
Sorgu koduna ekleme yapamazsın. Kodu kopyala, yeni sorgu oluşturup Sql kaynağına bu kodu yapıştır. Sorguyu tasarım görünümünde açıp sağa yaslanacak alanda üstteki Kod form ve alan isimlerine göre değiştir. Para birimi için de aynı işlemi uygula.
Cevapla
#6
Sayın hocam,
Bir örnekle açaıklama yapabilirmisiniz.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task