Chữ thuyết minh bị che khuất trong các shape

tuhocvba

Administrator
Thành viên BQT
Nếu là báo cáo gửi trong công ty thì điều này là không được phép. Mọi người thường phải chỉnh bằng tay.
Hiện tại diễn đàn đang thực hiện dự án code cho một bạn. Trong file trao đổi giữa hai bên cũng xảy ra tình trạng chữ bị che khuất.
Bạn cần đăng nhập để thấy đính kèm


Đây là thông tin hiển thị đầy đủ:
Bạn cần đăng nhập để thấy đính kèm


Việc chữ bị che khuất rất nguy hiểm, người thao tác có thể đọc thiếu thông tin, dẫn tới làm ra output sai.
Vậy, tôi đặt vấn đề cho các bạn thử giải quyết:
Trên Activesheet có nhièu ô textbox.
Chữ trong ô textbox bị che khuất.
Mong muốn macro tìm tất cả các ô textbox và thực hiện tính toán để căn chỉnh lại ô textbox cho phù hợp hiển thị (main).
 

NhanSu

SMod
Thành viên BQT
@tuhocvba máy mình chỉ có ActiveX textbox còn Form control textbox không thể chèn được nên mình chỉ nói về ActiveX textbox.
Mã:
Option Explicit
Option Base 1
Sub AutoSizeT()
Dim x As OLEObject, arr(), i
For Each x In Sheet1.OLEObjects
    If x.progID = "Forms.TextBox.1" Then
        x.Object.AutoSize = True
        i = i + 1
        ReDim Preserve arr(i)
        Set arr(i) = x
    End If
'''''  di chuyen textbox
Next
End Sub
Sub này sẽ thiết lập thuộc tính AutoSize thành True để textbox tự co dãn cho vừa chữ.
Sau khi co dãn thì sẽ xảy ra trường hợp textbox này bị chồng lên textbox kia. Ta tưởng tượng textbox là các hình chữ nhật trong hệ tọa độ, các cạnh của các hình chữ nhật này song song với 1 trong 2 trục tọa độ. Điều kiện để 2 hình chữ nhật tb1 và tb2 không chồng lên nhau là tb1 nằm phía trên tb2 (tb1.top+tb1.height>=tb2.top) hoặc tb1 nằm bên trái tb2 (tb1.left+tb1.width<=tb2.left) hoặc ngược lại. Khi đó ta duyệt mảng textbox đã lấy được ở trên, nếu arr(k) chồng lên arr(i) với k>i thì ta sẽ di chuyển textbox arr(k) sang vị trí khác.
 

tuhocvba

Administrator
Thành viên BQT
Cảm ơn @NhanSu. Mình xin lỗi nếu chưa trình bày rõ vấn đề. Không phải hai ô Textbox trùng nhau.
Bạn cần đăng nhập để thấy đính kèm


Có hai cách nghĩ, một là nới rộng ô ra. Hai là chỉnh size font cho nhỏ lại.
Mình nghĩ cần ưu tiên đi theo hướng 2 (chỉnh font chữ cho nhỏ lại). Bởi vì khi dùng các đối tượng shape, đôi khi nó được đặt ở vị trí có ý đồ. Nếu thay đổi vị trí có thể làm xê dịch không mong muốn. Nên nếu tính toán chỉnh font chữ thì hay hơn.
 

NhanSu

SMod
Thành viên BQT
@PTHhn máy mình chỉ có ActiveX textbox, loại form control bị mờ không thêm vào sheet được.
 
Sửa lần cuối:

PTHhn

Yêu THVBA như điếu đổ
Tôi thử code của bạn @NhanSu :
Mã:
Sub Autosize()
    Dim ob As Object
    For Each ob In Sheets(1).DrawingObjects
        If InStr(1, ob.Name, "TextBox", vbTextCompare) > 0 Then
            ob.Object.Autosize 'Hoac: ob.Autosize
        End If
    Next
End Sub
thì đều bị lỗi. Textbox hay shape, không có phương thức Autosize.
 
B

bvtvba

Guest
Font size giả sử là z. (Ex: 12, 13, 14,...)
Trước khi Autosize:
Bạn cần đăng nhập để thấy hình ảnh

Giả sử ô textbox có diện tích là a.

Sau khi Autosize:
Bạn cần đăng nhập để thấy hình ảnh

Giả sử ô textbox lúc này có diện tích là b.

Font size cần thay đổi thành : z = z*(a/b)
Mã:
Sub Autosize()
    Dim ob As Object
    Dim sf  As Integer 'SizeFont .TextFrame.Characters.Font.Size
    Dim sf2 As Double
    Dim wLeft   As Double, wTop As Double, wWidth As Double, wHeight As Double
    Dim wWidth2 As Double, wHeight2 As Double
    With ActiveSheet
        For Each ob In Sheets(1).DrawingObjects
            If InStr(1, ob.Name, "TextBox", vbTextCompare) > 0 Then
                With ob
                    'Luu lai thong tin ban dau
                     wLeft = .Left
                     wTop = .Top
                     wWidth = .Width
                     wHeight = .Height
                     sf = ActiveSheet.Shapes(ob.Name).TextFrame.Characters.Font.Size
                     '==================Thay doi============================
                     ActiveSheet.Shapes(ob.Name).TextFrame.Autosize = True
                     '======================================================
                     wWidth2 = .Width
                     wHeight2 = .Height
                     sf2 = (wWidth2 * wHeight2)
                     sf2 = (wWidth * wHeight) / sf2
                     sf = Int(sf * sf2)
                     '=================Thay doi font chu============================
                     ActiveSheet.Shapes(ob.Name).TextFrame.Characters.Font.Size = sf
                     '==============================================================
                     'Tra lai vi tri ban dau cua shape
                     .Left = wLeft
                     .Top = wTop
                     .Width = wWidth
                     .Height = wHeight
                End With
            End If
        Next
    End With
End Sub
Hình như chưa ổn định lắm. Em thử có lúc rất tốt, có lúc chưa tốt.
 

tuhocvba

Administrator
Thành viên BQT
Ồ code chạy tốt đấy chứ. Cảm ơn mọi người. Thêm dòng code tắt Autosize ở dòng 33.
Bạn cần đăng nhập để thấy đính kèm

Mã:
Sub Autosize()
    Dim ob As Object
    Dim sf  As Integer 'SizeFont .TextFrame.Characters.Font.Size
    Dim sf2 As Double
    Dim wLeft   As Double, wTop As Double, wWidth As Double, wHeight As Double
    Dim wWidth2 As Double, wHeight2 As Double
    With ActiveSheet
        For Each ob In Sheets(1).DrawingObjects
            If InStr(1, ob.Name, "TextBox", vbTextCompare) > 0 Then
                With ob
                    'Luu lai thong tin ban dau
                     wLeft = .Left
                     wTop = .Top
                     wWidth = .Width
                     wHeight = .Height
                     sf = ActiveSheet.Shapes(ob.Name).TextFrame.Characters.Font.Size
                     '==================Thay doi============================
                     ActiveSheet.Shapes(ob.Name).TextFrame.Autosize = True
                     '======================================================
                     wWidth2 = .Width
                     wHeight2 = .Height
                     sf2 = (wWidth2 * wHeight2)
                     sf2 = (wWidth * wHeight) / sf2
                     sf = Int(sf * sf2)
                     '=================Thay doi font chu============================
                     ActiveSheet.Shapes(ob.Name).TextFrame.Characters.Font.Size = sf
                     '==============================================================
                     'Tra lai vi tri ban dau cua shape
                     .Left = wLeft
                     .Top = wTop
                     .Width = wWidth
                     .Height = wHeight
                      ActiveSheet.Shapes(ob.Name).TextFrame.Autosize = False
                End With
            End If
        Next
    End With
End Sub
 
Top