Tặng tiện ích CALENDAR tuyệt đẹp!

Liên hệ QC
Hoàng Trọng Nghĩa

Hoàng Trọng Nghĩa

Chuyên gia GPE
Thành viên BQT
Moderator
Tham gia
17/8/08
Bài viết
8,616
Được thích
16,675
Giới tính
Nam
***************************************************************************************************************
***************************************************************************************************************
Đã có phiên bản mới tại đây:

Tặng tiện ích CALENDAR (Excel 2007 trở về sau)​


***************************************************************************************************************
***************************************************************************************************************



Nhân dịp khoác trên vai “4 sao vàng”, tôi xin tặng các bạn một UserForm Calendar tuyệt đẹp, nó không những thay thế được với Control Calendar của Excel mà nó còn hiển thị ngày Âm lịch.

(Giới thiệu trước, gửi file ở bài sau)
3.jpg​

Mặc dù mã nguồn tôi đã sưu tầm từ nhiều nơi (thật sự tôi không nhớ nguồn gốc của các mã này của ai sáng tác), nhưng tôi đã cải tiến cũng như thiết kế lại giao diện, kết hợp mã nguồn của dương lịch và mã nguồn chuyển Âm lịch, có đầy đủ “thiên can địa chi” cho năm.

Cũng như tại bài viết này tôi đã giới thiệu (http://www.giaiphapexcel.com/forum/showthread.php?36542-Đặt-caption-cho-nhiều-Label&p=242247#post242247) thì cải tiến lần này hoàn chỉnh nhất, Calendar này sẽ nhớ ngày hiện hành (hôm nay) bằng cách tô màu hồng đậm. Dùng phím mũi tên (lên, xuống, trái, phải) để di chuyển giữa các ô ngày; mỗi ô ngày được chọn sẽ có nền trắng, viền ngoài để phân biệt với ngày hiện hành và các ngày trong tháng.

Các bạn để ý sẽ thấy, khi ô ngày nào được chọn, thì Label ở dưới cùng thể hiện ngày Dương lịch được chọn bên trái và ngày Âm lịch được chọn bên phải, chúng có màu nền, cũng như màu font chữ của ô ngày hiện hành.

Cũng tại Label này, khi bạn đang chọn ngày khác với ngày hiện hành, thì bạn click vào đó nó sẽ chọn về ngày hôm nay.

2.jpg​

Nếu bạn rê chuột ngang qua nó, nó sẽ show cho bạn một ToolTip để báo bạn biết chức năng của nó.

Đặc biệt, lần cải tiến này tôi đã thay đổi 2 Label tháng và năm thành 2 ComboBox THÁNG & NĂM để chúng ta có thể di chuyển ngay tới tháng hoặc năm cần xem.

1.jpg

– Chọn tháng –

4.jpg

– Chọn năm –

5.jpg
​

Các thao tác trên lịch:

  • Di chuyển giữa các ô ngày bằng các phím mũi tên để di chuyển qua lại, lên xuống.
  • Dùng phím Tab để di chuyển ngày kế tiếp, shift + tab để di chuyển ngược lại.
  • PgUp, PgDn để chọn tháng trước, tháng sau (tương đương với bấm vào 2 CommandButton mũi tên qua, lại sát ComboBox Tháng, cũng tương đương Shift + các phím mũi tên).
  • Shift+ PgUp/ PgDn để chọn năm trước, năm sau (tương đương với bấm vào 2 CommandButton mũi tên qua, lại sát ComboBox Năm).
  • Phím Home để trở về ngày hiện hành (ngày hôm nay).

Các bạn cứ bấm thử với Shift hoặc Ctrl kết hợp với các phím trên sẽ nắm rõ nguyên lý hoạt động của lịch.

Với phím Enter, Esc hoặc click vào ô ngày nào đó sẽ thoát lịch.

Nếu lịch được khởi động trên một UserForm và muốn nhận giá trị ngày từ Calendar vào một TextBox trên form này, thì sau khi thoát Lịch, giá trị lịch tại ô ngày nào được chọn sẽ nhập vào TextBox của UserForm đó.

Năm nào có tháng nhuần thì nó thể hiện chữ (N) trên Calendar.

6.jpg​
Khi gọi Calendar từ một UserForm, nếu TextBox cần nhập Date có sẳn ngày tháng, lịch sẽ lấy ngày đó làm ngày hiển thị, ngược lại, lịch sẽ hiển thị ngày hiện hành.

7.jpg
​
 
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
cách import calender qua file khác

Hoàng Trọng Nghĩa đã viết:
Vấn đề này tôi nghĩ cũng không khó, nhưng vấn đề chủ yếu của Calendar này các bạn chép nó (import) qua file của các bạn để nhập ngày tháng nhanh chóng là chủ yếu.

Còn việc nó trở thành hoặc như một phần mềm lịch có đầy đủ chức năng ghi chú, báo nhắc nhở, thậm chí tử vi thì khá rắc rối và mất quá nhiều thời gian, mặc dù nó rất linh tinh. Nhưng có thể một lúc nào đó tôi rãnh rỗi thì sẽ nghiên cứu và cải tiến thêm cho nó về các vấn đề này.
Nhấp chuột vào đây để mở rộng...


thầy cho e hỏi làm sao để minh import calendar này vào file excel khác để thực hiện các thao tác nhập ngày tháng vào các ô được chọn... em cảm ơn thầy và các bạn đã quan tâm...
 
Upvote 0
minhluan0409 đã viết:
thầy cho e hỏi làm sao để minh import calendar này vào file excel khác để thực hiện các thao tác nhập ngày tháng vào các ô được chọn... em cảm ơn thầy và các bạn đã quan tâm...
Nhấp chuột vào đây để mở rộng...
Bạn tải cái AddIn này về và như thế bạn có thể xài vô tư trên mọi file Excel trên máy của bạn:

http://www.giaiphapexcel.com/forum/...n-ích-CALENDAR-tuyệt-đẹp!&p=463914#post463914
 
Upvote 0
Update phiên bản 3.0 14/09/2015:

AddIn với thủ tục lược giản trên form Calendar khi sử dụng Class Module.

Sau khi cài đặt vào AddIn vào máy, bạn thử mở 1 file trắng ra, tại một ô bất kỳ, click chuột phải, trên CellMenu bạn sẽ thấy cái mặt cười Calendar, click vô đó, Calendar sẽ hiện ra ngay dưới ô đó và sau khi chọn ngày, tại ô đó sẽ nhận giá trị ngày bạn chọn.

Để biết thủ tục nhập trên sheet hay nhập trên userform, bạn mở file ThiNghiem sẽ thấy các câu lệnh trong đó.

Nếu là thủ tục để nhập tại một Range trên sheet (giả sử là ô C1), bạn chỉ việc sử dụng câu lệnh này:

Run "'CalendarShow.xla'!CalendarOpen", Range("A1")

hoặc trên Target chẳng hạn:

Run "'CalendarShow.xla'!CalendarOpen", Target

Còn nếu bạn muốn xài trên UserForm và muốn gán giá trị vào một TextBox chẳng hạn, xài thủ tục sau:

Run "'CalendarShow.xla'!CalendarOpen", TextBox2, Me

Như thế, ta có thể chạy các thủ tục từ trong một file .xla để thực hiện công việc của mình.

==============================================

ĐÃ UPDATE LẠI ADDIN MỚI (BỔ SUNG TRƯỜNG HỢP PAGE BREAK PREVIEW), THAY CÁI CŨ.

==============================================
Đã có file cải tiến mới nhất tại đây:

[h=1]Tặng tiện ích CALENDAR tuyệt đẹp (phần 2 - Phiên bản 5)[/h]
 

File đính kèm

  • ThiNghiem.xls
    32.5 KB · Đọc: 64
  • CalendarShow.xla
    233.5 KB · Đọc: 72
Lần chỉnh sửa cuối:
Upvote 0
Hoàng Trọng Nghĩa đã viết:
Update phiên bản 3.0 14/09/2015:

AddIn với thủ tục lược giản trên form Calendar khi sử dụng Class Module.

Sau khi cài đặt vào AddIn vào máy, bạn thử mở 1 file trắng ra, tại một ô bất kỳ, click chuột phải, trên CellMenu bạn sẽ thấy cái mặt cười Calendar, click vô đó, Calendar sẽ hiện ra ngay dưới ô đó và sau khi chọn ngày, tại ô đó sẽ nhận giá trị ngày bạn chọn.
...
Như thế, ta có thể chạy các thủ tục từ trong một file .xla để thực hiện công việc của mình.
Nhấp chuột vào đây để mở rộng...

Nghĩa làm AddIn rất hữu dụng, nhưng có một vấn đề cần khắc phục là khi sheet đang ở "Page break preview" thì click chuột phải trên cellMenu không thấy được cái mặt cười Calendar.
 
Upvote 0
thanh_tks đã viết:
Nghĩa làm AddIn rất hữu dụng, nhưng có một vấn đề cần khắc phục là khi sheet đang ở "Page break preview" thì click chuột phải trên cellMenu không thấy được cái mặt cười Calendar.
Nhấp chuột vào đây để mở rộng...
Nếu anh thường dùng trong chế độ "Page break preview" này thì nên dùng code này:

Mã: 
Private Sub Workbook_Open()
    With Application.CommandBars(Application.CommandBars("Cell").Index + 3)
[COLOR=#008000]    ''With Application.CommandBars("Cell")[/COLOR]
        On Error GoTo MenuLich
        If Not .Controls("Calendar") Is Nothing Then Exit Sub
MenuLich:
        .Controls("Cut").BeginGroup = True
        .Controls.Add(1, , , 1).Caption = "Calendar"
        With .Controls("Calendar")
            .Style = 3
            .FaceId = 59
            .BeginGroup = True
            .OnAction = "CalShow"
        End With
    End With
End Sub




Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Application.CommandBars(Application.CommandBars("Cell").Index + 3).Controls("Calendar").Delete
[COLOR=#008000]    ''Application.CommandBars("Cell").Controls("Calendar").Delete[/COLOR]
End Sub

Màu xanh là code cũ.
 
Upvote 0
Việc chuyển đổi qua lại thì không biết sự kiện nó như thế nào nữa! Để từ từ nghiên cứu xem có thể dùng sự kiện nào để thay đổi được không.
 
Upvote 0
thanh_tks đã viết:
Nghĩa làm AddIn rất hữu dụng, nhưng có một vấn đề cần khắc phục là khi sheet đang ở "Page break preview" thì click chuột phải trên cellMenu không thấy được cái mặt cười Calendar.
Nhấp chuột vào đây để mở rộng...
OK, biết em này nó ẩn và hiện menu kiểu của nó nên ta lợi dụng điểm này, làm luôn 2 thủ tục chồng nhau, qua sheet dạng nào cũng có menu này hết:

Mã: 
Option ExplicitPublic ContextMenu1 As CommandBar
Public ContextMenu2 As CommandBar


Sub CreateCalendarCellMenu()
    Set ContextMenu1 = Application.CommandBars("Cell")
    With ContextMenu1
        On Error GoTo MenuLich
        If Not .Controls("Calendar") Is Nothing Then Exit Sub
MenuLich:
        .Controls("Cut").BeginGroup = True
        .Controls.Add(1, , , 1).Caption = "Calendar"
        With .Controls("Calendar")
            .Style = 3
            .FaceId = 59
            .BeginGroup = True
            .OnAction = "CalShow"
        End With
    End With
End Sub


Sub CreateCalendarPageBreakMenu()
    Set ContextMenu2 = Application.CommandBars(Application.CommandBars("Cell").Index + 3)
    With ContextMenu2
        On Error GoTo MenuLich
        If Not .Controls("Calendar") Is Nothing Then Exit Sub
MenuLich:
        .Controls("Cut").BeginGroup = True
        .Controls.Add(1, , , 1).Caption = "Calendar"
        With .Controls("Calendar")
            .Style = 3
            .FaceId = 59
            .BeginGroup = True
            .OnAction = "CalShow"
        End With
    End With
End Sub


Sub DeleteCalendarCellMenu()
    On Error Resume Next
    ContextMenu1.Controls("Calendar").Delete
    ContextMenu2.Controls("Calendar").Delete
End Sub

Đã thay AddIn cũ bàng AddIn mới cho bài #63 này!
 
Upvote 0
em cũng không biết mấy hàm GetDC,GetDeviceCaps dùng để làm gì nữa . chắc ngày xưa máy móc chưa chuẩn nên phải dùng chăng ?

ở đây anh thử chạy hàm này trên máy anh xem nó có hiển thị đúng không nha
Mã: 
Function DatePicked(Optional ByVal varPassedDate As Variant, Optional ByVal IsRange As Boolean) As Variant
    On Error Resume Next
    gvarStartDate = IIf(IsMissing(varPassedDate), Date, varPassedDate)
    If Not IsDate(gvarStartDate) Then gvarStartDate = Date
    If IsRange Then
        Dim Arr
        Dim MyRange As Range
        Set MyRange = varPassedDate
       [COLOR=#ff0000][B] 'Arr = CellPosition(MyRange)[/B][/COLOR]
        With UsfCalendar
            .StartUpPosition = 0
            '.Left = Arr(1)
            '.Top = Arr(2)
           [SIZE=2] [COLOR=#ff0000][B].Top = ActiveWindow.PointsToScreenPixelsY(MyRange.Top / 0.75) * 0.75 + MyRange.Height
            .Left = ActiveWindow.PointsToScreenPixelsX(MyRange.Left / 0.75) * 0.75[/B][/COLOR][/SIZE]
            .Show
        End With
    Else
        UsfCalendar.Show
    End If
    DatePicked = gvarSelectedDate
End Function

nếu mà hiển thị đúng thì ta bỏ được 1 số cái thằng quỉ API phải không . bớt được thằng nào đỡ phiền thằng đó . vì addin của anh đem sang máy 64 như em có chạy được đâu
 
Upvote 0
doveandrose đã viết:
em cũng không biết mấy hàm GetDC,GetDeviceCaps dùng để làm gì nữa . chắc ngày xưa máy móc chưa chuẩn nên phải dùng chăng ?

ở đây anh thử chạy hàm này trên máy anh xem nó có hiển thị đúng không nha
Mã: 
Function DatePicked(Optional ByVal varPassedDate As Variant, Optional ByVal IsRange As Boolean) As Variant
    On Error Resume Next
    gvarStartDate = IIf(IsMissing(varPassedDate), Date, varPassedDate)
    If Not IsDate(gvarStartDate) Then gvarStartDate = Date
    If IsRange Then
        Dim Arr
        Dim MyRange As Range
        Set MyRange = varPassedDate
       [COLOR=#ff0000][B] 'Arr = CellPosition(MyRange)[/B][/COLOR]
        With UsfCalendar
            .StartUpPosition = 0
            '.Left = Arr(1)
            '.Top = Arr(2)
           [SIZE=2] [COLOR=#ff0000][B].Top = ActiveWindow.PointsToScreenPixelsY(MyRange.Top / 0.75) * 0.75 + MyRange.Height
            .Left = ActiveWindow.PointsToScreenPixelsX(MyRange.Left / 0.75) * 0.75[/B][/COLOR][/SIZE]
            .Show
        End With
    Else
        UsfCalendar.Show
    End If
    DatePicked = gvarSelectedDate
End Function

nếu mà hiển thị đúng thì ta bỏ được 1 số cái thằng quỉ API phải không . bớt được thằng nào đỡ phiền thằng đó . vì addin của anh đem sang máy 64 như em có chạy được đâu
Nhấp chuột vào đây để mở rộng...

Hồi đó, học hỏi các Thầy, thấy hàm đó chạy đáp ứng nhu cầu của mình nên không cần tìm hiểu sâu hơn. Cả 2 cách đều như nhau, nhưng cái làm mình đau đầu nhất vẫn là nếu Window bị Zoom <> 100. Cho dù mình có làm như cách dưới đây thì cũng tẻo tèo teo!

Mã: 
Function DatePicked(Optional ByVal varPassedDate As Variant, Optional ByVal IsRange As Boolean) As Variant
    On Error Resume Next
    gvarStartDate = IIf(IsMissing(varPassedDate), Date, varPassedDate)
    If Not IsDate(gvarStartDate) Then gvarStartDate = Date
    If IsRange Then
        Dim myRange As Range
        Dim myLeft As Single, myTop As Single
        Set myRange = varPassedDate
        With ActiveWindow
            myLeft = .PointsToScreenPixelsX(myRange.Left / 0.75) * 0.75
            myTop = .PointsToScreenPixelsY(myRange.Top / 0.75) * 0.75 + myRange.Height
[COLOR=#ff0000]            myLeft = (myLeft * .Zoom) / 100[/COLOR]
[COLOR=#ff0000]            myTop = (myTop * .Zoom) / 100[/COLOR]
        End With
        With UsfCalendar
            .StartUpPosition = 0
            .Left = myLeft
            .Top = myTop
            .Show
        End With
    Else
        UsfCalendar.Show
    End If
    DatePicked = gvarSelectedDate
End Function
 
Upvote 0
Hoàng Trọng Nghĩa đã viết:
Hồi đó, học hỏi các Thầy, thấy hàm đó chạy đáp ứng nhu cầu của mình nên không cần tìm hiểu sâu hơn. Cả 2 cách đều như nhau, nhưng cái làm mình đau đầu nhất vẫn là nếu Window bị Zoom <> 100. Cho dù mình có làm như cách dưới đây thì cũng tẻo tèo teo!
Nhấp chuột vào đây để mở rộng...
ồ đúng là công thức bị thiếu cái đó . em thật kém quá không lường hết . vậy giờ anh đâm thêm 2 nhát thử xem sao
Mã: 
myLeft = .PointsToScreenPixelsX(myRange.Left / 0.75 * .Zoom / 100) * 0.75
myTop = .PointsToScreenPixelsY((myRange.Top + myRange.Height) / 0.75 * .Zoom / 100) * 0.75
2 dòng chứ không phải 4 dòng đâu nha
 
Lần chỉnh sửa cuối:
Upvote 0
doveandrose đã viết:
ồ đúng là công thức bị thiếu cái đó . em thật kém quá không lường hết . vậy giờ anh đâm thêm 2 nhát thử xem sao
Mã: 
myLeft = .PointsToScreenPixelsX(myRange.Left / 0.75 * .Zoom / 100) * 0.75
myTop = .PointsToScreenPixelsY((myRange.Top + myRange.Height) / 0.75 * .Zoom / 100) * 0.75
2 dòng chứ không phải 4 dòng đâu nha
Nhấp chuột vào đây để mở rộng...
Không xi nhê đâu, kéo xuống vài trăm dòng vài chục cột là tèo luôn! Đang tìm cách khác đây.
 
Upvote 0
Vừa giải quyết xong cái vụ ZOOM nó lại thêm cái đau đầu khác: FREEZE PANE. -+*/-+*/;;;;;;;;;;;;;;;;;;;;;;**~****~**
 
Upvote 0
doveandrose đã viết:
cụ thể là anh giải quyết sao chỉ em với
Nhấp chuột vào đây để mở rộng...
Tạm thời phải dùng hàm này (sưu tầm trên net) để giải quyết các vấn đề Zoom trong sheet, nhưng vấn đền Freeze Pane thì bó tay chấm cơm vì chưa biết sử dụng đối tượng trong biến Pane (phần Optional màu đỏ) như thế nào hết.

Nguồn: http://hp.vector.co.jp/authors/VA016119/excel/cellpos.txt

Mã: 
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
    ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" ( _
    ByVal hwnd 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 LOGPIXELSY = 90


Const SplitBarWidth = 6
Const SplitBarHeight = 6
Const RoundConst = 0.5000001




Function CellScreenPos(CellRange As Range, _
        Optional Unit As Long = 0, [COLOR=#ff0000][B]Optional ByVal WnPane As Pane[/B][/COLOR]) As Variant
'Unit
'    0: Pixels (default)
'    1: Points
    
    Dim Wn As Window, ws As Worksheet
    Dim r As Range, r1 As Range, r2 As Range, vr(1 To 4) As Range
    Dim hdc As Long, px As Long, py As Long
    Dim x As Double, y As Double, x2 As Double, y2 As Double
    Dim i As Long, z As Long, sph As Long, spv As Long


    On Error GoTo ErrorHandler


    Set r = CellRange.Cells(1)
    Set ws = r.Worksheet


    If WnPane Is Nothing Then
        Set Wn = ActiveWindow
    Else
        Set Wn = WnPane.Parent
    End If


    Select Case Wn.Panes.Count
        Case 1
            Set vr(1) = Wn.VisibleRange
        Case 2
            Set vr(1) = Wn.Panes(1).VisibleRange
            Set vr(2) = Wn.Panes(2).VisibleRange
        Case 3, 4
            
            Set vr(1) = Wn.Panes(1).VisibleRange
            
            Set vr(4) = Wn.Panes(4).VisibleRange
            
            Set vr(2) = vr(1).Worksheet.Cells( _
                Wn.Panes(2).ScrollRow, Wn.Panes(2).ScrollColumn) _
                    .Resize(vr(1).Rows.Count, vr(4).Columns.Count)
            
            Set vr(3) = vr(1).Worksheet.Cells( _
                Wn.Panes(3).ScrollRow, Wn.Panes(3).ScrollColumn) _
                    .Resize(vr(4).Rows.Count, vr(1).Columns.Count)
    End Select


    If WnPane Is Nothing And Wn.FreezePanes Then
        For i = 1 To Wn.Panes.Count
            If Not Intersect(vr(i), r) Is Nothing Then Exit For
        Next
        If i > Wn.Panes.Count Then Exit Function
        Set WnPane = Wn.Panes(i)
    End If
    
    If WnPane Is Nothing Then Set WnPane = Wn.ActivePane


    Set r1 = vr(1)
    Set r2 = vr(WnPane.Index)
    If Intersect(r, r2) Is Nothing Then Exit Function


    hdc = GetDC(0)
    px = GetDeviceCaps(hdc, LOGPIXELSX)
    py = GetDeviceCaps(hdc, LOGPIXELSY)
    ReleaseDC 0, hdc: hdc = 0


    z = Wn.Zoom
    sph = Int(Wn.SplitHorizontal * px / 72 + RoundConst)
    spv = Int(Wn.SplitVertical * py / 72 + RoundConst)


    Select Case Sgn(Wn.SplitVertical) * 2 + Sgn(Wn.SplitHorizontal)
        Case 1
            If WnPane.Index = 2 Then x = sph
        Case 2
            If WnPane.Index = 2 Then y = spv
        Case 3
            Select Case WnPane.Index
                Case 2, 4: x = sph
            End Select
            Select Case WnPane.Index
                Case 3, 4: y = spv
            End Select
    End Select


    If x > 0 Then If Not Wn.FreezePanes Then x = x + SplitBarWidth
    If y > 0 Then If Not Wn.FreezePanes Then y = y + SplitBarHeight


    x = x + Wn.PointsToScreenPixelsX(0)
    y = y + Wn.PointsToScreenPixelsY(0)


    If (z \ 100) * 100 = z Then
        x = x + Int(r1.Left * px * z / 7200 + RoundConst)
        y = y + Int(r1.Top * py * z / 7200 + RoundConst)
        x = x + Int((r.Left - r2.Left) * px * z / 7200 + RoundConst)
        y = y + Int((r.Top - r2.Top) * py * z / 7200 + RoundConst)
        x2 = x + Int(r.Width * py * z / 7200 + RoundConst)
        y2 = y + Int(r.Height * py * z / 7200 + RoundConst)
    Else
        For i = 1 To r1.Column - 1
            x = x + Int(ws.Columns(i).Width * px * z / 7200 + RoundConst)
        Next
        For i = r2.Column To r.Column - 1
            x = x + Int(ws.Columns(i).Width * px * z / 7200 + RoundConst)
        Next
        x2 = x + Int(ws.Columns(i).Width * px * z / 7200 + RoundConst)


        For i = 1 To r1.Row - 1
            y = y + Int(ws.Rows(i).Height * py * z / 7200 + RoundConst)
        Next
        For i = r2.Row To r.Row - 1
            y = y + Int(ws.Rows(i).Height * py * z / 7200 + RoundConst)
        Next
        y2 = y + Int(ws.Rows(i).Height * py * z / 7200 + RoundConst)
    End If


    If Unit = 1 Then
        x = x * 72 / px
        y = y * 72 / py
        x2 = x2 * 72 / px
        y2 = y2 * 72 / py
    End If
    CellScreenPos = Array(x, y, x2, y2)
    Exit Function


ErrorHandler:
    If hdc <> 0 Then ReleaseDC 0, hdc
    Exit Function
End Function

Và tạm sử dụng như vầy:

Mã: 
Function DatePicked(Optional ByVal varPassedDate As Variant, Optional ByVal IsRange As Boolean) As Variant
    On Error Resume Next
    gvarStartDate = IIf(IsMissing(varPassedDate), Date, varPassedDate)
    If Not IsDate(gvarStartDate) Then gvarStartDate = Date
    If IsRange Then
        Dim myArr
        Dim myRange As Range
        Dim myLeft As Single, myTop As Single
        Set myRange = varPassedDate
        If ActiveWindow.FreezePanes Then
[B]            myArr = CellScreenPos(myRange, 1, [COLOR=#ff0000]ActiveWindow.Panes[/COLOR])[/B]
        Else
            myArr = CellScreenPos(myRange, 1)
        End If
        If IsArray(myArr) Then
            myLeft = myArr(2)
            myTop = myArr(3)
        End If
        With UsfCalendar
            .StartUpPosition = 0
            .Left = myLeft
            .Top = myTop
            .Show
        End With
    Else
        UsfCalendar.Show
    End If
    DatePicked = gvarSelectedDate
End Function


Phần ActiveWindow.Panes chả biết chọn đối tượng nào cho nó, nên nó không thực hiện được nên myArr không phải là mảng và vì thế khi form hiện lên có left = 0 và top = 0. Mà vậy cũng tạm chấp nhận còn hơn nó biến mất tiêu luôn!
 
Upvote 0
Hoàng Trọng Nghĩa đã viết:
Tạm thời phải dùng hàm này (sưu tầm trên net) để giải quyết các vấn đề Zoom trong sheet, nhưng vấn đền Freeze Pane thì bó tay chấm cơm vì chưa biết sử dụng đối tượng trong biến Pane (phần Optional màu đỏ) như thế nào hết.

Nguồn: http://hp.vector.co.jp/authors/VA016119/excel/cellpos.txt


Phần ActiveWindow.Panes chả biết chọn đối tượng nào cho nó, nên nó không thực hiện được nên myArr không phải là mảng và vì thế khi form hiện lên có left = 0 và top = 0. Mà vậy cũng tạm chấp nhận còn hơn nó biến mất tiêu luôn!
Nhấp chuột vào đây để mở rộng...

thất bại là mẹ của thất bại . hi hi
anh kiểm tra dùm hàm này trên máy anh xem freeze panel có bị sai không

Mã: 
Public Function CellPositionA(ByVal rCell As Range) As Variant
Const RoundConst = 0.5000001
Dim vr(1 To 3) As Range, arr(1 To 2) As Double, r As Long, ws As Worksheet
Dim lr As Long, lc As Long, tempVr As Range
Set ws = rCell.Parent


With ActiveWindow
    Set vr(1) = .Panes(1).VisibleRange
    If .Panes.Count > 1 Then Set vr(2) = .Panes(2).VisibleRange
    If .Panes.Count > 2 Then Set vr(3) = .Panes(3).VisibleRange
    arr(1) = .Panes(1).PointsToScreenPixelsX(0)
    arr(2) = .Panes(1).PointsToScreenPixelsY(0)
    lc = getLastColNum(vr(1))
    For r = 1 To lc Step 1
        If r >= rCell.Column Then Exit For
        arr(1) = arr(1) + Int(ws.Columns(r).Width / 0.75 * .Zoom / 100 + RoundConst)
    Next
    If Not vr(2) Is Nothing And r > lc Then
        If rCell.Column > vr(2).Column Then
            For r = vr(2).Column To getLastColNum(vr(2)) Step 1
                If r >= rCell.Column Then Exit For
                arr(1) = arr(1) + Int(ws.Columns(r).Width / 0.75 * .Zoom / 100 + RoundConst)
            Next
        End If
    End If
    
    lr = Mid(vr(1).Address, InStrRev(vr(1).Address, "$") + 1)
    For r = 1 To lr Step 1
        If r > rCell.Row Then Exit For
        arr(2) = arr(2) + Int(ws.Rows(r).Height / 0.75 * .Zoom / 100 + RoundConst)
    Next
    If Not vr(2) Is Nothing And r > lr Then
        If vr(2).Column = vr(1).Column Then Set tempVr = vr(2) Else Set tempVr = vr(3)
        If Not tempVr Is Nothing Then
            If tempVr.Row <= rCell.Row Then
                For r = tempVr.Row To Mid(tempVr.Address, InStrRev(tempVr.Address, "$") + 1) Step 1
                    If r > rCell.Row Then Exit For
                    arr(2) = arr(2) + Int(ws.Rows(r).Height / 0.75 * .Zoom / 100 + RoundConst)
                Next
            End If
        End If
    End If
End With
arr(1) = arr(1) * 0.75
arr(2) = arr(2) * 0.75
CellPositionA = arr
End Function

Mã: 
Private Function getLastColNum(target As Range) As Long
Dim arr As Variant
arr = Split(target.Address, "$")
getLastColNum = Range(arr(UBound(arr) - 1) & 1).Column
End Function
 
Upvote 0
doveandrose đã viết:
thất bại là mẹ của thất bại . hi hi
anh kiểm tra dùm hàm này trên máy anh xem freeze panel có bị sai không
Nhấp chuột vào đây để mở rộng...
Tốt rồi, nhưng có một nhược điểm là số hàng/ số cột càng lớn thì tốc độ load form càng chậm. Nhưng như thế đã quá tốt.

Phải chi lấy chỉ số của cái cột sát cái tiêu đề hàng và cột thì chiếu ra sẽ lẹ hơn là quét từ đầu đến ô đang tham chiếu.
 
Upvote 0
Hoàng Trọng Nghĩa đã viết:
Tốt rồi, nhưng có một nhược điểm là số hàng/ số cột càng lớn thì tốc độ load form càng chậm. Nhưng như thế đã quá tốt.

Phải chi lấy chỉ số của cái cột sát cái tiêu đề hàng và cột thì chiếu ra sẽ lẹ hơn là quét từ đầu đến ô đang tham chiếu.
Nhấp chuột vào đây để mở rộng...

muốn lấy cột đầu tiên trong khung nhìn đến ô cần hiện lịch thì phải tính được cái cột tên hàng . nghe nói cột này rộng 29 px . nhưng không lấy gì làm bảo đảm mà cũng không có công thức nào tính được
 
Upvote 0
doveandrose đã viết:
Mã: 
Private Function getLastColNum(target As Range) As Long
Dim arr As Variant
arr = Split(target.Address, "$")
getLastColNum = Range(arr(UBound(arr) - 1) & 1).Column
End Function
Nhấp chuột vào đây để mở rộng...
Hàm này sao không làm vầy cho khỏe?
PHP: 
Private Function getLastColNum(target As Range) As Long
getLastColNum = target.Column + target.Columns.Count - 1
End Function
 
Upvote 0
Lỡ làm thì làm nốt trường hợp này luôn đi --=0
Capture.JPG
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

LuuAnh980
Vấn đề viết tắt trong Diễn Đàn.
    • Thích
Trả lời
5
Đọc
63
befaint
befaint
ann266
Kế toán kho F&B
    • Cười
2
Trả lời
21
Đọc
211
ann266
ann266
P
Hướng dẫn giải bài tập excel
Trả lời
2
Đọc
65
VetMini
V
T
Cần bạn viết phần mềm quản lý quán karaoke bằng excel
Trả lời
7
Đọc
162
VetMini
V
senna
  • Question
Xin giúp đỡ tổng hợp dữ liệu từ nhiều file vào 1 file mà không cần mở file
Trả lời
1
Đọc
69
tle2003
T
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom