Tùy chọn
Căn chỉnh chữ vừa với textbox
- Căn chỉnh chữ vừa với textbox
-
Căn chỉnh chữ vừa với textbox
phanthang > 13-08-17, 02:42 AM
Em muốn chỉnh cho dữ liệu khi xuất ra báo cáo thì dữ liệu sẽ tự thu nhỏ cho vừa texbox nếu văn bản dài hơn textbox giiongs như thuộc tính Shink trong excell ý ah ( không phải là textbox tự dãn theo chữ nhé) vì muốn cố định hàng và cột. mong các bác chỉ giáo -
RE: Căn chỉnh chữ vừa với textbox
lehongduc > 13-08-17, 08:45 AM
(13-08-17, 02:42 AM)phanthang Đã viết: Em muốn chỉnh cho dữ liệu khi xuất ra báo cáo thì dữ liệu sẽ tự thu nhỏ cho vừa texbox nếu văn bản dài hơn textbox giiongs như thuộc tính Shink trong excell ý ah ( không phải là textbox tự dãn theo chữ nhé) vì muốn cố định hàng và cột. mong các bác chỉ giáo
Chào Bạn,
Chắc ý Bạn muốn rằng khi Report được in ra, nếu nội dung dữ liệu của 1 ô vượt quá chiều rộng của ô đó thì cho tự động xuống dòng và được kẻ ô cho đúng với chiều cao nhất của các ô dữ liệu.
Nếu ý của Bạn đúng như vậy, Bạn cần phải viết code VBA cho sự kiện in từng dòng trong vùng Detail của Report (Detail Print Event). MS Access không có sẵn định dạng cho nhu cầu này.
Có thể tóm tắt giải pháp như sau:
1. Phải tắt hết việc in đường kẻ ô của các ô dữ liệu trong vùng Detail (Border Style = Transparent)
Việc kẻ ô này ta sẽ cho thực hiện bằng code VBA tự viết.
2. Khai báo 2 thuộc tính “Can Grow” và “Can Shink” là Yes, nghĩa là cho tự động co dãn nội dung của từng ô dữ liệu (Trên Report của Access thì chỉ co dãn theo chiều cao của textbox thôi, còn chiều rộng thì không)
3. Viết code VBA cho sự kiện in vùng Detail (Detail Print Event), trong code ấy:
- Mỗi khi in 1 dòng, ta sẽ cho duyệt qua chiều cao của từng ô trong vùng Detail để lấy ra chiều cao nhất.
- Sau đó, vẽ khung chữ nhật cho từng ô với các tọa độ và kích thước như sau:
+ Đỉnh trái của khung chữ nhật = chỉ số lề trái (Left) của ô
+ Chiều rộng của khung chữ nhật = chiều rộng của ô
+ Chiều cao của khung chữ nhật = chiều cao nhất mà ta đã xác định được ở trên.
4. Code VBA mẫu:
Mã:Private Sub Detail2_Print(Cancel As Integer, PrintCount As Integer)
Dim ctl As Control, ctlName As String
Dim lngMaxHeight As Long
Dim intCtrl As Long, k As Long
Dim ArrayCtl(50) As String
If GetValue("TatKhuyenmai") = True Then
If Me.Dongia = 0 Then
Cancel = True
Exit Sub
End If
End If
intCtrl = 0
For Each ctl In Me.Controls
ctlName = ctl.Name
If Me.Controls(ctlName).Section = 0 And Me.Controls(ctlName).ControlType = acTextBox Then
If Me.Controls(ctlName).Height > lngMaxHeight Then
lngMaxHeight = Me.Controls(ctlName).Height
End If
intCtrl = intCtrl + 1
ArrayCtl(intCtrl) = ctlName
End If
Next ctl
For k = 1 To intCtrl
ctlName = ArrayCtl(k)
Set ctl = Me.Controls(ctlName)
Me.Line (ctl.Left, ctl.Top)-Step(ctl.Width, lngMaxHeight), , B
Next
Set ctl = Nothing
End Sub
Và đây là kết quả bản in:
![[Hình: ama16bb6h391gbd4g.jpg]](https://www.mediafire.com/convkey/b1ac/ama16bb6h391gbd4g.jpg)
Trong code VBA trên có sử dụng Line method của Report.
![[Hình: 6fhb8pfa22e8kvm4g.jpg]](https://www.mediafire.com/convkey/95cf/6fhb8pfa22e8kvm4g.jpg)
Các Bạn tham khảo tài liệu giải thích và hướng dẫn của Microsoft tại link sau nhé: https://msdn.microsoft.com/VBA/Access-VB...hod-access -
RE: Căn chỉnh chữ vừa với textbox
cpucloi > 13-08-17, 06:18 PM
cái này có đấy, nó co nhỏ chữ lại cho vừa textbox, còn có xuống dòng không thì chưa thử, mình áp dụng để làm thẻ tên nhân viên (hiện đang onl bằng mobile lên ko có demo) -
RE: Căn chỉnh chữ vừa với textbox
phanthang > 14-08-17, 09:43 PM
(13-08-17, 02:42 AM)phanthang Đã viết: Em muốn chỉnh cho dữ liệu khi xuất ra báo cáo thì dữ liệu sẽ tự thu nhỏ cho vừa texbox nếu văn bản dài hơn textbox giiongs như thuộc tính Shink trong excell ý ah ( không phải là textbox tự dãn theo chữ nhé) vì muốn cố định hàng và cột. mong các bác chỉ giáo
Cảm ơn bác. ý em là text co nhỏ lại cho vừa textbox ah -
RE: Căn chỉnh chữ vừa với textbox
phanthang > 14-08-17, 09:45 PM
(13-08-17, 08:45 AM)lehongduc Đã viết:
(13-08-17, 02:42 AM)phanthang Đã viết: Em muốn chỉnh cho dữ liệu khi xuất ra báo cáo thì dữ liệu sẽ tự thu nhỏ cho vừa texbox nếu văn bản dài hơn textbox giiongs như thuộc tính Shink trong excell ý ah ( không phải là textbox tự dãn theo chữ nhé) vì muốn cố định hàng và cột. mong các bác chỉ giáo
Chào Bạn,
Chắc ý Bạn muốn rằng khi Report được in ra, nếu nội dung dữ liệu của 1 ô vượt quá chiều rộng của ô đó thì cho tự động xuống dòng và được kẻ ô cho đúng với chiều cao nhất của các ô dữ liệu.
Nếu ý của Bạn đúng như vậy, Bạn cần phải viết code VBA cho sự kiện in từng dòng trong vùng Detail của Report (Detail Print Event). MS Access không có sẵn định dạng cho nhu cầu này.
Có thể tóm tắt giải pháp như sau:
1. Phải tắt hết việc in đường kẻ ô của các ô dữ liệu trong vùng Detail (Border Style = Transparent)
Việc kẻ ô này ta sẽ cho thực hiện bằng code VBA tự viết.
2. Khai báo 2 thuộc tính “Can Grow” và “Can Shink” là Yes, nghĩa là cho tự động co dãn nội dung của từng ô dữ liệu (Trên Report của Access thì chỉ co dãn theo chiều cao của textbox thôi, còn chiều rộng thì không)
3. Viết code VBA cho sự kiện in vùng Detail (Detail Print Event), trong code ấy:
- Mỗi khi in 1 dòng, ta sẽ cho duyệt qua chiều cao của từng ô trong vùng Detail để lấy ra chiều cao nhất.
- Sau đó, vẽ khung chữ nhật cho từng ô với các tọa độ và kích thước như sau:
+ Đỉnh trái của khung chữ nhật = chỉ số lề trái (Left) của ô
+ Chiều rộng của khung chữ nhật = chiều rộng của ô
+ Chiều cao của khung chữ nhật = chiều cao nhất mà ta đã xác định được ở trên.
4. Code VBA mẫu:
Mã:Private Sub Detail2_Print(Cancel As Integer, PrintCount As Integer)
Dim ctl As Control, ctlName As String
Dim lngMaxHeight As Long
Dim intCtrl As Long, k As Long
Dim ArrayCtl(50) As String
If GetValue("TatKhuyenmai") = True Then
If Me.Dongia = 0 Then
Cancel = True
Exit Sub
End If
End If
intCtrl = 0
For Each ctl In Me.Controls
ctlName = ctl.Name
If Me.Controls(ctlName).Section = 0 And Me.Controls(ctlName).ControlType = acTextBox Then
If Me.Controls(ctlName).Height > lngMaxHeight Then
lngMaxHeight = Me.Controls(ctlName).Height
End If
intCtrl = intCtrl + 1
ArrayCtl(intCtrl) = ctlName
End If
Next ctl
For k = 1 To intCtrl
ctlName = ArrayCtl(k)
Set ctl = Me.Controls(ctlName)
Me.Line (ctl.Left, ctl.Top)-Step(ctl.Width, lngMaxHeight), , B
Next
Set ctl = Nothing
End Sub
Và đây là kết quả bản in:
Trong code VBA trên có sử dụng Line method của Report.
Các Bạn tham khảo tài liệu giải thích và hướng dẫn của Microsoft tại link sau nhé: https://msdn.microsoft.com/VBA/Access-VB...hod-access
Cảm ơn bác. ý em là text co nhỏ lại cho vừa textbox ah -
RE: Căn chỉnh chữ vừa với textbox
phanthang > 14-08-17, 09:46 PM
-
RE: Căn chỉnh chữ vừa với textbox
cpucloi > 15-08-17, 03:55 PM
Cái này mình sưu tầm được trên Internet khá lâu, không rõ của ai, nếu của ai vui lòng cmt để mình bổ sung thông tin
1. Tạo Module
Mã PHP:Option Compare Database
[/font][/size][/color]Option Explicit
Private Type Size
cx As Long
cy As Long
End Type
' Declare API functions.
Private Declare PtrSafe Function CreateFont 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 PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare PtrSafe Function apiDeleteObject Lib "gdi32" _
Alias "DeleteObject" (ByVal hObject As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" _
(ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function MulDiv Lib "kernel32" (ByVal nNumber As Long, _
ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare PtrSafe Function CreateIC Lib "gdi32" Alias "CreateICA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare PtrSafe Function apiGetTextExtentPoint32 Lib "gdi32" _
Alias "GetTextExtentPoint32A" _
(ByVal hdc As Long, ByVal lpsz As String, _
ByVal cbString As Long, lpSize As Size) As Long
Private Declare PtrSafe Function apiGetDC Lib "user32" _
Alias "GetDC" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function apiReleaseDC Lib "user32" _
Alias "ReleaseDC" (ByVal hWnd As Long, _
ByVal hdc As Long) As Long
Private Declare PtrSafe Function apiDeleteDC Lib "gdi32" _
Alias "DeleteDC" (ByVal hdc As Long) As Long
Private Declare PtrSafe Function RestoreDC Lib "gdi32" (ByVal hdc As Long, ByVal nSavedDC As Long) As Long
Private Declare PtrSafe Function SaveDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare PtrSafe Function GetTextAlign Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare PtrSafe Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
'Used to ask System for the Logical pixels/inch in Y axis
Const LOGPIXELSY = 90
'Used to ask System for the Logical pixels/inch in X axis
Const LOGPIXELSX = 88
'Stock Object - System Font
Const SYSTEM_FONT = 13
'**LEAVE THESE AS PUBLIC VARS
'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
Function fMakeFitSingle(ctl As Control, FontHeight As Integer) As Boolean
'Name fMakeFit
'Purpose: Resize Font to make text fit into
' a fixed size Text Control
'Version: 1.0 RAW :-)
'Calls Text API stuff
'Created by: Stephen Lebans
'Date: Oct 23, 1999
'Time: 11:40:18pm
'Feedback: macarthu@nbnet.nb.ca
'My Web Page: http://www.lebans.com
'Copyright: Lebans Holdings Ltd.
' May not be resold in whole or part
' but may be used without restriction
' in any software you develop.
'
'Calculates the Font size required to force the current
'text to fit inside the fixed size Text Control
'WORKS WITH SINGLE LINE DATA ONLY!!!!!!!!!!!!!!!
'See modMakeFitMemo to handle multiple lines.
'Bugs:
'Not tested enough to tell. Let me know
'
'Enjoy
'Stephen Lebans
'***************Code Start***************
Dim hFont As Long
'handle to font we created in MakeFont
'so that we can destroy it before exiting main function
Dim hFontCtl
'font that was selected in DC first time through
'this function
'Temporary holder for returns from API calls
Dim lngret As Long
'Calculate screen Font height
Dim fheight As Long
'Holder for what Font Size works
Dim intFontHeight
hWnd = ctl.Parent.hWnd
'retrieve a handle to a display device context (DC)
'for the client area of the specified window
hdc = apiGetDC(hWnd)
'Let's save the current state of the DC to restore after
'We will be changing the font size
'lngRet = SaveDC(hdc)
'Store this so we can reset the Font that was initially selected into
'the hdc when we entered this function
'Nevermind, we've picked it up upon entering this function instead
hFontCtl = SelectObject(hdc, GetStockObject(SYSTEM_FONT))
lngret = SelectObject(hdc, hFontCtl)
'Do we have to bother calling the
'main function?
If Not IsNull(ctl.Value) Then
If ctl.Value <> "" Then
'Clear our return value
lngret = 0
'**************
' MakeFont uses FontHeight passed in Function call
' Lets make sure our Control's Fontsize is the same
' as the size passed to this function
ctl.FontSize = FontHeight
Do While lngret >= 0
hFont = makefont(hdc, ctl)
lngret = JustifyText(hdc, ctl)
Select Case lngret
Case -2
'Put your error handlers here
hFont = SelectObject(hdc, hFontCtl)
lngret = apiDeleteObject(hFont)
lngret = apiReleaseDC(hWnd, hdc)
fMakeFitSingle = False
Exit Function
Case -1
'Everything OK
'Cleanup!
hFont = SelectObject(hdc, hFontCtl)
lngret = apiDeleteObject(hFont)
lngret = apiReleaseDC(hWnd, hdc)
fMakeFitSingle = True
Exit Function
Case 0
'Everything OK
'Cleanup!
hFont = SelectObject(hdc, hFontCtl)
lngret = apiDeleteObject(hFont)
lngret = apiReleaseDC(hWnd, hdc)
fMakeFitSingle = True
Exit Function
Case Else
'Here is the actual number of characters
'left that didn't fit in the box
'you could use this number to speed up
'the process. I don't here
ctl.FontSize = ctl.FontSize - 1
'Let's get real here. How small
'can you go. This is for error handling
'as well so put something here.
If ctl.FontSize < 3 Then Exit Do
End Select
Loop
'Control's value is null
End If
'Control's value is a zero length string
End If
'Cleanup!
hFont = SelectObject(hdc, hFontCtl)
lngret = apiDeleteObject(hFont)
lngret = apiReleaseDC(hWnd, hdc)
fMakeFitSingle = True
End Function
Private Function JustifyText(hdc As Long, ctl As Control) As Long
'This function is adapted from my Justification function.
'IT IS FOR SINGLE LINE DATA ONLY!!!!!!!!!!!!!!!!!!!!!
'API's need UserControl.Width in Pixels not Twips
Dim UserControlWidthPixels As Integer
Dim UserControlHeightPixels As Integer
'Junk holder for Return values we don't use
Dim lngReturn As Long
'UDT to hold Text Height and Width from API
Dim lpSize As Size
'This is the actual Text string(Caption)
Dim pText As String
'Length of the entire string to be output.
Dim CaptionLength As Integer
'Grab the current string from the control
pText = ctl.Value
CaptionLength = Len(pText)
On Error GoTo MYHandler
'Calculate Current UserControl.Width in Pixels
UserControlWidthPixels = (ctl.Width \ (1440 \ lngYdpi))
'UserControlHeightPixels = (ctl.Height \ (1440 \ lngYdpi))
'We have to leave space for the border
'Adjust as you see fit! :-)
'Must be a minimum of 10 pixels otherwise
'to allow for the border width Access uses to calculate
'what text will actaully fit in a control
UserControlWidthPixels = UserControlWidthPixels - 10
'UserControlHeightPixels = UserControlHeightPixels - 6
' See if current text in control FITS
lngReturn = apiGetTextExtentPoint32(hdc, pText, Len(pText), lpSize)
'Debug.Print "Ctl.FontSize:" & ctl.fontsize & " | " & "lpsize.cx:" & lpSize.cx & " | " _
'& "CtlWidth:" & UserControlWidthPixels & " | " & ctl.Value
If lpSize.cx >= UserControlWidthPixels Then
' Keep reducing Font Size - still doesn't fit.
JustifyText = 1
Else
' OK it fits we'er all done
JustifyText = -1
End If
Exit Function
MYHandler:
'Add your own handlers here.
On Error Resume Next
JustifyText = -2
End
End Function
Private Function makefont(hdc As Long, ctl As Control) As Long
'Returns handle to newfont so we can delete it when we exit amin function
Dim newfont As Long
Dim oldfont As Long
Dim lngret As Boolean
Dim fheight As Integer
'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 = CreateIC("DISPLAY", vbNullString, vbNullString, vbNullString)
If lngIc <> 0 Then
lngYdpi = GetDeviceCaps(lngIc, LOGPIXELSY)
DeleteDC (lngIc)
Else
lngYdpi = 120 'Default average value
End If
'Calculate/Convert requested Font Height
'into Font's Device Coordinate space
fheight = MulDiv(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 = CreateFont(-fheight, 0, _
0, 0, .FontWeight, _
.FontItalic, .FontUnderline, _
0, 0, 0, _
0, 0, 0, .FontName)
End With
' Select the new font.
oldfont = SelectObject(hdc, newfont)
'I was worried about trying to delete the
'font originally selected into the Control
'in Report Design view.
'Doesn't seem to be causing any problems
'...running very fast away! :-)
apiDeleteObject (oldfont)
'Return handle to font to be destroyed when we exit main function
'actually I've decided to pick it up as we enter the main function
makefont = newfont
End Function
[color=#000000][size=small][font=Calibri]
2. Tại thuộc tính Onformat
Với số 14 là cỡ lớn nhất mà bạn muốn, txt_hovaten là textbox muốn căn chữ
Mã PHP:Dim lngret2 As Long 'For Last Name Control
[/font][/size][/color]
lngret2 = fMakeFitSingle(txt_hovaten, 14)
[color=#000000][size=small][font=Calibri]
View report của bạn để xem thành quả.
Lưu ý, cách này dòng chữ không tự động xuống dòng khi vượt qua chiều rộng textbox, cỡ chữ thu nhỏ đến khi dòng chữ bằng chiều rộng textbox.
![[Hình: ama16bb6h391gbd4g.jpg]](http://www.mediafire.com/view/ama16bb6h391gbd/Rpt.png)
![[Hình: 6fhb8pfa22e8kvm4g.jpg]](http://www.mediafire.com/view/6fhb8pfa22e8kvm/LineMethod.png)