Làm cho đường dẩn nằm vừa khít với chiều ngang của Control

[ndu96081631]

Khi ta dùng code để lấy đường dẩn của 1 file hoặc 1 thư mục, có lúc đường dẩn này quá dài khiến ta không nhìn thấy được phần đuôi
Tôi xây dựng 1 hàm với mục đích "nén" đường dẩn sao cho nó nằm vừa khít theo chiều ngang của control
Code như sau:

Private Declare Function PathCompactPath Lib "shlwapi.dll" Alias "PathCompactPathA" _
  (ByVal hDC As Long, ByVal pszPath As String, ByVal dx As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
  (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetDC Lib "user32" _
        (ByVal hWnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" _
        (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
        (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Const LOGPIXELSX = 88
Private Const POINTS_PER_INCH As Long = 72

Private Function CompactPath(ByVal sPath As String, ByVal sWidth As Double) As String
  Dim PointsPerPixel As Double, hWnd As Long, hDC As Long
  hWnd = FindWindow("ThunderDFrame", Me.Caption)
  hDC = GetDC(hWnd)
  PointsPerPixel = POINTS_PER_INCH / GetDeviceCaps(GetDC(0), LOGPIXELSX)
  CompactPath = sPath
  PathCompactPath hDC, sPath, sWidth / PointsPerPixel
  If InStr(sPath, Chr$(0)) Then CompactPath = Left$(sPath, InStr(sPath, Chr$(0)) - 1)
  ReleaseDC 0, hDC
End Function

Private Sub cboFileName_DropButtonClick()
  Dim vFile
  vFile = Application.GetOpenFilename("Excel Files, *.xls;*.xlsx;*.xlsm")
  If TypeName(vFile) = "String" Then
    With cboFileName
      .Text = CompactPath(vFile, .Width)
    End With
  End If
  cboFileName.Enabled = False
  cboFileName.Enabled = True
End Sub

cboFileName là 1 ComboBox
-------------------------
Code chạy cũng tạm được, nhưng vấn đề ở đây là cái đường dẩn kia sau khi được "nén" lại có vẽ chưa chính xác lắm theo chiều ngang của Control
Nhờ các cao thủ xem giúp
Kết quả hiển thị thế này:



Mà lý ra phải như vầy thì sẽ đẹp hơn



-------------------
Không biết có liên quan đến Font size của Control không nhỉ?
(Với VB6, làm mấy vụ này nó dễ ẹc... còn VBA sao mà khó khăn thế nhỉ?)

 

[Nguyễn Duy Tuân]

Vấn đề này trên VB6 hay các ngôn ngữ khác thì ra ngay nhưng VBA thì khác. Lý do là đơn vị đo của Userform không không phải là Pixcel mà hình như là Point.
Hàm API PathCompactPath , đối số của cùng của nó phải là đơn vị Pixcel, vì vậy khi đưa chiều rộng của cboFileName vào thì phải đổi ra đơn vị Pixcel. Nhưng khi đổi ra Pixcel thì kết quả vẫn không đúng.

Vấn đề cần giải quyết có thể là việc chuyển đổi đơn vị đo về Pixcel. Liệu đơn vị đo của Userform có phải là phải là Point hay không?

Vụ này khó ra phết.