Tặng tiện ích CALENDAR tuyệt đẹp! (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
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,662
Được thích
16,725
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
Hoàng Trọng Nghĩa đã viết:
Tôi nghĩ là nên như vầy:

Mã: 
Public Function CellPositionC(ByVal rCell As Range) As Variant
    Dim arrLeftTop(1 To 2) As Double, r As Byte
[B][COLOR=#ff0000]    Set rCell = rCell(1, 1): rCell.Activate[/COLOR][/B]
    With ActiveWindow
        If Intersect(.ActivePane.VisibleRange, rCell) Is Nothing Then
            For r = 1 To .Panes.Count
                If Not Intersect(.Panes(r).VisibleRange, rCell) Is Nothing Then
                    arrLeftTop(1) = .Panes(r).PointsToScreenPixelsX(rCell.Left) * 0.75
                    arrLeftTop(2) = .Panes(r).PointsToScreenPixelsY(rCell.Top) * 0.75 [COLOR=#ff0000][B]+ rCell.Height[/B][/COLOR]
                    Exit For
                End If
            Next
        Else
            arrLeftTop(1) = .ActivePane.PointsToScreenPixelsX(rCell.Left) * 0.75
            arrLeftTop(2) = .ActivePane.PointsToScreenPixelsY(rCell.Top) * 0.75 [COLOR=#ff0000][B]+ rCell.Height[/B][/COLOR]
        End If
    End With
    CellPositionC = arrLeftTop
End Function
Nhấp chuột vào đây để mở rộng...
AddIn hông nên tự ý thay đổi vùng chọn và/hoặc ô hiện hành. Một số người dùng sẽ thấy khó chịu vì vấn đề này.
 
Upvote 0
huuthang_bd đã viết:
AddIn hông nên tự ý thay đổi vùng chọn và/hoặc ô hiện hành. Một số người dùng sẽ thấy khó chịu vì vấn đề này.
Nhấp chuột vào đây để mở rộng...


Ở đây nó không thay đổi vùng chọn vì nó chỉ căn cứ Cell đầu tiên của vùng thôi, nếu không làm vậy, chọn nguyên khối ô chắc nó trừ cái Height của ô đó chắc khủng lắm nhỉ? Chọn nguyên khối ô, rồi cho ô đầu tiên Active và cho Form hiển thị dưới ô đó, nhưng kết quả không thay đổi sau khi Unload Form thì đâu có gì phải lo đúng không.

Cái này mới lo nè:

arr(2) = .ActivePane.PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75

Vì nó sẽ phát sinh lỗi (hiếm ai sử dụng đến dòng cuối cùng, nhưng cũng phải loại trừ).

Còn cái này lại khác, kết quả không khác, nhưng an toàn:

arrLeftTop(2) = .ActivePane.PointsToScreenPixelsY(rCell.Top) * 0.75 + rCell.Height
 
Upvote 0
vừa rồi em có xem bản xla của anh trên FB có chỗ này chưa đúng
Mã: 
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long[COLOR=#ff0000][SIZE=3][B]Ptr[/B][/SIZE][/COLOR]

nó sẽ gây ra lỗi type mismatch ở dòng
Mã: 
hForm = FindWindow("ThunderDFrame", Me.Caption)
anh chỉ cần bỏ chữ Ptr màu đỏ đi là được

tiếp theo là về hiệu ứng . nếu có thể được . em để xuất anh nên tạo ra hiệu ứng khi hơ chuột qua từng ngày . đó có thể là đổi màu ô đó hoặc gì đó tùy . miễn sao người dùng nhận ra là đang rê chuột lên ô nào là được .

cuối cùng là khi click vào các nút hình mũi tên trên Form cảm giác hơi Lag thì phải . hi vọng đây chỉ là cảm giác nhất thời . em không chắc về điều này : xem hàm FixDaysInMonth từ phần
Dim a As String, b As String, c As String, d As String
trở xuống liệu có cần thiết chăng ? hay do em chưa nắm rõ ý nghĩa phần này ?
 
Upvote 0
doveandrose đã viết:
vừa rồi em có xem bản xla của anh trên FB có chỗ này chưa đúng
Mã: 
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long[COLOR=#ff0000][SIZE=3][B]Ptr[/B][/SIZE][/COLOR]

nó sẽ gây ra lỗi type mismatch ở dòng
Mã: 
hForm = FindWindow("ThunderDFrame", Me.Caption)
anh chỉ cần bỏ chữ Ptr màu đỏ đi là được
Nhấp chuột vào đây để mở rộng...
Tiện đây bạ cho mình hỏi nhân việc bạn bảo bỏ Ptr đi thì hàm sau không còn lỗi. Nhưng bỏ Ptr trong biến lại bị lỗi
#If VBA7 And Win64 Then 'Office 64-bit
Private Declare PtrSafe Function MessageBoxW Lib "user32" (ByVal hWnd As LongPtr, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As LongPtr) As Long
#Else ' Office 32-bit
Private Declare Function MessageBoxW Lib "user32" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
#End If
 
Lần chỉnh sửa cuối:
Upvote 0
viehoai đã viết:
Tiện đây bạ cho mình hỏi nhân việc bạn bảo bỏ Ptr đi thì hàm sau không còn lỗi. Nhưng bỏ Ptr trong biến lại bị lỗi
#If VBA7 And Win64 Then 'Office 64-bit
Private Declare PtrSafe Function MessageBoxW Lib "user32" (ByVal hWnd As LongPtr, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As LongPtr) As Long
#Else ' Office 32-bit
Private Declare Function MessageBoxW Lib "user32" (ByVal hWnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
#End If
Nhấp chuột vào đây để mở rộng...

không hiểu . bạn viết đại 1 sub làm ví dụ đi
 
Upvote 0
viehoai đã viết:
Mình đang dùng office 64 bit dùng hàm API thì biến Long ->LongPtr nhưng sao Long cuối (biến trả về của hàm) lại là Long không có Ptr
Nhấp chuột vào đây để mở rộng...

điều này sai !
vì thế tôi mới bảo bạn viết sub cụ thể . không có câu trả lời cho mọi trường hợp
kiểu trả về của hàm findWindow là Long hay LongPtr đều được . nhưng bạn vận dụng không khéo thì lỗi bạn ráng chịu
thí dụ bạn khai báo
findWindow return LongPtr
getMessageW (byval hWnd as LongPtr)

khi sử dụng getMessageW(activeWindow.hWnd,......) thì không sao
nhưng nếu tạo ra 1 biến Long tên là hw (vì viết cho cả 2 HĐH nên phải khai báo hw là Long) thì sai type Missmatch ngay
Mã: 
dim hw as Long
hw = findWindow (....)
call getMessageW (hW,....)

nhưng lại cũng có lúc bắt buộc phải khai báo LongPtr trên máy 64 bit chứ không được là Long
cho nên tôi mới yêu cầu bạn viết sub cụ thể thì tôi mới trả lời được là nên khai báo kiểu nào . không thể nói chung chung được
 
Upvote 0
doveandrose đã viết:
điều này sai !
vì thế tôi mới bảo bạn viết sub cụ thể . không có câu trả lời cho mọi trường hợp
kiểu trả về của hàm findWindow là Long hay LongPtr đều được . nhưng bạn vận dụng không khéo thì lỗi bạn ráng chịu
thí dụ bạn khai báo
findWindow return LongPtr
getMessageW (byval hWnd as LongPtr)

khi sử dụng getMessageW(activeWindow.hWnd,......) thì không sao
nhưng nếu tạo ra 1 biến Long tên là hw (vì viết cho cả 2 HĐH nên phải khai báo hw là Long) thì sai type Missmatch ngay
Mã: 
dim hw as Long
hw = findWindow (....)
call getMessageW (hW,....)

nhưng lại cũng có lúc bắt buộc phải khai báo LongPtr trên máy 64 bit chứ không được là Long
cho nên tôi mới yêu cầu bạn viết sub cụ thể thì tôi mới trả lời được là nên khai báo kiểu nào . không thể nói chung chung được
Nhấp chuột vào đây để mở rộng...
Mình vướng mắc như Bài #5 này nhưng chưa có kết quả vô tình đọc bài của bạn mình thử bỏ Ptr là OK nhưng có thắc mắc khi thì Long, khi thì Long Ptr là sao? có quy luật nào không mong bạn giải thích
Để khhông bị lạc đề topic này, bạn có thể trả lời tiếp link mình đã đưa nhé
Sub cụ thể bài 5 ở trên nhé.
Hay cụ thể hơn là sử dụng hàm này với office - 64 bit <<= Hàm này sửa đi, sửa lại cuối cùng cũng được rồi nhưng không biết lúc nào là Long, lúc nào là LongPtr
Cảm ơn bạn.
 
Lần chỉnh sửa cuối:
Upvote 0
viehoai đã viết:
Mình vướng mắc như Bài #5 này nhưng chưa có kết quả vô tình đọc bài của bạn mình thử bỏ Ptr là OK nhưng có thắc mắc khi thì Long, khi thì Long Ptr là sao? có quy luật nào không mong bạn giải thích
Để khhông bị lạc đề topic này, bạn có thể trả lời tiếp link mình đã đưa nhé
Sub cụ thể bài 5 ở trên nhé.
Hay cụ thể hơn là sử dụng hàm này với office - 64 bit <<= Hàm này sửa đi, sửa lại cuối cùng cũng được rồi nhưng không biết lúc nào là Long, lúc nào là LongPtr
Cảm ơn bạn.
Nhấp chuột vào đây để mở rộng...

í đừng xúi dại . mấy topic bạn nêu ra tôi không thấy có bài viết nào của bạn trong đó thì trả lời làm sao ? vô đó nói nhăng cuội lại xếp vào tội đào bới chủ đề cũ khi không ai có nhu cầu hỏi đáp
đây là cách làm của tôi thôi chứ không có theo sách vở nào hết
tất cả mọi chỗ có kiểu Long từ tham số cho tới kiểu trả về , tôi khai báo cứ để nguyên là Long . khi nào biên dịch nó la làng lên là
Type Missmatch thì vị trí nào báo sai thì vị trí đó sửa lại thành LongPtr
thí dụ chỉ cần sửa lại như vầy là đủ
Mã: 
Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
                                            (ByVal idHook As Long, _
                                             ByVal lpfn As Long[COLOR=#ff0000][SIZE=3][B]Ptr[/B][/SIZE][/COLOR], _
                                             ByVal hmod As Long, _
                                             ByVal dwThreadId As Long) As Long

tiếp theo hãy nhìn vào hàm MyUniMsgBox của Hoàng Trọng Nghĩa mà bạn trích dẫn
Mã: 
hHook = SetWindowsHookEx(WH_CBT, AddressOf MsgBoxHookProc, 0, GetCurrentThreadId)
đó chính là cách để tương thích được cả 2 HDH . tại sao vậy ?
hệ 32 bit hàm AddressOf trả về kiểu Long , 64 bit trả về kiểu LongLong
viết thẳng hàm này vào trong hàm SetWindowsHookEx thì ứng với hệ nào nó tự trả về đúng kiểu của hệ đó
còn viết như này là tự bắn vào chân
Mã: 
#If VBA7 Then
  Private Declare PtrSafe Function MessageBoxW Lib "user32" _
  (ByVal hwnd As Long, ByVal lpText As LongPtr, ByVal lpCaption As LongPtr, ByVal wType As VbMsgBoxStyle) As VbMsgBoxResult
#Else
  Private Declare Function MessageBoxW Lib "user32" _
  (ByVal hwnd As Long, ByVal lpText As Long, ByVal lpCaption As Long, ByVal wType As VbMsgBoxStyle) As VbMsgBoxResult
#End If
Sub ShowUniMsg()
  Dim text As String, [COLOR=#ff0000][B]textLg As Long[/B][/COLOR]
  text = ChrW(272) & "ây là Msgbox ti" & ChrW(7871) & "ng Vi" & ChrW(7879) & "t Unicode"
  [COLOR=#ff0000][B]textLg = StrPtr(text)[/B][/COLOR]
  MessageBoxW Application.hwnd,[COLOR=#ff0000][B] textLg,[/B][/COLOR] StrPtr("THÔNG BÁO"), 0
End Sub
cuối cùng bạn sẽ hỏi . vậy nếu tôi có nhu cầu gán giá trị của StrPtr(text) ra 1 biến trung gian để làm việc khác thì sao ?
có 2 cách . 1 cách nguy hiểm : khỏi khai báo biến textLg . cứ thế xài luôn
Mã: 
Sub ShowUniMsg()
  Dim text As String
  text = ChrW(272) & "ây là Msgbox ti" & ChrW(7871) & "ng Vi" & ChrW(7879) & "t Unicode"
  textLg = StrPtr(text)
  MessageBoxW Application.hwnd, textLg, StrPtr("THÔNG BÁO"), 0
End Sub
nhưng làm vậy thì các nhà thông thái sẽ chỉ trích : chưa khai báo biến textLg mà sử dụng là phản khoa học , blah .. blah
vậy thì khai báo cho vừa ý cả làng
Mã: 
#If VBA7 Then
  Private Declare PtrSafe Function MessageBoxW Lib "user32" _
  (ByVal hwnd As Long, ByVal lpText As LongPtr, ByVal lpCaption As LongPtr, ByVal wType As VbMsgBoxStyle) As VbMsgBoxResult
  Private textLg As LongPtr
#Else
  Private Declare Function MessageBoxW Lib "user32" _
  (ByVal hwnd As Long, ByVal lpText As Long, ByVal lpCaption As Long, ByVal wType As VbMsgBoxStyle) As VbMsgBoxResult
  Private textLg As Long
#End If
Sub ShowUniMsg()
  Dim text As String
  text = ChrW(272) & "ây là Msgbox ti" & ChrW(7871) & "ng Vi" & ChrW(7879) & "t Unicode"
  textLg = StrPtr(text)
  MessageBoxW Application.hwnd, textLg, StrPtr("THÔNG BÁO"), 0
End Sub
 
Upvote 0
doveandrose đã viết:
vừa rồi em có xem bản xla của anh trên FB có chỗ này chưa đúng
Mã: 
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long[COLOR=#ff0000][SIZE=3][B]Ptr[/B][/SIZE][/COLOR]

nó sẽ gây ra lỗi type mismatch ở dòng
Mã: 
hForm = FindWindow("ThunderDFrame", Me.Caption)
anh chỉ cần bỏ chữ Ptr màu đỏ đi là được
Nhấp chuột vào đây để mở rộng...
Thank you bạn! Tôi chơi 1 phát Replace em nào Long thì thành LongPtr và vì không có máy 64bit để kiểm tra nên chẳng biết sai chỗ nào để sửa.

doveandrose đã viết:
tiếp theo là về hiệu ứng . nếu có thể được . em để xuất anh nên tạo ra hiệu ứng khi hơ chuột qua từng ngày . đó có thể là đổi màu ô đó hoặc gì đó tùy . miễn sao người dùng nhận ra là đang rê chuột lên ô nào là được.
Nhấp chuột vào đây để mở rộng...

Cái này không khó, để xem nó phù hợp với màu nào hay hiệu ứng gì nhẹ nhàng thì sẽ thực hiện luôn.

doveandrose đã viết:
cuối cùng là khi click vào các nút hình mũi tên trên Form cảm giác hơi Lag thì phải . hi vọng đây chỉ là cảm giác nhất thời . em không chắc về điều này : xem hàm FixDaysInMonth từ phần
Nhấp chuột vào đây để mở rộng...

Đúng là nó có chớp, nhưng chưa có giải pháp hạn chế.

doveandrose đã viết:
Dim a As String, b As String, c As String, d As String
trở xuống liệu có cần thiết chăng ? hay do em chưa nắm rõ ý nghĩa phần này ?
Nhấp chuột vào đây để mở rộng...

Đúng là hồi đó mình làm trên Label chả có màu gì hết, chỉ màu mặc định nên mình viết cái đó để code tạo màu, sau này mình fill màu sẳn luôn nên code đó thừa, có thể bỏ luôn đoạn đó.
 
Lần chỉnh sửa cuối:
Upvote 0
anh Nghĩa vui lòng cho biết lý do sao ta cần phải sử dụng 2 label cho 1 ngày ( thí dụ lbl11 và AL11)
nếu sử dụng 1 label cho 1 ngày có được không ?
 
Upvote 0
doveandrose đã viết:
anh Nghĩa vui lòng cho biết lý do sao ta cần phải sử dụng 2 label cho 1 ngày ( thí dụ lbl11 và AL11)
nếu sử dụng 1 label cho 1 ngày có được không ?
Nhấp chuột vào đây để mở rộng...
Theo phán đoán của tôi thì 1 cái để hiển thị ngày dương, một cái để hiển thị ngày âm. Dùng một cái cũng được nhưng có lẽ sẽ không đẹp bằng.
 
Lần chỉnh sửa cuối:
Upvote 0
huuthang_bd đã viết:
Theo phán đoán của tôi thì 1 cái để hiển thị ngày dương, một cái để hiển thị ngày dương. Dùng một cái cũng được nhưng có lẽ sẽ không đẹp bằng.
Nhấp chuột vào đây để mở rộng...
tôi hỏi là vì tôi thử set Caption cho hàng loạt label trên Form khác thì thấy có tỉ lệ bị nháy màn hình nhất định nào đó không tránh khỏi .
nếu ở đây ta phải set Caption cho số lượng label giảm đi 1 nửa biết đâu tỉ lệ bị nháy màn hình cũng giảm đi thì tốt hơn
 
Upvote 0
doveandrose đã viết:
tôi hỏi là vì tôi thử set Caption cho hàng loạt label trên Form khác thì thấy có tỉ lệ bị nháy màn hình nhất định nào đó không tránh khỏi .
nếu ở đây ta phải set Caption cho số lượng label giảm đi 1 nửa biết đâu tỉ lệ bị nháy màn hình cũng giảm đi thì tốt hơn
Nhấp chuột vào đây để mở rộng...
Cái này phải chấp nhận đánh đổi thôi. Nếu dùng chung 1 label thì sẽ rất xấu. Thông thường cỡ font chữ ngày âm lịch sẽ nhỏ hơn ngày dương lịch, chưa kể người ta còn tô màu ngày đầu tháng âm lịch để nhận diện nữa. Nếu bạn dùng chung thì format sẽ phải giống nhau hết.
 
Upvote 0
Hỏi xoáy: Đặt con trỏ ngay ô màu vàng, bấm dấu cộng của Group cho nó xổ các hàng ẩn ra, sau đó gọi form xem nó nằm ở đâu? Nếu dung nhan mùa hạ nó nằm tuốt luốt bên dưới, trong trường hợp này mình muốn form nó hiện ra ở đâu cũng được, tức tính làm sao cái Top của nó phải nhỏ hơn cái top của sheet tab thì phải làm sao?
 

File đính kèm

Upvote 0
Hoàng Trọng Nghĩa đã viết:
Nói tóm lại là cái form nó show lên là được!

Sheet Tab là những cái tab mình bấm chọn sheet đó!
Nhấp chuột vào đây để mở rộng...
ặc . hôm nay mới biết nó kêu là sheet tab =))
làm cho form có nhìn thấy trong sheet thì dễ quá (0,0) cũng là nhìn thấy vậy
anh phải chỉ đích danh hiện chỗ nào mới có hứng làm anh ơi . (chứ như trên là chưa đủ xoáy)
 
Upvote 0
doveandrose đã viết:
ặc . hôm nay mới biết nó kêu là sheet tab =))
làm cho form có nhìn thấy trong sheet thì dễ quá (0,0) cũng là nhìn thấy vậy
anh phải chỉ đích danh hiện chỗ nào mới có hứng làm anh ơi . (chứ như trên là chưa đủ xoáy)
Nhấp chuột vào đây để mở rộng...
Cứ cho là (0, 0) đi, nhưng làm sao biết được nó xảy ra trong trường hợp này?
 
Upvote 0
Hoàng Trọng Nghĩa đã viết:
Hỏi xoáy: Đặt con trỏ ngay ô màu vàng, bấm dấu cộng của Group cho nó xổ các hàng ẩn ra, sau đó gọi form xem nó nằm ở đâu? Nếu dung nhan mùa hạ nó nằm tuốt luốt bên dưới, trong trường hợp này mình muốn form nó hiện ra ở đâu cũng được, tức tính làm sao cái Top của nó phải nhỏ hơn cái top của sheet tab thì phải làm sao?
Nhấp chuột vào đây để mở rộng...
Đề phòng cho trường hợp không bao giờ xảy ra --=0
Mã: 
Public Function CellPosition(ByVal rCell As Range) As Variant
    Dim arrLeftTop(1 To 2) As Double, r As Byte
    Set rCell = ActiveCell
    With ActiveWindow
        If Intersect(.ActivePane.VisibleRange, rCell) Is Nothing Then
            For r = 1 To .Panes.Count
                If Not Intersect(.Panes(r).VisibleRange, rCell) Is Nothing Then
                    arrLeftTop(1) = .Panes(r).PointsToScreenPixelsX(rCell.Left) * 0.75
                    arrLeftTop(2) = .Panes(r).PointsToScreenPixelsY(rCell.Top) * 0.75 + rCell.Height
                    Exit For
                End If
            Next
        Else
            arrLeftTop(1) = .ActivePane.PointsToScreenPixelsX(rCell.Left) * 0.75
            arrLeftTop(2) = .ActivePane.PointsToScreenPixelsY(rCell.Top) * 0.75 + rCell.Height
        End If
    End With
[COLOR=#0000cd]    Dim TmpCll As Range[/COLOR]
[COLOR=#0000cd]    On Error Resume Next
    Set TmpCll = ActiveWindow.RangeFromPoint(arrLeftTop(1) / 0.75, (arrLeftTop(2) - rCell.Height) / 0.75)
    On Error GoTo 0
    If TmpCll Is Nothing Then
        arrLeftTop(1) = 0
        arrLeftTop(2) = 0
    End If[/COLOR]
    CellPosition = arrLeftTop
End Function
 
Upvote 0
xin được góp ý về 1 chỗ chưa hợp lý trên addin
hình như anh có tạo phím tắt Escape dùng để thoát Form , và khi thoát Form thì nội dung của cell vừa Active cũng bị xóa luôn
đó là sự bất hợp lý vì khi người dùng bấm Escape đó là dấu hiệu cho thấy họ không muốn lấy nội dung gì từ Calendar cả , nhưng nội dung hiện hành của Active cell thì cần phải giữ nguyên như lúc chưa Show Form . mong anh để ý giúp
 
Upvote 0
doveandrose đã viết:
xin được góp ý về 1 chỗ chưa hợp lý trên addin
hình như anh có tạo phím tắt Escape dùng để thoát Form , và khi thoát Form thì nội dung của cell vừa Active cũng bị xóa luôn
đó là sự bất hợp lý vì khi người dùng bấm Escape đó là dấu hiệu cho thấy họ không muốn lấy nội dung gì từ Calendar cả , nhưng nội dung hiện hành của Active cell thì cần phải giữ nguyên như lúc chưa Show Form . mong anh để ý giúp
Nhấp chuột vào đây để mở rộng...
Đang cập nhật bản mới nhất có nội dung như:

1) Về giao diện, không ẩn những Label mà vẫn để chúng show ra với dạng ngày tháng trước và ngày tháng sau trong 42 cái label DL và 42 cái AL. Khi click vào đây sẽ đỡ phải bấm chạy qua tháng trước hoặc tháng sau một vài ngày. Giao diện sẽ nhẹ nhàng hơn một tí.

2) Có một Label phía dưới cùng khi click vào sẽ thoát form và không ghi gì cả.

3) Nếu vùng (khối ô) được chọn sẽ cảnh báo trước.

4) Nếu vùng có dữ liệu sẽ thông báo. Nếu ô có dữ liệu thì hiển thị dữ liệu đó trên msgbox và hỏi có muốn thay thế hay không. Còn nếu vùng/ ô được chọn không có dữ liệu thì sẽ không hỏi gì.

5) Đang viết hiệu ứng rê chuột, sẽ sớm hoàn thiện thôi.

Nhưng chắc sẽ tạo một topic mới để mọi người dễ dàng truy cập.
 
Upvote 0
Đã hoàn tất phiên bản V.5 rồi nhé! Ngày mai gửi tặng các bạn! Giờ nhá hàng thôi, làm mấy file một lúc nên đuối lắm rồi!

Đó, khi rê chuột trên Label nó có cái khung hồng hồng chạy theo con chuột đó. Để làm được điều này trên 42 Label là chuyện khủng khiếp đó, nhưng ta viết sự kiện MouseMove cho Label trong Class thì OK (sự kiện này không có sẳn trong Class nên ta phải tạo ra nó).

Và những ngày tháng xám xám là ngày của tháng trước hoặc ngày của tháng sau.
 

File đính kèm

  • ReChuot.jpg
    ReChuot.jpg
    63.2 KB · Đọc: 75
Upvote 0
Định gửi bài lên rồi, nhưng còn vướng một điểm là xác định vị trí!

Có 3 vị trí cần tìm trong một file Excel đó là:

1) Cell trên worksheet,

2) Control trên form,

3) Control trên worksheet.

Ta có thể tìm được 2 cái trên, vậy cái thứ 3 sao tìm ra vị trí được ta, giúp mình cái này luôn đi. Vị trí này giống y vị trí của Cell, nó cũng lệ thuộc Zoom, Freeze Pane v.v...
 
Upvote 0
Hoàng Trọng Nghĩa đã viết:
Định gửi bài lên rồi, nhưng còn vướng một điểm là xác định vị trí!

Có 3 vị trí cần tìm trong một file Excel đó là:

1) Cell trên worksheet,

2) Control trên form,

3) Control trên worksheet.

Ta có thể tìm được 2 cái trên, vậy cái thứ 3 sao tìm ra vị trí được ta, giúp mình cái này luôn đi. Vị trí này giống y vị trí của Cell, nó cũng lệ thuộc Zoom, Freeze Pane v.v...
Nhấp chuột vào đây để mở rộng...

hoặc là anh tải lên cho em mượn cái addin hoặc là anh xem cái này
anh nói Control trên Worksheet tức là nói về 1 textbox được tạo trên sheet ?
vậy thì nó đâu khác gì 1 cell đâu . anh thay đối số hàm CellPosition cho nhận vào 1 kiểu Variant (có khi là Cell có khi là Textbox)

để biết textbox thuộc về panes nào thì anh chạy cái này
Mã: 
With ActiveWindow
Dim r As Byte, vRG As Range
For r = 1 To .Panes.Count Step 1
    Set vRG = .Panes(r).VisibleRange
    If vRG(1, 1).Top <= Sheet1.TextBox2.Top And _
       vRG(1, 1).Offset(vRG.Rows.Count).Top >= Sheet1.TextBox2.Top And _
       vRG(1, 1).Left <= Sheet1.TextBox2.Left And _
       vRG(1, 1).Offset(, vRG.Columns.Count).Left >= Sheet1.TextBox2.Left Then
        Exit For
    End If
Next
End With
MsgBox r

khi đã biết textbox thuộc về panes nào rồi thì chuyện còn lại đâu có gì phải bàn nữa
có điều em thấy phải chỉnh StartUpPosition của Form thành Manual mới hiển thị đúng với textbox trên sheet
 
Upvote 0
ở trên vẫn chưa đúng khi textbox nằm khuất chứ không nằm trọn trong 1 panel . để tìm cách khác vậy
===============================================================
hàm tìm vị trí của Textbox trên Sheet , hàm CellPosition thôi ta giữ nguyên
Mã: 
Public Function ControlPosition(ByVal mCtrl As Variant) As Variant
Dim arr(1 To 2) As Double, r As Byte, vRG As Range
Dim recPoint(1 To 4) As Double, cellRec(1 To 4) As Double
With mCtrl
    recPoint(1) = .Top
    recPoint(2) = .Top + .Height
    recPoint(3) = .Left
    recPoint(4) = .Left + .Width
End With
With ActiveWindow
    For r = 1 To .Panes.Count Step 1
        Set vRG = .Panes(r).VisibleRange
        cellRec(1) = vRG(1, 1).Top
        cellRec(2) = vRG(1, 1).Offset(vRG.Rows.Count).Top
        cellRec(3) = vRG(1, 1).Left
        cellRec(4) = vRG(1, 1).Offset(, vRG.Columns.Count).Left
        If ((cellRec(1) <= recPoint(1) And cellRec(2) >= recPoint(1)) Or ( _
            cellRec(1) <= recPoint(2) And cellRec(2) >= recPoint(2))) _
        And _
           ((cellRec(3) <= recPoint(3) And cellRec(4) >= recPoint(3)) Or ( _
            cellRec(3) <= recPoint(4) And cellRec(4) >= recPoint(4))) Then
            arr(1) = .Panes(r).PointsToScreenPixelsX(recPoint(3)) * 0.75
            arr(2) = .Panes(r).PointsToScreenPixelsY(recPoint(2)) * 0.75
            Exit For
        End If
    Next
End With
ControlPosition = arr
End Function

như thế hình thành ra 3 trường hợp
Application.Run "'CalendarShow.xla'!CalendarOpen", ActiveCell
Application.Run "'CalendarShow.xla'!CalendarOpen", Sheet1.TextBox2
Application.Run "'CalendarShow.xla'!CalendarOpen", Me.TextBox1, Me
 
Lần chỉnh sửa cuối:
Upvote 0
doveandrose đã viết:
ở trên vẫn chưa đúng khi textbox nằm khuất chứ không nằm trọn trong 1 panel . để tìm cách khác vậy
===============================================================
hàm tìm vị trí của Textbox trên Sheet , hàm CellPosition thôi ta giữ nguyên
Mã: 
Public Function ControlPosition(ByVal mCtrl As Variant) As Variant
Dim arr(1 To 2) As Double, r As Byte, vRG As Range
Dim recPoint(1 To 4) As Double, cellRec(1 To 4) As Double
With mCtrl
    recPoint(1) = .Top
    recPoint(2) = .Top + .Height
    recPoint(3) = .Left
    recPoint(4) = .Left + .Width
End With
With ActiveWindow
    For r = 1 To .Panes.Count Step 1
        Set vRG = .Panes(r).VisibleRange
        cellRec(1) = vRG(1, 1).Top
        cellRec(2) = vRG(1, 1).Offset(vRG.Rows.Count).Top
        cellRec(3) = vRG(1, 1).Left
        cellRec(4) = vRG(1, 1).Offset(, vRG.Columns.Count).Left
        If ((cellRec(1) <= recPoint(1) And cellRec(2) >= recPoint(1)) Or ( _
            cellRec(1) <= recPoint(2) And cellRec(2) >= recPoint(2))) _
        And _
           ((cellRec(3) <= recPoint(3) And cellRec(4) >= recPoint(3)) Or ( _
            cellRec(3) <= recPoint(4) And cellRec(4) >= recPoint(4))) Then
            arr(1) = .Panes(r).PointsToScreenPixelsX(recPoint(3)) * 0.75
            arr(2) = .Panes(r).PointsToScreenPixelsY(recPoint(2)) * 0.75
            Exit For
        End If
    Next
End With
ControlPosition = arr
End Function

như thế hình thành ra 3 trường hợp
Application.Run "'CalendarShow.xla'!CalendarOpen", ActiveCell
Application.Run "'CalendarShow.xla'!CalendarOpen", Sheet1.TextBox2
Application.Run "'CalendarShow.xla'!CalendarOpen", Me.TextBox1, Me
Nhấp chuột vào đây để mở rộng...
Quả thật làm việc theo nhóm thật thú vị, tôi sẽ test kỹ hàm này, sau đó gửi lên version mới luôn! Cám ơn bạn.
 
Upvote 0
huuthang_bd đã viết:
Nên chăng sửa lại như vầy
PHP: 
Public Function CellPositionC(ByVal rCell As Range) As Variant
Dim arr(1 To 2) As Double, r As Byte
With ActiveWindow
    If Intersect(.ActivePane.VisibleRange, rCell) Is Nothing Then
        For r = 1 To .Panes.Count
            If Not Intersect(.Panes(r).VisibleRange, rCell) Is Nothing Then
                arr(1) = .Panes(r).PointsToScreenPixelsX(rCell.Left) * 0.75
                arr(2) = .Panes(r).PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
                Exit For
            End If
        Next
    Else
        arr(1) = .ActivePane.PointsToScreenPixelsX(rCell.Left) * 0.75
        arr(2) = .ActivePane.PointsToScreenPixelsY(rCell.Offset(1).Top) * 0.75
    End If
End With
CellPositionC = arr
End Function
Nhấp chuột vào đây để mở rộng...
Có cách nào đưa hàm này qua VB.Net được không mọi người. Mình chuyển qua Form không đúng vị trí ạ
 
Upvote 0
Hoàng Trọng Nghĩa đã viết:
Có thể nói cái lịch này là một tiện ích "có thể" thay thế được với control Caledar của Excel VBA, giao diện thân thiện hơn, dễ chỉnh sửa, nói chung là dễ cá nhân hóa nó theo ý thích.

Nhập ngày tháng nhanh chóng bất cứ ở đâu, trên form hoặc trên sheet

Coi ngày tháng Âm lịch từ ngày 01/02/1900 (DL) đến 14/2/2200 (DL)

Nhập liệu nhanh chóng trên sheet thì chúng ta có thể làm một nút lệnh trên Cell Menu như sau:

Trong Module ThisWorkBook, đặt 2 thủ tục này để tạo Menu:

Mã: 
Private Sub Workbook_Activate()
    With Application.CommandBars("Cell")
        .Reset
        .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_Deactivate()
    Application.CommandBars("Cell").Reset
End Sub

Khi click chuột phải sẽ như thế này:

attachment.php


Sau khi chọn vào Calendar thì lịch được show như vầy:

attachment.php


Chỉ việc bấm chọn ngày tháng cần thiết vào ô hoặc khối ô được chọn, chỉ với thủ tục như thế này thôi:

Mã: 
Sub CalShow()
      Dim Ftop As Double, Fleft As Double
      With Selection
            Fleft = .Left [COLOR=#ff0000]+ 22[/COLOR] [COLOR=#008000]'Màu đỏ có thể chưa chính xác cho từng loại Window[/COLOR]
            Ftop = .Top + .Height[COLOR=#ff0000] + 110[/COLOR]
            With UsfCalendar
                  .StartUpPosition = 0
                  .Top = Ftop
                  .Left = Fleft
            End With
            .Value = DatePicked(.Value)
      End With
End Sub

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

Xa hơn nữa, sẽ định cải tiến trên cơ sở dữ liệu (nhỏ thôi) các ghi chú, sinh nhật, nhắc nhở v.v...

Mà thôi, thấy chẳng ai bận tâm, thậm chí chỉ một vài người cám ơn (mặc dù đã tải hơn 120 lần) nên chẳng muốn cải tiến tí nào!
Nhấp chuột vào đây để mở rộng...
Hi bạn
Mình có userform mà gọi lịch không được, mình thì mù VBA nên nhờ được giúp dỡ ạ.
Không biết cách nào để có lịch trên form hết
Cám ơn nhiều ạ
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (2 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
413
Đọc
50K
tuanktt3
T
N
  • Question Question
Cho em hỏi về mail merge bằng vba (2 người xem)
Trả lời
7
Đọc
200
Hoàng Tuấn 868
H
L
Nhờ anh chị giúp đỡ công thức hàm len (1 người xem)
Trả lời
17
Đọc
102
LOGANWover
L
SA_DQ
  • Question Question
Bài tập VBA cho những người rỗi. . . đủ thứ! (1 người xem)
Trả lời
0
Đọc
44
SA_DQ
SA_DQ
N
Chuyển dấu chấm thành dấu chấm phẩy trong dữ liệu (1 người xem)
Trả lời
3
Đọc
45
ptm0412
ptm0412
T
Khóa cột cập nhật dữ liệu
Trả lời
1
Đọc
100
HUONGHCKT
H
H
  • Question Question
Xin giúp đỡ về tạo hàm excel với C# và excel-dna
Trả lời
4
Đọc
129
hdcv.excel
H
befaint
Chia sẻ tâm tư, xả nỗi lòng (1 người xem)
    • Thích
6 7 8
Trả lời
761
Đọc
63K
befaint
befaint
B
Bỏ lọc và sort trong VBA
Trả lời
1
Đọc
65
Bảo_Anh_
B
K
Điền giá trị ô thay vì địa chỉ ô
Trả lời
5
Đọc
214
DeTong
D
T
Xin hỏi về bảng lương (1 người xem)
Trả lời
1
Đọc
130
SA_DQ
SA_DQ
T
Nhờ anh chị xem giúp file bị lỗi gì mà chạy rất chậm/lag - File tính tiền nhà trọ
Trả lời
3
Đọc
118
Thaik05
T
J
chiết khấu ở hóa đơn bán lẻ, lưu vào sheet tổng hợp
Trả lời
2
Đọc
87
le_vis
L
2
  • Question Question
Hỏi cách in phiếu điều tra PCGD-XMC từ file dữ liệu mẫu xuất ra từ hệ thống PCGD-XMC của Bộ GD (1 người xem)
    • Thích
Trả lời
8
Đọc
725
Hoàng Tuấn 868
H
B
Sau 1 tháng Mã Lại reset về 1 trở lên (1 người xem)
    • Chấp nhận
Trả lời
23
Đọc
386
SA_DQ
SA_DQ
H
Đánh số thứ thự phiếu thu chi (2 người xem)
Trả lời
16
Đọc
335
HangktGTN
H
4
HỌC ĐẠI LÝ THUẾ
Trả lời
1
Đọc
65
Hoàng Tuấn 868
H
B
Chuyển số tiền thành chữ
Trả lời
3
Đọc
99
bongngongo
B
S
Tạo sheet mới từ dữ liệu 2 sheet khác ĐVT
Trả lời
1
Đọc
119
Hoàng Tuấn 868
H
H
Tìm kiếm thông tin chi tiết trên sheet tổng hợp (1 người xem)
Trả lời
1
Đọc
113
LOGANWover
L
Xem thêm…

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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom