Di chuyển UserForm đến 1 vị trí của Cell

[anhtuan1066]

Trên diển đàn đã từng có bài viết về việc di chuyển UserForm đến vị trí của ActiveCell... Hãy xem bài viết này:

Dùng VBA để xác định vị trí của Form
Di chuyển Form đến Activecell

Có điều nếu xem xong code, chắc các bạn sẽ.. té xỉu vì code dài đến mức không thể hiểu nỗi... Đến lúc muốn tùy biến hoặc chỉnh sửa code cũng chẳng biết đường đâu mà lần
Xin gữi các bạn 1 code đáp ứng được nhu cầu này nhưng với giải thuật hoàn toàn khác, lại vô cùng ngắn gọn
Code gồm 2 phần
1> Hàm API hổ trợ

Declare Function FindWindowEx Lib "user32" _
    Alias "FindWindowExA" (ByVal hWnd1 As Long, _
    ByVal hWnd2 As Long, ByVal lpsz1 As String, _
    ByVal lpsz2 As String) As Long
Declare Function GetWindowRect Lib "user32" _
    (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function GetDC Lib "user32" _
    (ByVal hwnd As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" _
    (ByVal hDC As Long, ByVal nIndex As Long) As Long
Declare Function ReleaseDC Lib "user32" _
    (ByVal hwnd As Long, ByVal hDC As Long) As Long

Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

2> Code chính

Sub MoveFormToCell(ByRef frmForm As Object, ByVal rngCell As Range)
  Dim hWndDesk As Long, hWndChart As Long, uChartPos As RECT, PointsPerPixel As Double
  With rngCell.Parent.ChartObjects.Add(rngCell.Left, rngCell.Top, 1, 1)
    .Activate
    .Delete
  End With
  hWndDesk = FindWindowEx(Application.hwnd, 0, "XLDESK", "")
  hWndChart = FindWindowEx(hWndDesk, 0, "EXCELE", "")
  GetWindowRect hWndChart, uChartPos
  PointsPerPixel = 72 / GetDeviceCaps(GetDC(0), 88)
  ReleaseDC 0, GetDC(0)
  frmForm.Left = uChartPos.Left * PointsPerPixel
  frmForm.Top = uChartPos.Top * PointsPerPixel
End Sub

-------------------------------------------------
Áp dụng:
Giả sử ta muốn dùng sự kiện SelectionChange để di chuyển UserForm1 đến góc bên phải của ActiveCell, ta sẽ viết như sau:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  With UserForm1
    .Hide
    .StartUpPosition = 0
     MoveFormToCell UserForm1, Target.Offset(0, 1)
    .Show
  End With
End Sub

Vô cùng đơn giản, đúng không?
Nếu thích, có thể save thành 1 Add-In để dùng lâu dài (xóa toàn bộ code, chỉ chừa lại code trong Module trước khi save Add-In)

 

[Nguyễn Duy Tuân]

Sub MoveFormToCell(ByRef frmForm As Object, ByVal rngCell As Range)
  Dim hWndDesk As Long, hWndChart As Long, uChartPos As RECT, PointsPerPixel As Double
  With rngCell.Parent.ChartObjects.Add(rngCell.Left, rngCell.Top, 1, 1)
    .Activate
    .Delete
  End With
  hWndDesk = FindWindowEx(Application.hwnd, 0, "XLDESK", "")
  hWndChart = FindWindowEx(hWndDesk, 0, "EXCELE", "")
  GetWindowRect hWndChart, uChartPos
  PointsPerPixel = 72 / GetDeviceCaps(GetDC(0), 88)
  ReleaseDC 0, GetDC(0)
  frmForm.Left = uChartPos.Left * PointsPerPixel
  frmForm.Top = uChartPos.Top * PointsPerPixel
End Sub

Code trên của anh chưa đúng ở 2 vấn đề:
1) PointsPerPixel anh mới chỉ tính đúng cho X còn Y thì chưa tính.
2) Không chạy được trên Excel 2007.

Đoạn code em sửa lại để sửa cho vấn đề 1).

Private Const POINTS_PER_INCH As Long = 72
Private Const LOGPIXELSX = 88        '  Logical pixels/inch in X
Private Const LOGPIXELSY = 90        '  Logical pixels/inch in Y

Sub MoveFormToCell(ByRef frmForm As Object, ByVal rngCell As Range)
  Dim hWndDesk As Long, hWndChart As Long, uChartPos As RECT
  Dim PointsPerPixelX As Double, PointsPerPixelY As Double
  Dim hDc As Long

  With rngCell.Parent.ChartObjects.Add(rngCell.Left, rngCell.Top, 1, 1)
    .Activate
    .Delete
  End With

  hWndDesk = FindWindowEx(Application.hwnd, 0, "XLDESK", "")
  hWndChart = FindWindowEx(hWndDesk, 0, "EXCELE", "")
  
  GetWindowRect hWndChart, uChartPos
  hDc = GetDC(0)
  [COLOR="Red"]PointsPerPixelX[/COLOR] = POINTS_PER_INCH / GetDeviceCaps(hDc, LOGPIXELSX)
  [COLOR="Red"]PointsPerPixelY[/COLOR] = POINTS_PER_INCH / GetDeviceCaps(hDc, LOGPIXELSY)
  ReleaseDC 0, hDc
  frmForm.Left = uChartPos.Left * PointsPerPixelX
  frmForm.Top = uChartPos.Top * PointsPerPixelY

End Sub

Vấn đê lỗi ở 2) thì hiện nay chưa có giải pháp. Mong mọi người tiếp tục hoàn thiện.

 

[anhtuan1066]

Vấn đê lỗi ở 2) thì hiện nay chưa có giải pháp. Mong mọi người tiếp tục hoàn thiện.

Mình vừa thử xong, đúng là code không chạy được trên Excel 2007
Lúc đầu mình nghĩ chắc có sự khác biệt về Class Name giữa 2 Version này... Nhưng sau khi tìm hiểu thì thấy rằng:
- Application có Class Name lả XLMAIN
- Sheet Grid có Class Name là XLDESK
- Embedded Chart có Class Name là EXCELE
Đâu có gì khác biệt với Excel 2003 nhỉ?
Vậy điều gì làm cho nó không chạy được trên Excel 2007? Khó hiểu thật
Nhờ bạn TuanVNUNI nghiên cứu giúp
(Tôi rất "kết" thuật toán này và cho rằng đây là 1 thuật toán rất thông minh)
-----------------------------------------
Ah... Xin hỏi thêm: Tại sao phải cần tính Y cho PointsPerPixel? Nếu bỏ qua thì sẽ có sai sót gì?
Tôi chưa tìm ra được sai sót khi không tính Y, mong bạn chỉ giáo thêm

 

[Nguyễn Duy Tuân]

Mình vừa thử xong, đúng là code không chạy được trên Excel 2007
Lúc đầu mình nghĩ chắc có sự khác biệt về Class Name giữa 2 Version này... Nhưng sau khi tìm hiểu thì thấy rằng:
- Application có Class Name lả XLMAIN
- Sheet Grid có Class Name là XLDESK
- Embedded Chart có Class Name là EXCELE
Đâu có gì khác biệt với Excel 2003 nhỉ?
Vậy điều gì làm cho nó không chạy được trên Excel 2007? Khó hiểu thật
Nhờ bạn TuanVNUNI nghiên cứu giúp
(Tôi rất "kết" thuật toán này và cho rằng đây là 1 thuật toán rất thông minh)

Với Excel 2003 trở về trước.
Chart có Class Name là EXCELE
Sau khi chèn đồ thị vào bảng tính, thậm chí xóa đi thì Excel vẫn chưa giải phóng handle của đồ thị, về nguyên tắc phải giải phóng nó (destroy). Đây có lẽ là lỗi về quản lý Window của Excel. Nhờ vậy mà ta tranh thủ lấy được giá trị của điều khiển (handle) Window của đồ thị bằng hàm tìm handle FindWindowEx.

hWndChart = FindWindowEx(hWndDesk, 0, "EXCELE", "")

giá trị hWndChart > 0 là tìm được handle của đồ thị. Các hàm API dùng tới nó đều chạy đúng.

Với Excel 2007 trở về sau.
Chart có Class Name là EXCELE? Cái này em không chắc chắn vì không thể tìm được.
Sau khi chèn đồ thị vào bảng tính thì Excel đã giải phóng hoặc ẩn handle của đồ thị ngay tức khắc. Có lẽ Excel 2007 đã chữa lỗi này của phiên bản cũ. Vì vậy mà ta không thể lấy được điều khiển Window của đồ thị

hWndChart = FindWindowEx(hWndDesk, 0, "EXCELE", "")

giá trị hWndChart = 0 là tìm không được handle của đồ thị.
Khi hWndChart =0 tất cả các hàm API dùng tới nó đều không chạy.

GetWindowRect hWndChart, uChartPos không chạy hoặc bị lỗi.
Giá trị trong biến RECT uChartPos đều bằng 0

frmForm.Left = uChartPos.Left * PointsPerPixelX ->luôn bằng 0
frmForm.Top = uChartPos.Top * PointsPerPixelY ->luôn bằng 0

Nên Userform luôn nằm ở tọa độ [0,0] của màn hình.

Giải pháp:
1) Làm sao biết chắc được class name của đồ thị trong Excel 2007 là gì? Có phải là EXCELE không? Nếu vậy thì phải bắt nó lúc nào?
2) Nếu 1) không làm được thì phải tạo một đối tượng khác để làm sao túm được handle của nó.

Biết là vậy nhưng tìm giải pháp này vô cùng khó khăn. Em cũng rất tiếc nếu như không thể tìm được giải pháp cho vấn đề này, vì nó rất hữu dụng.

Ah... Xin hỏi thêm: Tại sao phải cần tính Y cho PointsPerPixel? Nếu bỏ qua thì sẽ có sai sót gì?
Tôi chưa tìm ra được sai sót khi không tính Y, mong bạn chỉ giáo thêm

Các điểm ảnh trên màn hình được hiểm thị theo tọa độ X - chiều ngang và Y - chiều dọc. Độ phân giải của nó tùy thuộc vào cấu tạo phần cứng của màn hình
Đây là đoạn trích trong tài liệu của Microsoft nói về hàm GetDeviceCaps

The [B]GetDeviceCaps[/B] function retrieves device-specific information for the specified device. 

int [B]GetDeviceCaps[/B](
  HDC hdc,     // handle to DC
  int nIndex   // index of capability
);

hdc 
[in] Handle to the DC. 
nIndex 
[in] Specifies the item to return. This parameter can be one of the following values. 

LOGPIXELSX Number of pixels per logical inch along the screen width. In a system with multiple display monitors, this value is the same for all monitors. 
LOGPIXELSY Number of pixels per logical inch along the screen height. In a system with multiple display monitors, this value is the same for all monitors.

Trong một hoàn cảnh nào đó về cấu tạo màn hình, card màn hình mà Windows quản lý độ phân giải cũng như tỷ lệ pixels/inch là khác nhau, vì thế mà khi xác định tỷ lệ luôn phải tìm tỷ lệ X và Y.

Cái này về lý thuyết em chỉ biết vậy, còn thực tế chưa có điều kiện để chứng mình sự khác nhau nhưng nên làm theo chỉ dẫn của Microsoft. Chúng ta thử tìm trên Google về hàm GetDeviceCaps sẽ thấy người ta luôn tính X và Y.

 

[rollover79]

Xin góp vui bằng 1 phương pháp hơi củ chuối này, nó không phụ thuộc vào Excel 2003 hay 2007. Tuy nhiên về tốc độ nó bị delay 1 khoảng thời gian. Có thể tăng step để xử lý tăng tốc độ nếu cần thiết.

 

[anhtuan1066]

Xin góp vui bằng 1 phương pháp hơi củ chuối này, nó không phụ thuộc vào Excel 2003 hay 2007. Tuy nhiên về tốc độ nó bị delay 1 khoảng thời gian. Có thể tăng step để xử lý tăng tốc độ nếu cần thiết.

Rất tốt bạn à! Chẳng củ chuối tí nào đâu... Dù có Delay tí cũng chẳng phải vấn đề gì
Tuy nhiên tôi thử trên Excel 2010 thì UF hiện không đúng vị trí (Excel 2003 và Excel 2007 không có vấn đề)

 

[rollover79]

Rất tốt bạn à! Chẳng củ chuối tí nào đâu... Dù có Delay tí cũng chẳng phải vấn đề gì
Tuy nhiên tôi thử trên Excel 2010 thì UF hiện không đúng vị trí (Excel 2003 và Excel 2007 không có vấn đề)

Tôi không có Excel 2010 nên không test thử được, bác thử debug xem vấn đề của excel 2010 ở chỗ nào.

 

[Nguyễn Duy Tuân]

Xin góp vui bằng 1 phương pháp hơi củ chuối này, nó không phụ thuộc vào Excel 2003 hay 2007. Tuy nhiên về tốc độ nó bị delay 1 khoảng thời gian. Có thể tăng step để xử lý tăng tốc độ nếu cần thiết.

Từ ý tưởng của bạn, tôi đã cải tiến lại và tốc độ chạy nhanh hơn.

Toàn bộ code trong ThisWorkbook như sau:

Option Explicit
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 Declare Function GetActiveWindow Lib "user32.dll" () As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hWnd As Long, ByRef lpRect As RECT) As Long
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Static PointsPerPixelX As Double, PointsPerPixelY As Double
    Dim x As Long, y As Long
    Dim rng As Range
    Dim rc As RECT
    Dim hWnd&
    [COLOR="SeaGreen"]'Application.ActiveWindow.Zoom <> 100 ==>error[/COLOR]
    If Application.ActiveWindow.Zoom <> 100 Then Application.ActiveWindow.Zoom = 100
    If PointsPerPixelX = 0 Then
        Dim hDc&
        hDc = GetDC(0)
        PointsPerPixelX = 72 / GetDeviceCaps(hDc, 88)
        PointsPerPixelY = 72 / GetDeviceCaps(hDc, 90)
        ReleaseDC 0, hDc
    End If
    hWnd = GetActiveWindow
    GetWindowRect hWnd, rc
    For x = rc.Left To rc.Right Step 20
        For y = rc.Top To rc.Bottom Step 20
            Set rng = Application.ActiveWindow.RangeFromPoint(x, y)
            If Not rng Is Nothing Then Exit For
        Next y
        If Not rng Is Nothing Then Exit For
    Next x
    If rng Is Nothing Then Exit Sub
    If UserForm1.StartUpPosition <> 0 Then
        UserForm1.StartUpPosition = 0
    End If
    UserForm1.Top = y * PointsPerPixelY + (ActiveCell.Top - rng.Top) - _
                    IIf(Val(Application.Version) = 14, 8, 0)
    UserForm1.Left = x * PointsPerPixelX + (ActiveCell.Left - rng.Left) + ActiveCell.Width - _
                    IIf(Val(Application.Version) = 14, 8, 0)
    UserForm1.Show vbModeless
End Sub

Các bạn có thể download file về chạy thử.

 

[anhtuan1066]

Tôi không có Excel 2010 nên không test thử được, bác thử debug xem vấn đề của excel 2010 ở chỗ nào.

Để tôi chụp hình lên cho bạn xem nè:




Ta thấy nó chỉ bị lệch theo phương dọc
Đặc biệt, nếu Minimize thanh Ribbon thì độ lệch này có thay đổi