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

[Hoàng Trọng Nghĩa]

***************************************************************************************************************
***************************************************************************************************************
Đã 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)

​

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.

​

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.

– Chọn tháng –



– Chọn năm –


​

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.

​

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.

​

 

[Hoàng Trọng Nghĩa]

ĐÃ UPDATE THÀNH ADDINS VỚI CÁC THỦ TỤC ĐƠN GIẢN.

TẢI BÀI MỚI TẠI ĐÂY (BÀI #63) - CLICK VÀO ĐÂY


Đã 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]

 

[KUMI]

Quả là rất hay và đẹp!
Nhưng nếu có thêm phần ghi chú,ghi nhớ (những sự kiện) theo ngày tháng năm rất Mỹ mãn Thầy ạ!

 

[Hoàng Trọng Nghĩa]

Quả là rất hay và đẹp!
Nhưng nếu có thêm phần ghi chú,ghi nhớ (những sự kiện) theo ngày tháng năm rất Mỹ mãn Thầy ạ!

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.

 

[Hoàng Trọng Nghĩa]

Trong Calendar này tôi có để thủ tục khi load form như sau:

'*********************************************************************************************
Private Sub UserForm_Initialize()
      Dim hForm As Long, TitleHeigh As Double
      TitleHeigh = Me.Height - Me.InsideHeight
      hForm = FindWindow("ThunderDFrame", Me.Caption)
      SetWindowLong hForm, GWL_STYLE, GetWindowLong(hForm, GWL_STYLE) And Not (WS_BORDER Or WS_CAPTION Or WS_THICKFRAME Or WS_DLGFRAME)
      SetWindowLong hForm, GWL_EXSTYLE, GetWindowLong(hForm, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
      Me.Height = Me.Height - TitleHeigh
      
      LbSolar.ControlTipText = "B" & ChrW$(7845) & "m vào " & ChrW$(273) & "ây " & ChrW$(273) & ChrW$(7875) & " ch" & ChrW$(7885) & "n ngày hôm nay."
      LbLunar.ControlTipText = LbSolar.ControlTipText
      
      CmdPreviousMonth.ControlTipText = "Xem tháng tr" & ChrW$(432) & ChrW$(7899) & "c"
      CmdNextMonth.ControlTipText = "Xem tháng k" & ChrW$(7871) & " ti" & ChrW$(7871) & "p"
      CmdPreviousYear.ControlTipText = "Xem n" & ChrW$(259) & "m tr" & ChrW$(432) & ChrW$(7899) & "c"
      CmdNextYear.ControlTipText = "Xem n" & ChrW$(259) & "m k" & ChrW$(7871) & " ti" & ChrW$(7871) & "p"

      Dim m As Long, y As Long
      For m = 1 To 12
            Month.AddItem "THÁNG " & Format(m, "00")
      Next
      
      For y = 1900 To 2199
            Year.AddItem "N" & ChrW$(258) & "M " & y
      Next
      
     [COLOR=#008000][B] 'If you want to close calendar after click a day, choose isClose = True, otherwise isClose = False.[/B][/COLOR][COLOR=#ff0000][B]
      isClose = True 'False[/B][/COLOR]
End Sub

Có nghĩa là, nếu các bạn không muốn click vào ngày đó nó tự thoát form, thì chọn cho isClose là False, chỉ thoát khi nhấn phím Enter hoặc Esc.

 

[yeudoi]

Quả là rất hay. Đúng như Anh đã nói cái này chỉ để cài đặt nhập liệu và xem trong file của mình thôi chứ như một phần mềm để ghi chú thì hơi phúc tạp đó

 

[thanhlanh]

Trong Calendar này tôi có để thủ tục khi load form như sau:

'*********************************************************************************************
Private Sub UserForm_Initialize()
      Dim hForm As Long, TitleHeigh As Double
      TitleHeigh = Me.Height - Me.InsideHeight
      hForm = FindWindow("ThunderDFrame", Me.Caption)
      SetWindowLong hForm, GWL_STYLE, GetWindowLong(hForm, GWL_STYLE) And Not (WS_BORDER Or WS_CAPTION Or WS_THICKFRAME Or WS_DLGFRAME)
      SetWindowLong hForm, GWL_EXSTYLE, GetWindowLong(hForm, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME
      Me.Height = Me.Height - TitleHeigh
      
      LbSolar.ControlTipText = "B" & ChrW$(7845) & "m vào " & ChrW$(273) & "ây " & ChrW$(273) & ChrW$(7875) & " ch" & ChrW$(7885) & "n ngày hôm nay."
      LbLunar.ControlTipText = LbSolar.ControlTipText
      
      CmdPreviousMonth.ControlTipText = "Xem tháng tr" & ChrW$(432) & ChrW$(7899) & "c"
      CmdNextMonth.ControlTipText = "Xem tháng k" & ChrW$(7871) & " ti" & ChrW$(7871) & "p"
      CmdPreviousYear.ControlTipText = "Xem n" & ChrW$(259) & "m tr" & ChrW$(432) & ChrW$(7899) & "c"
      CmdNextYear.ControlTipText = "Xem n" & ChrW$(259) & "m k" & ChrW$(7871) & " ti" & ChrW$(7871) & "p"

      Dim m As Long, y As Long
      For m = 1 To 12
            Month.AddItem "THÁNG " & Format(m, "00")
      Next
      
      For y = 1900 To 2199
            Year.AddItem "N" & ChrW$(258) & "M " & y
      Next
      
     [COLOR=#008000][B]'If you want to close calendar after click a day, choose isClose = True, otherwise isClose = False.[/B][/COLOR][COLOR=#ff0000][B]
      isClose = True 'False[/B][/COLOR]
End Sub

Có nghĩa là, nếu các bạn không muốn click vào ngày đó nó tự thoát form, thì chọn cho isClose là False, chỉ thoát khi nhấn phím Enter hoặc Esc.

Mình xin có ý kiến, bạn thử tạo thành một add-ins để chạy cùng Excel để cần thì mở Ex lên là có ngay, khỏi mất công đi tìm.
Nếu muốn hiện trên tray thì bạn ghép với file này:
Thử xem

 

[Hoàng Trọng Nghĩa]

Cải tiến: Kéo thả để di chuyển lịch, thêm Thứ trong tuần.

Tôi thấy cái lịch vì nó không có Caption trên Form nên không biết di dời nó ra chỗ khác bằng cách nào, hôm nay, cải tiến thêm một bước đó là rê con chuột đến 1 Label THỨ bất kỳ rồi nắm giữ chuột, sau đó kéo thả đến chỗ nào đó trên màn hình! Thủ tục như sau:

''*********************************************************************************************
Private Sub lblDay1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
      PosX = X: PosY = Y
End Sub

Private Sub lblDay1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
      Me.Left = Me.Left - (Button > 0) * (X - PosX)
      Me.Top = Me.Top - (Button > 0) * (Y - PosY)
End Sub

''*********************************************************************************************

Bạn nắm chuột vào các Label này:

''**********************************************************
Đồng thời, tôi cũng thêm một hàm Thứ trong tuần để hiển thị trên Label Dương Lịch:

Function fThu(ByVal WeekNum) As String
      Dim DayWeek As Variant
      DayWeek = Array("", "Nh" & ChrW$(7853) & "t", "Hai", _
                          "Ba", "T" & ChrW$(432), _
                          "N" & ChrW$(259) & "m", "Sáu", _
                          "B" & ChrW$(7843) & "y")
      Select Case WeekNum
            Case 1
                  fThu = "Ch" & ChrW$(7911) & " " & DayWeek(WeekNum) & " "
            Case 2 To 7
                  fThu = "Th" & ChrW$(7913) & " " & DayWeek(WeekNum) & " "
            Case Else
                  GoTo ExitFunction
            End Select
      Exit Function
ExitFunction:
      fThu = ""
End Function

Giờ đây khi show lịch thì nó sẽ như thế này:

- Có thêm "Thứ Ba" trên Calendar -

​

Các bạn tải file mới nhất tại bài 2 của topic này (đã update):

http://www.giaiphapexcel.com/forum/...n-ích-CALENDAR-tuyệt-đẹp!&p=451406#post451406

 

[ndu96081631]

Đồng thời, tôi cũng thêm một hàm Thứ trong tuần để hiển thị trên Label Dương Lịch:

Function fThu(ByVal WeekNum) As String
      Dim DayWeek As Variant
      DayWeek = Array("", "Nh" & ChrW$(7853) & "t", "Hai", _
                          "Ba", "T" & ChrW$(432), _
                          "N" & ChrW$(259) & "m", "Sáu", _
                          "B" & ChrW$(7843) & "y")
      Select Case WeekNum
            Case 1
                  fThu = "Ch" & ChrW$(7911) & " " & DayWeek(WeekNum) & " "
            Case 2 To 7
                  fThu = "Th" & ChrW$(7913) & " " & DayWeek(WeekNum) & " "
            Case Else
                  GoTo ExitFunction
            End Select
      Exit Function
ExitFunction:
      fThu = ""
End Function

Trong UserForm có đoạn:

.Caption = [COLOR=#ff0000]fThu[/COLOR](intCol) & DateSerial(iYear, iMonth, Day)

Với fThu chính là Function mà Nghĩa vừa viết
Nếu tôi sửa thế này thì sao:

.Caption = Evaluate("Text(" & intCol & ", ""[$-42A]dddd "")") & DateSerial(iYear, iMonth, Day)

Tức là không cần đến Function vừa viết?

 

[Hoàng Trọng Nghĩa]

Trong UserForm có đoạn:

.Caption = [COLOR=#ff0000]fThu[/COLOR](intCol) & DateSerial(iYear, iMonth, Day)

Với fThu chính là Function mà Nghĩa vừa viết
Nếu tôi sửa thế này thì sao:

.Caption = Evaluate("Text(" & intCol & ", ""[$-42A]dddd "")") & DateSerial(iYear, iMonth, Day)

Tức là không cần đến Function vừa viết?

Dạ, rất hay, vậy là ta có thể dùng hàm Evaluate để chuyển hàm Text trong Excel thay vì phải dùng đến WorksheetFunction. Có một điều em vẫn không thích kiểu định dạng này là vì đối với Excel 2003 trở về trước, thay vì là Chủ Nhật nó viết toàn bộ bằng chữ thường chủ nhật (phải thêm hàm PROPER vào nữa). Điều thứ hai em vẫn muốn nó xài rộng hơn cả Excel nên em không muốn lệ thuộc vào hàm của Excel.

Thay vì em dùng hàm cũ:

Function fThu(ByVal WeekNum) As String
      Dim DayWeek As Variant
      DayWeek = Array("", "Nh" & ChrW$(7853) & "t", "Hai", _
                          "Ba", "T" & ChrW$(432), _
                          "N" & ChrW$(259) & "m", "Sáu", _
                          "B" & ChrW$(7843) & "y")
      Select Case WeekNum
            Case 1
                  fThu = "Ch" & ChrW$(7911) & " " & DayWeek(WeekNum) & " "
            Case 2 To 7
                  fThu = "Th" & ChrW$(7913) & " " & DayWeek(WeekNum) & " "
            Case Else
                  GoTo ExitFunction
            End Select
      Exit Function
ExitFunction:
      fThu = ""
End Function

Bây giờ em viết lại hàm đó như sau:

Function DayInWeek(ByVal TheDate As Date) As String
      Dim DayWeek As Variant, str As String
      str = "Th" & ChrW$(7913)
      DayWeek = Array("", "Ch" & ChrW$(7911) & " Nh" & ChrW$(7853) & "t", _
                          str & " Hai", _
                          str & " Ba", _
                          str & " T" & ChrW$(432), _
                          str & " N" & ChrW$(259) & "m", _
                          str & " Sáu", _
                          str & " B" & ChrW$(7843) & "y")
     [COLOR=#800080][B] DayInWeek [/B][/COLOR][COLOR=#0000ff][B]= DayWeek(WeekDay(TheDate)) [/B][/COLOR][COLOR=#ff0000][B]& " " & TheDate[/B][/COLOR]
End Function

(Với hàm này ta có thể mở rộng ra làm kiểu định dạng chung cho ngày tháng, như thế này:

Function DayInWeek(ByVal TheDate As Date, Byval KieuDinhDang As String) As String

và cách dùng: DayInWeek(Date,"dd/mm/yyyy") chẳng hạn).

Và cái thủ tục:

.Caption = [COLOR=#ff0000]fThu[/COLOR](intCol) & DateSerial(iYear, iMonth, Day)

sẽ được sửa lại như sau:

.Caption = [COLOR=#ff0000]DayInWeek[/COLOR](DateSerial(iYear, iMonth, Day))

Và thủ tục xử lý ngày sẽ được loại bỏ công đoạn tìm số ngày trong cột như sau:

Loại bỏ: Dim intCol As Byte

và: intCol = Right(mstrSelected, 1)

Giờ đơn giản hơn một chút với thủ tục dưới đây:

Private Sub HandleIndent(strNewSelect As String)
      If ErrHdle = 0 Then
HdleIdnt:
            If Len(mstrSelected) > 0 Then
                  With Me(mstrSelected)
                        .BorderStyle = 0
                        .Font.Size = 11
                        .Font.Bold = False
                        .BackStyle = 1
                  End With
                  Me(Replace(mstrSelected, "lbl", "AL")).Font.Bold = False
            End If
            
            mstrSelected = strNewSelect
            
            Me(Replace(mstrSelected, "lbl", "AL")).Font.Bold = True
            
            With Me(mstrSelected)
                  .Font.Bold = True
                  .Font.Size = 12
                  .BorderStyle = 1
                  
                  If Me(mstrSelected) = mintDayToday And iMonth = mintMonthToday And iYear = mintYearToday Then
                        .BackStyle = 1
                  Else
                        .BackStyle = 0
                  End If
                  
                  Day = .Caption
            End With
            
            With LbSolar
                  [B][COLOR=#0000cd].Caption = [/COLOR][COLOR=#ff0000]DayInWeek[/COLOR][COLOR=#0000cd](DateSerial(iYear, iMonth, Day))[/COLOR][/B]
                  .BackColor = Me(mstrSelected).BackColor
                  .ForeColor = Me(mstrSelected).ForeColor
            End With
            
            With LbLunar
                  .Caption = AmLich(DateSerial(iYear, iMonth, Day))
                  .BackColor = Me(mstrSelected).BackColor
                  .ForeColor = Me(Replace(mstrSelected, "lbl", "AL")).ForeColor
            End With
      Else
            LbSolar_Click
            GoTo HdleIdnt
      End If
End Sub

 

[ndu96081631]

Dạ, rất hay, vậy là ta có thể dùng hàm Evaluate để chuyển hàm Text trong Excel thay vì phải dùng đến WorksheetFunction. Có một điều em vẫn không thích kiểu định dạng này là vì đối với Excel 2003 trở về trước, thay vì là Chủ Nhật nó viết toàn bộ bằng chữ thường chủ nhật (phải thêm hàm PROPER vào nữa). Điều thứ hai em vẫn muốn nó xài rộng hơn cả Excel nên em không muốn lệ thuộc vào hàm của Excel.

Tùy chuyện, tùy theo mức độ ứng dụng
Bạn thử nghĩ cái calendar của bạn sẽ ứng dụng vào đâu ngoài Excel và ứng dụng như thế nào?

 

[Hoàng Trọng Nghĩa]

Tùy chuyện, tùy theo mức độ ứng dụng
Bạn thử nghĩ cái calendar của bạn sẽ ứng dụng vào đâu ngoài Excel và ứng dụng như thế nào?

Em cũng chẳng biết, nhưng em vẫn thường nghe Thầy khuyên là đã viết hàm cho VBA, nếu không thể, thì không nên lệ thuộc hoặc dùng hàm của Excel; vì xa hơn có thể dùng trong môi trường VBA khác.

Cho nên em mới nghĩ ra như thế thôi.

 

[ndu96081631]

Em cũng chẳng biết, nhưng em vẫn thường nghe Thầy khuyên là đã viết hàm cho VBA, nếu không thể, thì không nên lệ thuộc hoặc dùng hàm của Excel; vì xa hơn có thể dùng trong môi trường VBA khác.

Cho nên em mới nghĩ ra như thế thôi.

Ví dụ thế này:
- Bạn viết hàm Sort dữ liệu
- Bạn viết hàm đổi số thành chữ
vân vân... đương nhiên bạn phải nhìn xa hơn để có thể ứng dụng nó ngoài Excel
Còn cái Calendar này nếu muốn ứng dụng xa hơn nữa phải tạo nó thành 1 OCX ---> Ẹc... Ẹc... trình độ của mình chắc hổng chơi được (ít nhất là trình độ của tôi không dám chơi)
------------------
Bây giờ chỉ nói trong nội bộ của Excel thôi, Nghĩa là có thể cho tôi biết cái calendar của Nghĩa ứng dụng vào việc gì không? Hay chỉ để nhìn chơi thôi?
Ví dụ trường hợp tôi không cài được MSCAL.OCX, vậy tôi sẽ dùng cái calendar của Nghĩa như thế nào?

 

[ptm0412]

Có 1 nhận xét nho nhỏ:
Mấy cái nút tròn be bé xinh xinh kia (dùng để chọn tháng, năm) nhấn vào nó giựt màn hình cái đùng. Cho nên đẹp thì đẹp nhưng thua cái control scrollbar hoặc Spin Button.

 

[Hoàng Trọng Nghĩa]

Có 1 nhận xét nho nhỏ:
Mấy cái nút tròn be bé xinh xinh kia (dùng để chọn tháng, năm) nhấn vào nó giựt màn hình cái đùng. Cho nên đẹp thì đẹp nhưng thua cái control scrollbar hoặc Spin Button.

Có thể nó chạy trên nhiều Label quá để tính hơn 84 cái và duyệt màu, duyệt số nên nó cứ phải chớp, em thử dùng me.repaint nhưng nó còn chớp bạo hơn. Cái này bó tay.

 

[ptm0412]

Em cũng chẳng biết, nhưng em vẫn thường nghe Thầy khuyên là đã viết hàm cho VBA, nếu không thể, thì không nên lệ thuộc hoặc dùng hàm của Excel; vì xa hơn có thể dùng trong môi trường VBA khác.

Cho nên em mới nghĩ ra như thế thôi.

Tôi thử export Form và module ra và mở bằng VB6:
- Form không thể hiện hết các control
- form size chỉ bằng với 1 hàng control trên cùng

Do đó không test được các chức năng khác. Sau khi sửa 1 tí tẹo cho nó maximize để test thì được.

Thực tế mà nhận xét:
- Code quá phức tạp vì cố gắng dùng quá nhiều chức năng trong 1 form như: dấu form control, sử dụng quá nhiều event mouse move, keypress, keydown,
- Chỉ vì 1 chức năng click đóng form mà phải viết 56 sub giống nhau (Có thể dùng Class thay vào)

Quan điểm cá nhân tôi:

- Code càng đơn giản càng tốt
- Chỉ chọn và sử dụng chức năng cần thiết nhất

 

[Hoàng Trọng Nghĩa]

Ví dụ thế này:
- Bạn viết hàm Sort dữ liệu
- Bạn viết hàm đổi số thành chữ
vân vân... đương nhiên bạn phải nhìn xa hơn để có thể ứng dụng nó ngoài Excel
Còn cái Calendar này nếu muốn ứng dụng xa hơn nữa phải tạo nó thành 1 OCX ---> Ẹc... Ẹc... trình độ của mình chắc hổng chơi được (ít nhất là trình độ của tôi không dám chơi)
------------------
Bây giờ chỉ nói trong nội bộ của Excel thôi, Nghĩa là có thể cho tôi biết cái calendar của Nghĩa ứng dụng vào việc gì không? Hay chỉ để nhìn chơi thôi?
Ví dụ trường hợp tôi không cài được MSCAL.OCX, vậy tôi sẽ dùng cái calendar của Nghĩa như thế nào?

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:

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:

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

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:

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!

 

[Hoàng Trọng Nghĩa]

Tôi thử export Form và module ra và mở bằng VB6:
- Form không thể hiện hết các control
- form size chỉ bằng với 1 hàng control trên cùng

Do đó không test được các chức năng khác. Sau khi sửa 1 tí tẹo cho nó maximize để test thì được.

Thực tế mà nhận xét:
- Code quá phức tạp vì cố gắng dùng quá nhiều chức năng trong 1 form như: dấu form control, sử dụng quá nhiều event mouse move, keypress, keydown,
- Chỉ vì 1 chức năng click đóng form mà phải viết 56 sub giống nhau (Có thể dùng Class thay vào)

Quan điểm cá nhân tôi:

- Code càng đơn giản càng tốt
- Chỉ chọn và sử dụng chức năng cần thiết nhất

Thật sự em muốn biết cách viết ClassModule trong trường hợp này như thế nào. Trước nay thấy mọi người dùng, em thích lắm nhưng chưa biết cách vận hành như thế nào.

Sư phụ vui lòng hướng dẫn em trong trường hợp này không? Xin Cảm ơn rất nhiều.

 

[ptm0412]

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.

Không ai phủ nhận những cố gắng và những thành tựu của Nghĩa. Tôi chỉ đưa ra những ý kiến nhận xét riêng. Thêm nữa đây, (có thể đắng):

- Nếu để thay thế calendar có sẵn, thì tại sao không sử dụng cái có sẵn?
- Giao diện đẹp hơn, đúng, nhưng không thấy "thân thiện" hơn: Cũng click chọn ngày, click chọn tháng, click chọn năm, cũng thể hiện thứ, ngày tháng theo thứ tự cùng kiểu.
- Được cái xem ngày âm lịch, nhưng cũng chỉ để xem như nhiều lịch khác trên gpe.
- Code hiện tại có thể nói là đã rất phức tạp, không dễ "cá nhân hóa theo ý thích" đâu.

 

[ptm0412]

Class ít sử dụng nên quên mất tiêu rồi. Nhưng trường hợp này không khó, đọc sơ qua code "trúc xanh trên form" của Kyo là làm được, vì nó sử dụng class cho command button tương tự bài này.

 

[Hoàng Trọng Nghĩa]

Class ít sử dụng nên quên mất tiêu rồi. Nhưng trường hợp này không khó, đọc sơ qua code "trúc xanh trên form" của Kyo là làm được, vì nó sử dụng class cho command button tương tự bài này.

Vì mỗi cái thủ tục nó lại kèm theo 1 cái tên của label nên em không biết phải làm như thế nào nữa.

Ai rành về class xin vui lòng hướng dẫn sơ cho mình về trường hợp trên form lịch này được không ạ?

Trân trọng cám ơn.

 

[ndu96081631]

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:

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:

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

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:

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!

Bạn hãy làm 1 ứng dụng hoàn chỉnh trên Excel rồi post file lên đây tôi xem thử
Đừng nói là khi muốn xài phải "vác" nguyên rừng code kia vào file nha ---> Nếu có thể được, phải tạo nó thành 1 Add-In. Để làm chi? Để mọi người, những ai không rành code cũng xài được!

 

[levanduyet]

Hi em,
Em có thể tham khảo thêm tại đây.

Lê Văn Duyệt

 

[Hoàng Trọng Nghĩa]

Hi em,
Em có thể tham khảo thêm tại đây.

Lê Văn Duyệt

Cám ơn Anh, đúng là code nó đơn giản thiệt, nhưng em thấy nó có nhiều hạn chế:

1) Không cho ta chọn được vào bất cứ ngày nào, nếu ta bỏ chọn Me.Hide trong sự kiện của Image:

[GPECODE=vb]Private Sub Image1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
' updated 2012-05-12 by OPE
Dim d As Date
y = y + Me.Image1.Top
d = GetSelectedDate(x, y)
If d >= 0 Then ' 1.1.1900 or later
SelectedDate = d
UserCancelled = False
'Nếu bỏ chọn Me.Hide cái lịch trở nên "đóng băng"
'Me.Hide
End If
End Sub
[/GPECODE]

2) Không thể di chuyển để lựa chọn ngày bằng các phím mũi tên (lên, xuống, trái, phải)

3) Không có các chọn lựa cho phím tắt

...

Em sẽ kết hợp code với cái lịch này và cái lịch mà em đã cải tiến lại với nhau để đơn giản hóa việc sử dụng các sự kiện của các Label.

Cám ơn anh LeVanDuyet rất nhiều.

 

[levanduyet]

Cám ơn Anh, đúng là code nó đơn giản thiệt, nhưng em thấy nó có nhiều hạn chế:

Chỉ để em tham khảo thôi, rút trích ra cái nào hay mà dùng thôi. Anh đâu có nói nó là "hoàn hảo" đâu.

Lê Văn Duyệt

 

[siwtom]

Vì mỗi cái thủ tục nó lại kèm theo 1 cái tên của label nên em không biết phải làm như thế nào nữa.

Ai rành về class xin vui lòng hướng dẫn sơ cho mình về trường hợp trên form lịch này được không ạ?

Trân trọng cám ơn.

Tình cờ đọc được chủ đề cũ được nhắc lại.
Giới thiệu qua về class thì cũng được thôi nhưng phải xử lý sự kiện click và phải cung cấp một macro để thực hiện khi có click. Macro như thế tôi định gọi bằng Application.Run do vậy phải để nó trong Module. Hiện thời trong LabelClick bạn gọi 1 sub, nhưng macro trong Module không thể gọi sub trong UserForm nên phải chuyển sub kia vào Module. Sub kia lại gọi 1 loạt sub trong UserForm nên lại phải chuyển chúng vào Module. Rồi còn phải sửa nhiều chỗ trong các sub ấy, vd. những chỗ bạn dùng Me thì không thể để Me được.
Tóm lại với 1 rừng code thì sửa lại mệt lắm. Có khi viết lại thì nhanh hơn. Nó như đại tu căn nhà ấy, đập đi xây mới còn nhanh hơn.
Nếu bạn quan tâm thì tôi sẽ viết lại toàn bộ code, chỉ giữ giao diện gần giống như của bạn thôi - thiết kế các Label, 2 combo, 2 Label ở dòng cuối, chuyển 4 Button ở dòng đầu thành Label.
Viết qua thôi để bạn tham khảo.

 

[Hoàng Trọng Nghĩa]

Tình cờ đọc được chủ đề cũ được nhắc lại.
Giới thiệu qua về class thì cũng được thôi nhưng phải xử lý sự kiện click và phải cung cấp một macro để thực hiện khi có click. Macro như thế tôi định gọi bằng Application.Run do vậy phải để nó trong Module. Hiện thời trong LabelClick bạn gọi 1 sub, nhưng macro trong Module không thể gọi sub trong UserForm nên phải chuyển sub kia vào Module. Sub kia lại gọi 1 loạt sub trong UserForm nên lại phải chuyển chúng vào Module. Rồi còn phải sửa nhiều chỗ trong các sub ấy, vd. những chỗ bạn dùng Me thì không thể để Me được.
Tóm lại với 1 rừng code thì sửa lại mệt lắm. Có khi viết lại thì nhanh hơn. Nó như đại tu căn nhà ấy, đập đi xây mới còn nhanh hơn.
Nếu bạn quan tâm thì tôi sẽ viết lại toàn bộ code, chỉ giữ giao diện gần giống như của bạn thôi - thiết kế các Label, 2 combo, 2 Label ở dòng cuối, chuyển 4 Button ở dòng đầu thành Label.
Viết qua thôi để bạn tham khảo.

Dạ, em rất ham muốn được học hỏi, xin thầy viết lại mới toàn bộ đi ạ. Em và những ai muốn học sẽ rất biết ơn Thầy!

 

[siwtom]

Dạ, em rất ham muốn được học hỏi, xin thầy viết lại mới toàn bộ đi ạ. Em và những ai muốn học sẽ rất biết ơn Thầy!

Vài lời về code của bạn:
1. Những chuỗi dùng trong control và Tip bạn nên dùng ChrW "trọn gói" hoặc không dùng "trọn gói" đừng làm nửa vời - một chuỗi có phần để nguyên có phần dùng ChrW. Tôi đính kèm hình cho bạn nhìn CanChi và Tip của bạn được hiển thị như thế nào

View attachment 94669

2. Trong code có chỗ thừa thì phải. Vd. bạn có UserForm_KeyDown. Bạn hãy chỉ ra cho tôi khi nào sẩy ra sự kiện UserForm_KeyDown? Hay tôi chưa xét kỹ? Vì thú thực là nhìn vào rừng code tôi không muốn theo dõi chi tiết.
---------------
Tôi đã cố viết thật hoàn chỉnh và tôi nghĩ có lẽ đã hoàn chỉnh. Tuy nhiên tôi viết mà không có thời gian nhiều để test nên rất có thể có những vấn đề tôi quên chưa làm.
0. Về giao diện thì giống của bạn tới 99,99%
1. Để làm mất focus cho 2 ComboBox (trông rất xấu) thì phải có chỗ chuyển focus đi. Tôi tạo Textbox dấu kín dùng cho mục đích chuyển focus về Textbox. Do chuyển focus về Textbox nên việc xử lý các phím nhấn được thực hiện trong Texbox1_KeyDown.
2. Về các phím thì toàn bộ code của tôi có chú thích đầy đủ nên bạn tự đọc. Ở đây tôi chỉ giải thích thêm.
a. Khi 2 Combobox không có focus (không hiện nút mở danh sách thả) và Shift, Ctrl không được nhấn thì các phím mũi tên dùng để đi sang ngày trước, sau, ở tuần trưỡc, sau.
3. Khi chỉ Shift được nhấn thì: múi tên down, mũi tên trái, phải dùng để mở ComboBox chọn tháng, chọn tháng trước, chọn tháng sau.
4. Khi chỉ Ctrl được nhấn thì: mũi tên down, mũi tên trái, phải dùng để mở ComboBox chọn năm, chọn năm trước, chọn năm sau.
5. Khi Combobox đang mở danh sách thì dùng mũi tên lên xuống. Ta có thể nhấn Enter để đóng danh sách thả và làm mất focus. Nếu ta đóng danh sách thả bằng cách click nút tam giác thì nếu muốn mất focus (vd. để dùng các phím mũi tên di chuyển sang các ngày khác) thì phải nhấn TAB cho tới khi 2 ComboBox mất focus, tức focus được chuyển về Textbox.
6. Khi Textbox có focus thì TAB không tác dụng để không thể chuyển focus sang Combobox. Muốn chuyển focus sang ComboBox và mở danh sách thả thì phải Shift / Ctrl + mũi tên Down. Chuyển focus bằng phím thì hơi rắc rối (vd. chuyển từ control đầu tới control cuối khi có nhiều control) chứ bằng chuột thì nhanh và đơn giản. Muốn focus ở đâu thì click ở đó.
7. Thậm chí cả khi ComboBox có focus và danh sách đang đóng (do click nút của ComboBox) thì user vẫn có thể dùng mũi tên Down, Up để di chuyển sang tháng, năm khác và Enter để chọn và làm mất focus trên ComboBox.
8. User không cần biết code như thế nào. Nếu muốn mở Lịch để chọn ngày tháng thì gọi hàm GetDate. Nếu sau đó user hủy ý định bằng cách nhấn ESC thì hàm trả về chuỗi rỗng. Nếu user nhấn Enter để chọn ngày đang được đánh dấu thì hàm trả về ngày đó.
9. Module modLichAm tôi lấy của bạn nhưng sửa hàm NgayAL và thêm hàm CanChi để phù hợp với nhu cầu code của tôi.
10. Code có ghi chú chi tiết. Có Button Test dùng để test.
11. À còn một vấn đề nữa. Tôi có một mảng 90 đối tượng của class clsLabel. Nhưng chỉ có 84 Label được tạo trong RunTime do 2 lý do. Thứ nhất tôi không đủ kiên nhẫn thả 84 Label xuống Form rồi căn, chỉnh, thiết lập các thuộc tính. Cái nữa là tôi chỉ tạo 84 Label trong RunTime còn 6 Label được tạo trong DesignTime để có cớ chỉ ra 2 cách thiết lập ctrl và macro.

code UserForm1:
[GPECODE=vb]
Private Sub cbMonth_Enter()
cbMonth.DropDown
End Sub

Private Sub cbMonth_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
' nếu user kết thúc lựa chọn bằng Enter thì làm mới Lịch và chuyển focus về TextBox1
If KeyCode = vbKeyReturn Then
Month = cbMonth.ListIndex + 1
FixDay
ShowCalendar
TextBox1.SetFocus
End If
End Sub

Private Sub cbYear_Enter()
cbYear.DropDown
End Sub

Private Sub cbYear_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
' nếu user kết thúc lựa chọn bằng Enter thì làm mới Lịch và chuyển focus về TextBox1
If KeyCode = vbKeyReturn Then
Year = cbYear.ListIndex + 1900
FixDay
ShowCalendar
TextBox1.SetFocus
End If
End Sub

Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
' nếu là TAB được nhấn thì không cho thoát khỏi TextBox1
If TextBox1.Tag Then
TextBox1.Tag = 0
Cancel = True
End If
End Sub

Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
' thiết lập flag rằng TAB được nhấn
If KeyCode = vbKeyTab Then
TextBox1.Tag = 1
Else
' xử lý các phím nhấn
HandleKeys KeyCode, Shift
End If
End Sub

Private Sub HandleKeys(ByVal KeyCode As Integer, ByVal Shift As Integer)
Select Case Shift
Case 0: ' Shift, Ctrl, Alt không được nhấn
Select Case KeyCode
' ngày chọn lùi dần - chỉ tới ngày đầu tháng
Case vbKeyLeft: If lastLabelIndex > StartDayOfWeek + 42 Then DoLabelClick Labels(lastLabelIndex - 1).Label
' ngày chọn tiến dần - chỉ tới ngày cuối tháng
Case vbKeyRight: If lastLabelIndex < StartDayOfWeek + TotalDays + 41 Then DoLabelClick Labels(lastLabelIndex + 1).Label
' ngày chọn là cùng thứ nhưng ở tuần trước
Case vbKeyUp: If lastLabelIndex > StartDayOfWeek + 48 Then DoLabelClick Labels(lastLabelIndex - 7).Label
' ngày chọn là cùng thứ nhưng ở tuần sau
Case vbKeyDown: If lastLabelIndex < StartDayOfWeek + TotalDays + 35 Then DoLabelClick Labels(lastLabelIndex + 7).Label
' nếu ESC thì trả về chuỗi rỗng, nêu Enter thì ngày chọn là DateSerial(Year, Month, Day)
' đóng Form
Case vbKeyEscape, vbKeyReturn:
If KeyCode = vbKeyEscape Then Day = 0
Unload Me
End Select
Case 1: ' chỉ có Shift nhấn
If KeyCode = vbKeyLeft Then
' chọn tháng trước
DoLabelClick Labels(87).Label
ElseIf KeyCode = vbKeyRight Then
' chọn tháng sau
DoLabelClick Labels(88).Label
ElseIf KeyCode = vbKeyDown Then
' mở danh sách thả chọn tháng
cbMonth.SetFocus
End If
Case 2: ' chỉ có Ctrl nhấn
If KeyCode = vbKeyLeft Then
' chọn năm trước - chỉ tới 1900
DoLabelClick Labels(89).Label
ElseIf KeyCode = vbKeyRight Then
' chọn năm sau - chỉ tới 2199
DoLabelClick Labels(90).Label
ElseIf KeyCode = vbKeyDown Then
' mở danh sách thả chọn năm
cbYear.SetFocus
End If
End Select
End Sub

Private Sub InitCalendar()
Dim index As Long, k As Long, t As Double, t1 As Double
On Error GoTo end_
' mảng 90 Label
ReDim Labels(1 To 90)
' tạo 84 Label và cung cấp macro cho Click - 42 Label với Caption là ngày dương, 42 Label với Caption là ngày âm
For index = 1 To 84
k = index
If k > 42 Then k = k - 42
Labels(index).Create Me, index, "DoLabelClick", 1 + ((k - 1) Mod 7) * 40, 37 + ((k - 1) \ 7) * 30, 40, 30
Next
' 6 Label cho vào mảng đã được tạo trong DesignTime
Set Labels(85).Label = lbDuong
Set Labels(86).Label = lbAm
Set Labels(87).Label = lbMonthLeft
Set Labels(88).Label = lbMonthRight
Set Labels(89).Label = lbYearLeft
Set Labels(90).Label = lbYearRight
' cung cấp macro cho Click cho các Label <, >
For index = 87 To 90
Labels(index).Label.Tag = index
Labels(index).Macro = "DoLabelClick"
Next
' tiêu đề các này trong tuần
Label1.Caption = "CN"
Label2.Caption = "Hai"
Label3.Caption = "Ba"
Label4.Caption = "T" & ChrW(432)
Label5.Caption = "N" & ChrW(259) & "m"
Label6.Caption = "S" & ChrW(225) & "u"
Label7.Caption = "B" & ChrW(7849) & "y"
' các lời nhắc, mách nước cho các Label <, > và 2 ComboBox chọn Tháng và Năm
lbMonthLeft.ControlTipText = "Ch" & ChrW(7885) & "n th" & ChrW(225) & "ng tr" & ChrW(432) & ChrW(7899) & "c"
lbMonthRight.ControlTipText = "Ch" & ChrW(7885) & "n th" & ChrW(225) & "ng sau"
lbYearLeft.ControlTipText = "Ch" & ChrW(7885) & "n n" & ChrW(259) & "m tr" & ChrW(432) & ChrW(7899) & "c"
lbYearRight.ControlTipText = "Ch" & ChrW(7885) & "n n" & ChrW(259) & "m sau"
cbMonth.ControlTipText = "Ch" & ChrW(7885) & "n th" & ChrW(225) & "ng"
cbYear.ControlTipText = "Ch" & ChrW(7885) & "n n" & ChrW(259) & "m"
' nhập tháng vào ComboBox chọn Tháng
For index = 1 To 12
cbMonth.AddItem "Th" & ChrW(225) & "ng " & Format(index, "00")
Next
' nhập năm vào ComboBox chọn Năm
For index = 1900 To 2199
cbYear.AddItem "N" & ChrW(259) & "m " & index
Next
' số ngày các tháng bình thường (không nhuận) trong năm
MonthLen = Array(0, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
' tên các ngày trong tuần
TenNgay = Array("Ch" & ChrW(7911) & " Nh" & ChrW(7853) & "t", "Th" & ChrW(7913) & " Hai", "Th" & ChrW(7913) & " Ba", "Th" & ChrW(7913) & " T" & ChrW(432), _
"Th" & ChrW(7913) & " N" & ChrW(259) & "m", "Th" & ChrW(7913) & " S" & ChrW(225) & "u", "Th" & ChrW(7913) & " B" & ChrW(7849) & "y")
' ngày hiện tại
YearToday = DatePart("yyyy", Date)
MonthToday = DatePart("m", Date)
DayToday = DatePart("d", Date)
todayLabelIndex = FirstDayOfMonth(MonthToday, YearToday) + DayToday - 1
' ngày đang được chọn
If Not IsDate(SelectDate) Then SelectDate = Date
Year = DatePart("yyyy", SelectDate)
Month = DatePart("m", SelectDate)
Day = DatePart("d", SelectDate)
' nhập vào ComboBox chọn Tháng và Năm ngày đang được chọn - ngày hiện tại ở lần mở đầu tiên
' hoặc ngày được chọn ở lần mở trước
cbMonth.Value = "Th" & ChrW(225) & "ng " & Format(Month, "00")
cbYear.Value = "N" & ChrW(259) & "m " & Year
end_:
End Sub

Private Sub HideTitlebar(ByVal hForm As Long)
Dim Style As Long, TitleHeight As Single
Style = GetWindowLong(hForm, GWL_STYLE)
TitleHeight = Me.height - Me.InsideHeight
Style = (Style And Not WS_CAPTION)
SetWindowLong hForm, GWL_STYLE, Style
Me.height = Me.height - TitleHeigh
DrawMenuBar hForm
End Sub

Private Sub UserForm_Initialize()
Dim hForm As Long
On Error GoTo end_
' tìm handle của cửa sổ UserForm - cửa sổ Lịch
hForm = FindWindow("ThunderDFrame", Me.Caption)
' bỏ thanh tiêu đề
HideTitlebar hForm
' khởi tạo các control và thiết lâp
InitCalendar
' hiển thị Lịch
ShowCalendar
end_:
End Sub

Private Sub UserForm_Terminate()
' hủy các Label được tạo
Erase Labels
End Sub
[/GPECODE]

 

[siwtom]

Tiếp bài trước. Do dài quá nên phải chia làm 2 phần.

code module modCalendar:
[GPECODE=vb]
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long

Public Const WS_CAPTION = &HC00000
Public Const GWL_STYLE = (-16)

Public Labels() As New clsLabel
Public Year As Long, Month As Long, Day As Long, YearToday As Long, MonthToday As Long, DayToday As Long
Public MonthLen As Variant, TenNgay As Variant
Public SelectDate As Variant, Today As Variant, lastLabelIndex As Long, todayLabelIndex As Long
Public StartDayOfWeek As Integer, TotalDays As Integer

' hàm trả về ngày tháng năm được chọn hoặc chuỗi rỗng nếu user nhấn ESC để hủy chọn
Function GetDate()
UserForm1.Show
' nếu user hủy chon bằng cách nhấn ESC thì Day = 0
If Day Then
' ngày tháng năm được chọn
SelectDate = DateSerial(Year, Month, Day)
GetDate = SelectDate
Else
GetDate = vbNullString
End If
End Function

' hàm trả về số thứ tự trong tuần (chủ Nhật là ngày đầu tiên) của ngày mồng 1 của tháng
Function FirstDayOfMonth(ByVal m As Integer, ByVal y As Integer) As Integer
FirstDayOfMonth = DatePart("w", DateSerial(y, m, 1), vbSunday)
End Function

Public Sub ShowCalendar()
Dim index As Long, currLabelIndex As Long

StartDayOfWeek = FirstDayOfMonth(Month, Year)
' số thứ tự của Label hiện hành tưng ứng với ngày đang được chọn
currLabelIndex = StartDayOfWeek + Day + 41
' số ngày trong tháng đang được chọn
If Month <> 2 Then
TotalDays = MonthLen(Month)
Else
TotalDays = DatePart("d", DateSerial(Year, 3, 1) - 1)
End If
' ẩn những Label không cần thiết và hiện những Label cần thiết trong tuần đầu tiên
For index = 1 To 7
If index < StartDayOfWeek Then
Labels(index).Label.Visible = False
Labels(index + 42).Label.Visible = False
Else
Labels(index).Label.Visible = True
Labels(index + 42).Label.Visible = True
End If
Next
' ẩn những Label không cần thiết và hiện những Label cần thiết trong các dòng cuối
For index = 29 To 42
If index < StartDayOfWeek + TotalDays Then
Labels(index).Label.Visible = True
Labels(index + 42).Label.Visible = True
Else
Labels(index).Label.Visible = False
Labels(index + 42).Label.Visible = False
End If
Next
' "in" ngày dương và âm trên các Label
For index = 1 To TotalDays
Labels(index + StartDayOfWeek - 1).Label.Caption = index
Labels(index + StartDayOfWeek + 41).Label.Caption = NgayAL(index, Month, Year)
Next

UpdateSelectedDate currLabelIndex
End Sub

Private Sub UpdateSelectedDate(ByVal currLabelIndex As Long)
Dim form As Object
' ngày đang được chọn
Day = Labels(currLabelIndex - 42).Label.Caption
' nếu có ngày trước đó được chọn tức Label có khung viền thì bỏ khung viền và mầu
If lastLabelIndex Then
Labels(lastLabelIndex).Label.BorderColor = &H80000004
Labels(lastLabelIndex - 42).Label.BackStyle = fmBackStyleTransparent
End If
lastLabelIndex = currLabelIndex
' hiện khung viền và mầu nền cho ngày hiện được chọn
Labels(lastLabelIndex).Label.BorderColor = &H0
Labels(lastLabelIndex - 42).Label.BackStyle = fmBackStyleOpaque
' thông tin về ngày dương và ngày âm - dòng cuối
Labels(85).Label.Caption = TenNgay((currLabelIndex - 1) Mod 7) & " " & DateSerial(Year, Month, Day)
Labels(86).Label.Caption = Replace(Labels(currLabelIndex).Label.Caption, vbCrLf, " ") & " " & Canchi(Day, Month, Year)
' nếu lịch của tháng và năm hiên hành thì tômầu nền của ngày hiện hành - today
If Month = MonthToday And Year = YearToday Then
Labels(todayLabelIndex).Label.BackStyle = fmBackStyleOpaque
Labels(todayLabelIndex).Label.BackColor = &HFF
Labels(todayLabelIndex).Label.ForeColor = &HFFFFFF
Labels(todayLabelIndex + 42).Label.ForeColor = &HFFFFFF
Else
' ngược lại thì bỏ mầu
Labels(todayLabelIndex).Label.BackStyle = fmBackStyleTransparent
Labels(todayLabelIndex).Label.BackColor = &HC0FFFF
Labels(todayLabelIndex).Label.ForeColor = &H0
Labels(todayLabelIndex + 42).Label.ForeColor = &H0
End If
End Sub

' macro thực thi khi click Label
Sub DoLabelClick(ctrl As MSForms.Label)
If ctrl.Tag < 85 Then
' chỉ các Label ứng với các ngày trong tháng
UpdateSelectedDate ctrl.Tag
Else
' các Label chuyển tháng hoặc năm - các Label <, >
Select Case ctrl.Tag
' tăng 1 hoặc giảm 1 giá trị của tháng hoặc năm
Case 87: If Month > 1 Or Year > 1900 Then Month = Month - 1
Case 88: If Month < 12 Or Year < 2199 Then Month = Month + 1
Case 89: If Year > 1900 Then Year = Year - 1
Case 90: If Year < 2199 Then Year = Year + 1
End Select
' sửa lại tháng
If Month < 1 Then
Month = 12
Year = Year - 1
ElseIf Month > 12 Then
Month = 1
Year = Year + 1
End If

FixDay
' thay đổi giá trị của ComboBox chọn tháng và năm
ctrl.Parent.cbMonth.ListIndex = Month - 1
ctrl.Parent.cbYear.ListIndex = Year - 1900
' hiển thị Lịch
ShowCalendar
End If
End Sub

Sub FixDay()
' nếu chỉ số ngày hiện hành > số ngày trong tháng thì giảm chỉ số ngày hiện hành
Do While MonthLen(Month) < Day
Day = Day - 1
Loop
End Sub
[/CODE]

code clsLabel:

Private WithEvents ctrl As MSForms.Label
Private strMacro As String, DoFree As Boolean

Private Sub Class_Terminate()
    If DoFree And Not ctrl Is Nothing Then
        Set ctrl = Nothing
    End If
End Sub

Property Get Label() As MSForms.Label
    Set Label = ctrl
End Property

Property Set Label(ctl As MSForms.Label)
    Set ctrl = ctl
End Property

Property Let Macro(ByVal cmd As String)
    strMacro = cmd
End Property

Public Sub Create(form As MSForms.UserForm, ByVal index As Long, ByVal Macro As String, _
    ByVal left As Integer, ByVal top As Integer, ByVal width As Integer, ByVal height As Integer)
On Error Resume Next
    Set ctrl = form.Controls.Add("Forms.Label.1")
    If Not ctrl Is Nothing Then
        strMacro = Macro
        DoFree = True
        With ctrl
            .BorderColor = &H80000004
            .BorderStyle = fmBorderStyleSingle
            .BackColor = &HC0FFFF
            .BackStyle = fmBackStyleTransparent
            If (index - 1) Mod 7 = 0 Then .ForeColor = &HFF
            .Font.Name = "Times New Roman"
            .Font.Size = 10
            If index > 42 Then .TextAlign = fmTextAlignRight
            .Tag = index
            If left > 0 Then .left = left
            If top > 0 Then .top = top
            If width > 0 Then .width = width
            If height > 0 Then .height = height
        End With
    End If
End Sub

Private Sub ctrl_Click()
    On Error Resume Next
    If strMacro <> vbNullString Then Application.Run strMacro, ctrl
End Sub
[/GPECODE]

 

[ptm0412]

Hôm trước mình có gợi ý Nghĩa sử dụng class cho các label, nhưng khi thử làm thì không được.
Hôm nay thấy siwtom làm class, mừng quá lấy về xem, thì thấy còn lâu mình mới tự làm được như vậy. Hic, còn phải học nhiều!

 

[siwtom]

Hôm trước mình có gợi ý Nghĩa sử dụng class cho các label, nhưng khi thử làm thì không được.
Hôm nay thấy siwtom làm class, mừng quá lấy về xem, thì thấy còn lâu mình mới tự làm được như vậy. Hic, còn phải học nhiều!

Cái này nó là một phần kiến thức trong lập trình dù bạn lập trình trong ngôn ngữ nào.
Do bạn chưa có nhu cầu nên bạn chưa làm hoặc ít làm. Chứ nếu phải làm thì bạn phải học, tức phải đọc, phải tự viết, tự thử nghiệm thì đương nhiên bạn sẽ biết làm. Sau đó có chuyển sang ngôn ngữ khác thì bạn cũng nhanh chóng biết làm vì cái cơ bản bạn đã hiểu, đã biết. Cú pháp có thể khác trong mỗi ngôn ngữ nhưng "cơ cấu cơ bản", lôgíc, triết lý là như nhau.

 

[thanhlanh]

---------------
Tôi đã cố viết thật hoàn chỉnh và tôi nghĩ có lẽ đã hoàn chỉnh. Tuy nhiên tôi viết mà không có thời gian nhiều để test nên rất có thể có những vấn đề tôi quên chưa làm.
[/GPECODE]

Tôi muốn khi chọn (hoặc gõ) tháng và năm trên các Combobox thì lịch nhảy theo, hình như anh quên?

--------
To Nghĩa: Cần phải bố trí thêm một nút để quay trở về ngày hiện tại

 

[Hoàng Trọng Nghĩa]

Tôi muốn khi chọn (hoặc gõ) tháng và năm trên các Combobox thì lịch nhảy theo, hình như anh quên?

--------
To Nghĩa: Cần phải bố trí thêm một nút để quay trở về ngày hiện tại

Tại 2 label cuối của form hiển thị lịch Dương và Âm, anh rê ngang chuột sẽ thấy có dòng Tip, dĩ nhiên anh click vào 2 label này nó trở về ngày hiện hành.

Anh nên tải tại bài này, nó đầy đủ hơn (file đã update):

http://www.giaiphapexcel.com/forum/...n-ích-CALENDAR-tuyệt-đẹp!&p=451406#post451406

 

[Hoàng Trọng Nghĩa]

Cái này nó là một phần kiến thức trong lập trình dù bạn lập trình trong ngôn ngữ nào.
Do bạn chưa có nhu cầu nên bạn chưa làm hoặc ít làm. Chứ nếu phải làm thì bạn phải học, tức phải đọc, phải tự viết, tự thử nghiệm thì đương nhiên bạn sẽ biết làm. Sau đó có chuyển sang ngôn ngữ khác thì bạn cũng nhanh chóng biết làm vì cái cơ bản bạn đã hiểu, đã biết. Cú pháp có thể khác trong mỗi ngôn ngữ nhưng "cơ cấu cơ bản", lôgíc, triết lý là như nhau.

Bài này Thầy gửi lên rất quan trọng đối với em và mọi người để được học thuật và cải thiện kiến thức của mình. Em rất cám ơn sự nhiệt huyết của Thầy.

Tuy nhiên cho em nói về file của Thầy một chút, có một số cần phải nói vì Thầy cũng cần có người test những sản phẩm của mình.

1) Các combobox tháng, năm không hoạt động khi chúng thay đổi do người dùng chọn.

2) Khi bấm phím phải hoặc trái, tại ngày đầu tháng hoặc cuối tháng nó không thể di chuyển sang tháng sau hoặc tháng trước. Và cũng vậy với phím lên xuống, khi ô hiện hành sát ở đỉnh hoặc đáy thì bấm thêm nó không chuyển qua tháng trước hoặc tháng sau.

3) Nên chăng thêm thuộc tính kéo thả form cho các Label thứ trong tuần.

4) Để trở về ngày hiện hành, em vẫn chưa biết vận dụng như thế nào.

5) Không biết có ý đồ gì không, nhưng hình như qua tháng khác thì ngày 28 lại không đổi màu.

Đó là một số vấn đề em test được, xin được Thầy cải tiến thêm.

 

[siwtom]

Tôi muốn khi chọn (hoặc gõ) tháng và năm trên các Combobox thì lịch nhảy theo, hình như anh quên?

Đúng là mải mê chuột với bàn phím nên quên về chuyện user có thể tự gõ chứ không chọn bằng chuột hay bàn phím. Vd. nếu muốn chọn Năm 2155 thì phải cuộn danh sách lâu nên nhanh nhất là tự gõ.
Nhưng không phải là hiện giờ user không gõ được. Gõ được bình thường. Chỉ có điều tôi quên vụ user tự gõ nên không chuẩn bị thuốc cho bệnh "gõ nhầm", cố tình "gõ nhầm" (vd. gõ hichic). Code phải "trơ" với những tình huống như thế.
------------
Tôi thay

Private Sub cbMonth_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = vbKeyReturn Then
        Month = cbMonth.ListIndex + 1
        FixDay
        ShowCalendar
        TextBox1.SetFocus
    End If
End Sub

Private Sub cbYear_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    If KeyCode = vbKeyReturn Then
        Year = cbYear.ListIndex + 1900
        FixDay
        ShowCalendar
        TextBox1.SetFocus
    End If
End Sub

bằng

Private Sub cbMonth_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'    nếu user kết thúc lựa chọn bằng Enter thì làm mới Lịch và chuyển focus về TextBox1
    If KeyCode = vbKeyReturn Then
        If cbMonth.ListIndex > -1 Then
            Month = cbMonth.ListIndex + 1
            FixDay
            ShowCalendar
        Else
            cbMonth.Value = "Th" & ChrW(225) & "ng " & Format(Month, "00")
        End If
        TextBox1.SetFocus
    End If
End Sub

Private Sub cbYear_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
'    nếu user kết thúc lựa chọn bằng Enter thì làm mới Lịch và chuyển focus về TextBox1
    If KeyCode = vbKeyReturn Then
        If cbYear.ListIndex > -1 Then
            Year = cbYear.ListIndex + 1900
            FixDay
            ShowCalendar
        Else
            cbYear.Value = "N" & ChrW(259) & "m " & Year
        End If
        TextBox1.SetFocus
    End If
End Sub

Nên chú ý là không có chuyện "Tôi muốn khi chọn (hoặc gõ) tháng và năm trên các Combobox thì lịch nhảy theo". Vì nếu nói về chọn bằng chuột thì có thể chọn nhầm, ta cho user cơ hội chọn lại. Còn về gõ thì biết lúc nào user gõ xong? Vậy chọn hay gõ xong thì phải Enter. Tôi đã viết rõ rồi - điểm 7 của hướng dẫn

Còn nếu ý bạn là "chọn - gõ" có nghĩa là chọn hoặc gõ xong thì Enter thì hiện thời vẫn làm được đó thôi. Cái tôi quên là chưa "chuẩn bị thuốc" cho bệnh nhập sai.


Các bạn xem lại hộ. Tập tin đính kèm cũng đã sửa lại.

 

[siwtom]

Bài này Thầy gửi lên rất quan trọng đối với em và mọi người để được học thuật và cải thiện kiến thức của mình. Em rất cám ơn sự nhiệt huyết của Thầy.

Tuy nhiên cho em nói về file của Thầy một chút, có một số cần phải nói vì Thầy cũng cần có người test những sản phẩm của mình.

1) Các combobox tháng, năm không hoạt động khi chúng thay đổi do người dùng chọn.

Bạn không đọc kỹ bài của tôi rồi

7. Thậm chí cả khi ComboBox có focus và danh sách đang đóng (do click nút của ComboBox) thì user vẫn có thể dùng mũi tên Down, Up để di chuyển sang tháng, năm khác và Enter để chọn và làm mất focus trên ComboBox.

Tức là khi gõ hoặc chọn xong thì chả có gì thay đổi cả. Phải nhấn Enter để kết thúc, lúc đó mới có thay đổi.
Tôi đã viết ở bài cho thanhlanh: user có thể chọn sai, tôi cho user cơ hội chọn lại. Khi kiểm tra thấy đúng ý mình thì ENTER để thay đổi.
Chuyện này là dụng ý của tôi thế và tôi đã viết hướng dẫn.

2) Khi bấm phím phải hoặc trái, tại ngày đầu tháng hoặc cuối tháng nó không thể di chuyển sang tháng sau hoặc tháng trước. Và cũng vậy với phím lên xuống, khi ô hiện hành sát ở đỉnh hoặc đáy thì bấm thêm nó không chuyển qua tháng trước hoặc tháng sau.

Đây cũng là tôi cố tình cho thế

' ngày chọn lùi dần - chỉ tới ngày đầu tháng
Case vbKeyLeft: If lastLabelIndex > StartDayOfWeek + 42 Then DoLabelClick Labels(lastLabelIndex - 1).Label
' ngày chọn tiến dần - chỉ tới ngày cuối tháng
Case vbKeyRight: If lastLabelIndex < StartDayOfWeek + TotalDays + 41 Then DoLabelClick Labels(lastLabelIndex + 1).Label

Cái chữ đỏ là tôi muốn nói chỉ cho phép như thế. 2 cái IF chính là để đảm bảo "chỉ cho phép như thế". Tôi cố tình như thế vì tôi cho rằng nếu vd. user đang đứng ở ngày 25 thì để chuyển sang ngày cuối tháng trước hay ngày đầu tháng sau thì chọn luôn tháng trước hay tháng sau nhanh hơn.

Nói chung mỗi người có một quan niệm. Tôi không muốn làm y như bạn và thực tình cũng không đọc hết các bài dài để biết bạn muốn có những chi tiết gì. Tôi viết chỉ để bạn tham khảo chứ không phải viết theo đơn đặt hàng của bạn. Vì viết theo đơn đặt hàng thì phải có tất cả mọi chức năng mà người đặt hàng yêu cầu, dù cho những yêu cầu đó như thế nào chăng nữa, thậm chí phi lý. Vì "người chi tiền" là thượng đế mà. Không đúng thế thì "không thanh toán".

3) Nên chăng thêm thuộc tính kéo thả form cho các Label thứ trong tuần.

Bạn có thể miêu tả "thuộc tính kéo thả form cho các Label thứ trong tuần" mặt mũi nó thế nào không?
Tôi không đọc hết các bài bạn giới thiệu Lịch của mình nên tôi không biết nó có những chức năng gì thêm

4) Để trở về ngày hiện hành, em vẫn chưa biết vận dụng như thế nào.

À, cái này thì tôi chưa có. Bạn cần thế à? Nếu cần thì để tôi thêm

5) Không biết có ý đồ gì không, nhưng hình như qua tháng khác thì ngày 28 lại không đổi màu.

Đó là một số vấn đề em test được, xin được Thầy cải tiến thêm.

Bạn miêu tả rõ một chút tôi sẽ xem xét lại.

 

[ptm0412]

Theo tôi nghĩ thì đúng như siwtom nói: Bài viết topic này cũng như tất cả các topic khác của gpe, của siwtom cũng như của người khác, là đưa ra giải thuật để người đọc chọn lọc, nếu hay thì học hỏi. Chứ không phải viết theo đơn đặt hàng, cũng như không phải viết để cho giống cái có sẵn 100%.

Người dùng có muôn ngàn nhu cầu khác nhau, và cách dùng khác nhau. Để chọn 1 mục trong combobox, có người dùng bàn phím gõ, người dùng phím mũi tên, người thì dùng chuột.

Người thì muốn có kết quả ngay dù đúng hay sai, người thì muốn sửa sang cho đúng ý rồi mới enter. Làm sao mà chiều cho hết được?

Nói thật, trong topic này tôi chỉ muốn học cái class của siwtom. Còn những code khác như mouse move, key up, key down (của Nghĩa), tôi không quan tâm. Như tôi đã nói trong bài trên, Nghĩa dồn tất cả cái biết, cái đã học, cái đã nghiên cứu, ... vào trong 1 dự án, mà về chức năng thì Excel có sẵn. Sau đó, lại muốn người khác làm cho giống hệt cái của mình. Dẫu để học chăng nữa (cũng đáng để học), nhưng vẫn là để nhồi nhét những cái tốt hơn vào dự án ban đầu, mà dự án đó, thay xong, vẫn chỉ bằng hoặc kém hơn cái có sẵn của excel.

Tát nhiên có cái hơn là có âm lịch, nhưng nếu chỉ để xem âm lịch thì có bao nhiêu loại lịch trên gpe để xem mà lại đơn giản hơn nhiều.

Nếu bây giờ bàn rằng tạo thêm tiện ích sao cho khi chọn ngày xong có thể set ngày chọn âm lịch xuống sheet hoặc xuống form khác, chắc chắn cũng sẽ làm được. Nhưng nghĩa là cái dự án cứ thế phình to ra, trong khi công dụng thực sự chả mấy tí.

 

[ptm0412]

Thí dụ với yêu cầu này:

3) Nên chăng thêm thuộc tính kéo thả form cho các Label thứ trong tuần.

Theo tôi hiểu thì Nghĩa muốn kéo thả label chẳng hạn như Sunday từ cuối lên đầu và ngược lại, để cho tuần bắt đầu từ chủ nhật thay vì thứ hai.

Yêu cầu này tôi cho rằng có thể làm được. Có nghĩa là thêm ít nhất 1 trang A4 code nữa. Nhưng để làm gì? Để phục vụ người dùng chăng? Rồi nếu có người muốn tuần bắt đầu từ thứ 4 cơ, hoặc mở rộng ra thì muốn tuần bắt đầu từ thứ mấy cũng được, thì sẽ vứt 1 trang A4 vừa rồi, làm lại 1 trang rưỡi A4 khác.

Cứ thế, và cứ thế, cuối cùng thì sau khi tạo thành add-in cho người dùng, nội việc load nó vào excel cũng đủ mệt mỏi, mà không phải lúc nào cũng dùng tới.
Hoặc gắn nó vào mỗi file chuyên dùng, thì lại quá dư. Mỗi file chắc chắn chỉ dùng 1 vài chức năng trong số hàng mấy chục chức năng đã khổ công viết.

 

[Hoàng Trọng Nghĩa]

Bạn không đọc kỹ bài của tôi rồi

7. Thậm chí cả khi ComboBox có focus và danh sách đang đóng (do click nút của ComboBox) thì user vẫn có thể dùng mũi tên Down, Up để di chuyển sang tháng, năm khác và Enter để chọn và làm mất focus trên ComboBox.

Em tải cái file đầu tiên, khi em chọn một mục ở combobox Tháng, rồi enter, ngay lập tức nó chuyển focus sang combobox Năm, xổ list của combobox này ra, nhưng hoàn toàn không có việc thay đổi ngày tháng năm theo những tháng, năm em chọn.

Và em đã tải 3 lần, cả 3 lần code đều khác nhau, có thể Thầy đã update trong mỗi phiên bản.

Như em cũng đã nói là học thuật, vì học thuật cũng có nhiều cách để học, Thầy dạy cho em nhiều thì em được biết nhiều, Thầy dạy cho em ít thì em biết ít. Có thể nói em tham lam, nhồi nhét nhiều thủ tục trong một ứng dụng, thật sự em cũng muốn người dùng cảm thấy hơn cái mà họ có sẳn và tiện ích hơn thì em đã thành công (mặc dù code em rườm rà, dài vằng vặc là vì em không có kiến thức sâu rộng như các Thầy).

Mà đã nói ứng dụng thay thế, nếu nó không bằng thằng control calendar, thì ai mà xài? Phải có điểm hơn mới thể dùng được.

Các điểm hơn mà chúng ta phải tạo:

1) Về các ngày thứ bảy, chủ nhật chúng ta phải cá nhân hóa bằng màu nền (cái này calendar không có); ngày hiện hành nó cũng không cho ta biết nằm ở đâu, chỉ có ngày mà chúng ta chọn nó khác màu so với các ngày khác. Đã ăn chắc mặc bền rồi thì cũng phải có nhu cầu cao hơn là ăn ngon mặc đẹp nữa chứ!

2) Chọn về ngày hôm nay (ngày hiện hành) mình làm được (dĩ nhiên calendar cũng làm được nếu ta cho nút lệnh calendar.value = date)

3) Giống hoặc gần giống hoàn toàn với calendar về nhiều thứ, nhất là khoản chọn lịch trên combobox: Không cho gõ trên đó, chỉ được xổ danh sách và chọn trong đó, sau khi chọn nó update liền tháng, năm được chọn, kể cả lịch trong điện thoại di động cũng làm như thế.

Các điểm hạn chế của lịch em cải tiến là:

- Khi chọn tháng, năm lịch update ngày hơi chậm hơn so với calendar

- Mỗi lần qua tháng khác, năm khác thường bị chớp màn hình.

- Code quả thật như các Thầy nhận xét, quá dài (nhưng đành chịu, không bỏ một trong các mắc xích được vì kiến thức hạn hẹp)

CHÍNH VÌ HIỂU ĐƯỢC BẢN CHẤT CỦA MÌNH MẠNH ĐIỂM NÀO, YẾU ĐIỂM NÀO ĐỂ MÌNH PHÁT HUY VÀ KHẮC PHỤC, cho nên em muốn học thêm thuật toán của các THẦY để dần dần hoàn thiện. Và luôn tự nhủ mình học vậy là hoàn toàn miễn phí từ các Thầy, nên các Thầy truyền đạt được nhiều thì em học được nhiều, dù ít hay nhiều em vẫn luôn luôn biết ơn và trân trọng, chứ em không bao giờ có ý nghĩ mình là người "đặt hàng" để đòi hỏi người "nhận hàng" phải làm thế này thế kia.

Em cám ơn Thầy rất nhiều ạ.

 

[ndu96081631]

Cái mà tôi quan tâm nhất trong topic này là: Liệu có thể tạo được 1 cái Calendar hoạt động gần giống như Calendar Control của Excel không?
Hoạt động gần giống nghĩa là:
- Khi click vào 1 ngày nào đó, tôi muốn giá trị ngày ấy gán vào đâu (trên cell, trên textbox hay bất kỳ đâu) thì nó sẽ gán vào đó
- Khi tôi muốn Calendar Show tại vị trí nào thì nó sẽ show đúng vị trí đó
- Code phải được Save thành 1 AddIn để dùng bất cứ khi nào tôi cần
vân vân...
Để làm chi? Để trong trường hợp tôi không thể cài được MSCAL.OCX (Office 64 không xài được) thì ít nhất tôi cũng có cái để dùng
----------------
Như vậy đấy! Nhưng xem ra thì cuối cùng cái Calendar này chỉ để... nhìn, mức độ ứng dụng chưa cao

 

[Hoàng Trọng Nghĩa]

Cái mà tôi quan tâm nhất trong topic này là: Liệu có thể tạo được 1 cái Calendar hoạt động gần giống như Calendar Control của Excel không?
Hoạt động gần giống nghĩa là:
- Khi click vào 1 ngày nào đó, tôi muốn giá trị ngày ấy gán vào đâu (trên cell, trên textbox hay bất kỳ đâu) thì nó sẽ gán vào đó
- Khi tôi muốn Calendar Show tại vị trí nào thì nó sẽ show đúng vị trí đó
- Code phải được Save thành 1 AddIn để dùng bất cứ khi nào tôi cần
vân vân...
Để làm chi? Để trong trường hợp tôi không thể cài được MSCAL.OCX (Office 64 không xài được) thì ít nhất tôi cũng có cái để dùng
----------------
Như vậy đấy! Nhưng xem ra thì cuối cùng cái Calendar này chỉ để... nhìn, mức độ ứng dụng chưa cao

2 cái hàng tô đậm thì đã làm được rồi mà Thầy? Riêng hàng thứ 2 thì trong form muốn nó ở vị trí nào thì cũng đã làm được ở chỗ đó, còn trên cell thì cái hàm mà Thầy và Thầy Siwtom hướng dẫn em vừa qua (CellPositon) đã giải quyết được đó thôi.

Riêng save thành addins thì để code hoàn thiện thì mình xây dựng cũng không muộn.

Việc thay thế cái thư viện MSCAL.OCX này e ra không thể, vì hình như trong các lịch nó lấy từ thư viện này kể cả lịch tự tạo cũng lấy từ lịch hệ thống, không biết em nói vậy đúng không?

 

[ndu96081631]

Riêng save thành addins thì để code hoàn thiện thì mình xây dựng cũng không muộn.

Không dễ ăn để làm điều này đâu. Thử sẽ biết
Đúng trên cương vị người dùng, tôi đâu cần biết code viết gì, cũng không quan tâm sẽ sửa code thế nào, miễn sao tôi có được 1 lệnh tổng quát để điều khiển calendar là được rồi

 

[Hoàng Trọng Nghĩa]

Không dễ ăn để làm điều này đâu. Thử sẽ biết
Đúng trên cương vị người dùng, tôi đâu cần biết code viết gì, cũng không quan tâm sẽ sửa code thế nào, miễn sao tôi có được 1 lệnh tổng quát để điều khiển calendar là được rồi

Em nghĩ chuyện code của form như thế nào thì người dùng chẳng cần bận tâm.

Vậy thì làm một Addins gán macro gọi lịch vào một menu, trên cell thì mình dùng thủ tục selection.value=calendar

Không biết ý Thầy nói khó ở đâu?

 

[Hoàng Trọng Nghĩa]

Em kết hợp hàm CellPosition (của Thầy được cải tiến bởi Thầy siwtom), làm một Addins thực hiện trên Cell Menu như sau:

Trên Thisworkbook Module ta đặt 2 sự kiện:

[GPECODE=vb]Option Explicit

Private Sub Workbook_Open()
With Application.CommandBars("Cell")
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("Cell").Controls("Calendar").Delete
End Sub
[/GPECODE]

Và thủ tục chạy sự kiện đó như sau:

[GPECODE=vb]

Sub CalShow()
With Selection
If .Rows.Count > 1 Then
Dim Msg As Integer, MsgText As String
MsgText = "B" & ChrW(7841) & "n " & ChrW(273) & "ang ch" & ChrW(7885) & _
"n trên nhi" & ChrW(7873) & "u Cell, b" & ChrW(7841) & _
"n mu" & ChrW(7889) & "n nh" & ChrW(7853) & _
"p ngày tháng nh" & ChrW(432) & " th" & ChrW(7871) & " nào?" & _
String(2, vbLf) & "- " & ChrW(272) & ChrW(7875) & " nh" & ChrW(7853) & _
"p trên t" & ChrW(7845) & "t c" & ChrW(7843) & " các cell, ch" & ChrW(7885) & "n YES" & _
String(2, vbLf) & "- Ch" & ChrW(7881) & " nh" & ChrW(7853) & "p t" _
& ChrW(7841) & "i ActiveCell (ô hi" & ChrW(7879) & "n hành), ch" & ChrW(7885) & "n NO."

Msg = Application.Assistant.DoAlert("THÔNG BÁO", MsgText, msoAlertButtonYesNo, _
msoAlertIconQuery, msoAlertDefaultSecond, msoAlertCancelDefault, False)
If Msg = vbNo Then
ActiveCell.Value = DatePicked(.Value)
Exit Sub
End If
End If
.Value = DatePicked(.Value)
End With
End Sub
[/GPECODE]

Với thủ tục CalShow, nếu vùng được chọn là 1 ô thì không nói gì, nhưng nếu là nhiều ô sẽ có một thông báo trước khi Lịch được hiện ra, hỏi bạn chọn nhập ngày tháng tại ô hiện hành hay cả khối ô đã chọn.

Và hàm DatePicked dưới đây cũng chỉnh lại chút cho phù hợp với lịch trên cell:

[GPECODE=vb]Function DatePicked(Optional varPassedDate As Variant) As Variant
On Error Resume Next
gvarStartDate = IIf(IsMissing(varPassedDate), Date, varPassedDate)
If Not IsDate(gvarStartDate) Then gvarStartDate = Date
Call ShowForm(UsfCalendar, ActiveCell)
DatePicked = gvarSelectedDate
End Function
[/GPECODE]

Bây giờ người dùng có thể chép vào thư mục Addin để chạy calendar thôi.

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

ĐÃ UPDATE THÀNH ADDINS VỚI CÁC THỦ TỤC ĐƠN GIẢN.

TẢI BÀI MỚI TẠI ĐÂY (BÀI #63) - CLICK VÀO ĐÂY

 

[ndu96081631]

Em kết hợp hàm CellPosition (của Thầy được cải tiến bởi Thầy siwtom), làm một Addins thực hiện trên Cell Menu như sau:
.

Nếu tôi không muốn cái Popup mà muốn dùng khi có sự kiện SelectionChange thì sao?
Thật ra Nghĩa chưa hiểu ý tôi! Cái tôi muốn là 1 công cụ chưa được "lắp ráp" sẵn, khi người dùng muốn xài sao thì tự họ "lắp ráp"
Ví dụ:
- Giả định rằng tôi viết được 1 Sub có tham số truyền theo dạng ShowCalendar(Left, Top)
- Giả định AddIn đã được gọi lên
- Giờ nếu tôi muốn hiện Calendar tại vị trí cell A1 thì tôi (người dùng) sẽ viết ShowCalendar(Range("A1").Left, Range("A1").Top)
Đại khái thế chứ không phải "lắp ráp hoàn chỉnh"... vì như code AddIn này, tôi muốn nó hiện tại UserForm của tôi thì làm thế nào?

 

[Hoàng Trọng Nghĩa]

Nếu tôi không muốn cái Popup mà muốn dùng khi có sự kiện SelectionChange thì sao?
Thật ra Nghĩa chưa hiểu ý tôi! Cái tôi muốn là 1 công cụ chưa được "lắp ráp" sẵn, khi người dùng muốn xài sao thì tự họ "lắp ráp"
Ví dụ:
- Giả định rằng tôi viết được 1 Sub có tham số truyền theo dạng ShowCalendar(Left, Top)
- Giả định AddIn đã được gọi lên
- Giờ nếu tôi muốn hiện Calendar tại vị trí cell A1 thì tôi (người dùng) sẽ viết ShowCalendar(Range("A1").Left, Range("A1").Top)
Đại khái thế chứ không phải "lắp ráp hoàn chỉnh"... vì như code AddIn này, tôi muốn nó hiện tại UserForm của tôi thì làm thế nào?

Thầy thử với cái này xem:

Tại File Addins, trong Module Thầy đặt thủ tục sau:

[GPECODE=vb]Sub CalendarShow()
UsfCalendar.Show
End Sub
[/GPECODE]

Bây giờ tại file người dùng Thầy đặt trong Module thủ tục sau:

[GPECODE=vb]Sub CallForm()
Run "'FileName.xla'!CalendarShow"
End Sub
[/GPECODE]

Như vậy, với đẳng cấp của Thầy, thì thầy biết phải đặt vị trí form này ở đâu và làm gì ở Sub CalendarShow rồi phải không?

 

[siwtom]

Em tải cái file đầu tiên, khi em chọn một mục ở combobox Tháng, rồi enter, ngay lập tức nó chuyển focus sang combobox Năm, xổ list của combobox này ra, nhưng hoàn toàn không có việc thay đổi ngày tháng năm theo những tháng, năm em chọn.

Và em đã tải 3 lần, cả 3 lần code đều khác nhau, có thể Thầy đã update trong mỗi phiên bản.

Thế thì lạ thật. Tôi gửi tập tin RAR chỉ 1 lần, và lần cuối vì thêm xử lý việc gõ sai trong ComboBox.

Mà đã nói ứng dụng thay thế, nếu nó không bằng thằng control calendar, thì ai mà xài? Phải có điểm hơn mới thể dùng được.

Các điểm hơn mà chúng ta phải tạo:

Nếu bạn đọc bài đầu tiên của tôi trong chủ để này thì bạn thấy cái mà tôi muốn giới thiệu chính là CLASS. Bạn viết nhiều bài, tại sao tôi lại trả lời đúng bài "ấy"?
Bạn có mục đích của mình là làm một Calendar, vậy bạn muốn nó có nhiều chức năng, thân thiện, giao diện đẹp. Mục đích của tôi là giới thiệu về CLASS, về code, tôi viết hoàn chỉnh code để cho có đầu có đuôi mà thôi. Vì phải "gắn" cái class ấy thế nào, vào đâu, xử lý click thế nào, vậy phải có calendar để test. Thế thôi. Cái tôi quan tâm là code, vậy tôi muốn biết code như thế đã chuẩn chưa, click, bấm phím vào "kia" có gì sẩy ra không. Tôi không quan tâm về chức năng, về giao diện vì tôi có ý làm Calendar đâu. Mà bạn đã có Calendar với chức năng từ A đến Z thì bạn cần 1 Calendar thứ 2 giống hệt về chức năng để làm gì???
Cái mà tôi muốn giỡi thiệu là class. Nhưng nếu bạn thấy cách code "chỗ này" là hay, "chỗ kia" có kỹ thuật mình chưa biết hay mẹo gì đó thì tôi mừng rồi. Vì mục đích của tôi chỉ có thế. Calendar chỉ là cái cớ để giới thiệu về code chứ không phải mục đích của tôi.

 

[Hoàng Trọng Nghĩa]

Thế thì lạ thật. Tôi gửi tập tin RAR chỉ 1 lần, và lần cuối vì thêm xử lý việc gõ sai trong ComboBox.


Nếu bạn đọc bài đầu tiên của tôi trong chủ để này thì bạn thấy cái mà tôi muốn giới thiệu chính là CLASS. Bạn viết nhiều bài, tại sao tôi lại trả lời đúng bài "ấy"?
Bạn có mục đích của mình là làm một Calendar, vậy bạn muốn nó có nhiều chức năng, thân thiện, giao diện đẹp. Mục đích của tôi là giới thiệu về CLASS, về code, tôi viết hoàn chỉnh code để cho có đầu có đuôi mà thôi. Vì phải "gắn" cái class ấy thế nào, vào đâu, xử lý click thế nào, vậy phải có calendar để test. Thế thôi. Cái tôi quan tâm là code, vậy tôi muốn biết code như thế đã chuẩn chưa, click, bấm phím vào "kia" có gì sẩy ra không. Tôi không quan tâm về chức năng, về giao diện vì tôi có ý làm Calendar đâu. Mà bạn đã có Calendar với chức năng từ A đến Z thì bạn cần 1 Calendar thứ 2 giống hệt về chức năng để làm gì???
Cái mà tôi muốn giỡi thiệu là class. Nhưng nếu bạn thấy cách code "chỗ này" là hay, "chỗ kia" có kỹ thuật mình chưa biết hay mẹo gì đó thì tôi mừng rồi. Vì mục đích của tôi chỉ có thế. Calendar chỉ là cái cớ để giới thiệu về code chứ không phải mục đích của tôi.

Thì em đã nói là em được học thêm Thầy về Class, em đâu có nói gì đến code của Thầy đâu, mà bản thân em chưa biết tí gì về Class hết sao biết đúng hay sai trong code, nên chỉ thấy Lịch nó thể hiện thế nào thì nói thế ấy thôi ạ.

À, mà em cũng không biết Thầy nói hiện tiếng Việt nữa vời là sao nữa, trong VBE em gõ chữ "vô, ngày..." được, em vẫn thấy nó hiển thị được, nhưng không hiểu sao cái hình của Thầy nó lại không ra chữ "vô, ngày..."?

Em có một thủ thuật để gõ như vậy là em quay macro tại WORD em gõ gì vào đó thì macro nó tự mã hóa dấu tiếng Việt cho em, em chỉ ôm nó qua Excel thôi, không chỉnh sửa thêm gì hết!

[GPECODE=vb]Sub Macro1()
'
' Macro1 Macro
' Macro recorded 28/12/2012 by NRKH
'
Selection.TypeText Text:="Kính th" & ChrW(432) & "a Th" & ChrW(7847) & _
"y siwtom, em r" & ChrW(7845) & "t bi" & ChrW(7871) & "t " & ChrW(417) & _
"n Th" & ChrW(7847) & "y!"
Selection.TypeParagraph
End Sub
[/GPECODE]

[GPECODE=vb]Sub Macro2()
'
' Macro2 Macro
' Macro recorded 28/12/2012 by NRKH
'
Selection.TypeText Text:="B" & ChrW(7845) & "m vô " & ChrW(273) & "ây " & _
ChrW(273) & ChrW(7875) & " ch" & ChrW(7885) & "n ngày hôm nay"
End Sub
[/GPECODE]

 

[ndu96081631]

Thầy thử với cái này xem:

Tại File Addins, trong Module Thầy đặt thủ tục sau:

[GPECODE=vb]Sub CalendarShow()
UsfCalendar.Show
End Sub
[/GPECODE]

Bây giờ tại file người dùng Thầy đặt trong Module thủ tục sau:

[GPECODE=vb]Sub CallForm()
Run "'FileName.xla'!CalendarShow"
End Sub
[/GPECODE]

Như vậy, với đẳng cấp của Thầy, thì thầy biết phải đặt vị trí form này ở đâu và làm gì ở Sub CalendarShow rồi phải không?

Mình nói mà hình như Nghĩa đếch có hiểu ý mình gì cả (hoặc là văn chương của mình có vấn đề)
Thôi, khỏi góp ý luôn chon rồi
Ẹc... Ẹc...

 

[thanhlanh]

Mình yếu nên không hiểu ndu và Nghĩa - "hai thầy trò" - thảo luận với nhau cái gì, tại sao lại phải tìm cách đặt nó ở ô A1, A2 ....

Nếu cái lịch này hoàn chỉnh, mình chỉ muốn tạo một lệnh ở đâu đó trên menu nào đó để thỉnh thoảng gọi nó show để tra ngày, đồng thời "ủng hộ" và giới thiệu sản phẩm của GPE.

Cái được nhất ở đây là mình học được giải thuật, thuật toán và class ... từ những cao thủ, đặc biệt là anh siwtom.

 

[Hoàng Trọng Nghĩa]

Mình nói mà hình như Nghĩa đếch có hiểu ý mình gì cả (hoặc là văn chương của mình có vấn đề)
Thôi, khỏi góp ý luôn chon rồi
Ẹc... Ẹc...

1) Ban đầu, Thầy nói người dùng chẳng cần biết gì về code, chỉ biết Addins rồi dùng. OK, em đã làm

2) Thầy lại nói sao gọi được cái Calendar từ Addins (tức người dùng đã biết VBA). OK, thủ tục để hiện cái Form em cũng đã đưa lên.

??? Tại sao Thầy lại nói vậy?

Nếu Thầy có hướng đi khác thì Thầy chia sẽ, chứ trình độ của em chỉ được vậy.

 

[ndu96081631]

Mình yếu nên không hiểu ndu và Nghĩa - "hai thầy trò" - thảo luận với nhau cái gì, tại sao lại phải tìm cách đặt nó ở ô A1, A2 ....

Là tìm cách sao cho "nó" hoạt động gần giống như Calendar Control mà ta vẫn dùng trên Excel đấy anh

 

[thanhlanh]

Là tìm cách sao cho "nó" hoạt động gần giống như Calendar Control mà ta vẫn dùng trên Excel đấy anh

Vậy mình nghĩ mục đích của Nghĩa cũng như mình, coi lịch chỉ như một tiện ích. Còn ndu thì nâng lên tầm cao hơn, làm cho lịch trở thành một control, nếu vậy chỉ có ndu trở lên mới có thể làm được. Vậy mà không hiểu nhau, thôi đừng nóng nữa thày ạ!

 

[ndu96081631]

Vậy mình nghĩ mục đích của Nghĩa cũng như mình, coi lịch chỉ như một tiện ích. Còn ndu thì nâng lên tầm cao hơn, làm cho lịch trở thành một control, nếu vậy chỉ có ndu trở lên mới có thể làm được. Vậy mà không hiểu nhau, thôi đừng nóng nữa thày ạ!

Thú thật là em khá sốt ruột. Chừng 1 năm nữa thôi, nếu đổi máy tính mới thì bắt buộc phải cài Win 64.
Mà theo em được biết thì 2 thằng em Calendar Control + DTPicker không chạy được trên hệ thống 64 bit ---> Lúc đó phải làm sao nếu có nhu cầu sử dụng?
Vậy nên em rất muốn tạo 1 Control cho riêng mình. Cái calendar ấy đẹp xấu không quan trọng... những giải thuật trong cũng chẳng có gì phải bàn cả, vấn đề là làm sao "múc" nó thành 1 dạng OCX?
Nghĩa làm không được thôi nhưng em nghĩ cở siwtom chắc sẽ làm được (còn em cũng đang nghiên cứu theo hướng này nhưng chưa được bao nhiêu)

 

[siwtom]

Thú thật là em khá sốt ruột. Chừng 1 năm nữa thôi, nếu đổi máy tính mới thì bắt buộc phải cài Win 64.
Mà theo em được biết thì 2 thằng em Calendar Control + DTPicker không chạy được trên hệ thống 64 bit ---> Lúc đó phải làm sao nếu có nhu cầu sử dụng?
Vậy nên em rất muốn tạo 1 Control cho riêng mình. Cái calendar ấy đẹp xấu không quan trọng... những giải thuật trong cũng chẳng có gì phải bàn cả, vấn đề là làm sao "múc" nó thành 1 dạng OCX?
Nghĩa làm không được thôi nhưng em nghĩ cở siwtom chắc sẽ làm được (còn em cũng đang nghiên cứu theo hướng này nhưng chưa được bao nhiêu)

Sao lại siwtom?
Các bạn thử tìm phần mềm cho 64 bit.
Lập trình cho 64 bit thì cũng phải học và có công cụ chứ lập trình bằng gì?
Tôi có phải người lập trình chuyên nghiệp đâu. Tới giờ tôi vẫn dùng XP 32 bit chứ chưa nói tới Win 7 hay 64 bit gì.
Nếu bạn muốn nhờ thì địa chỉ đúng là Nguyễn Duy Tuân. Tuân lập trình chuyên nghiệp, tạo sản phẩm, vậy Tuân có kiến thức và công cụ để tạo sản phẩm. Tuân bắt buộc phải học những công nghệ mới. Tôi chỉ lập trình chơi thôi nên tôi chỉ học những cái mình thích. Tôi không bắt buộc "phải" cái gì cả.

 

[ndu96081631]

Sao lại siwtom?
Các bạn thử tìm phần mềm cho 64 bit.
Lập trình cho 64 bit thì cũng phải học và có công cụ chứ lập trình bằng gì?
Tôi có phải người lập trình chuyên nghiệp đâu. Tới giờ tôi vẫn dùng XP 32 bit chứ chưa nói tới Win 7 hay 64 bit gì.
Nếu bạn muốn nhờ thì địa chỉ đúng là Nguyễn Duy Tuân. Tuân lập trình chuyên nghiệp, tạo sản phẩm, vậy Tuân có kiến thức và công cụ để tạo sản phẩm. Tuân bắt buộc phải học những công nghệ mới. Tôi chỉ lập trình chơi thôi nên tôi chỉ học những cái mình thích. Tôi không bắt buộc "phải" cái gì cả.

Ah... cái em quan tâm hồng phải là 32 hay 64... Em biết cách để làm cho code chạy được trên cả 32 hay 64 bit...
Nhưng trước mắt, cái mà em quan tâm là muốn hướng đến lập trình OCX hoặc DLL thôi

 

[Hoàng Trọng Nghĩa]

Nếu tôi không muốn cái Popup mà muốn dùng khi có sự kiện SelectionChange thì sao?
Thật ra Nghĩa chưa hiểu ý tôi! Cái tôi muốn là 1 công cụ chưa được "lắp ráp" sẵn, khi người dùng muốn xài sao thì tự họ "lắp ráp"
Ví dụ:
- Giả định rằng tôi viết được 1 Sub có tham số truyền theo dạng ShowCalendar(Left, Top)
- Giả định AddIn đã được gọi lên
- Giờ nếu tôi muốn hiện Calendar tại vị trí cell A1 thì tôi (người dùng) sẽ viết ShowCalendar(Range("A1").Left, Range("A1").Top)
Đại khái thế chứ không phải "lắp ráp hoàn chỉnh"... vì như code AddIn này, tôi muốn nó hiện tại UserForm của tôi thì làm thế nào?

Không biết thủ tục dưới đây có đúng ý của Thầy không:

Tại file Addins mà em gửi lên, viết thêm thủ tục này:

[GPECODE=vb]Public Sub CalendarShow(rCell As Range)
On Error Resume Next
Call ShowForm(UsfCalendar, rCell)
End Sub
[/GPECODE]

Vì thủ tục trên lệ thuộc vào thủ tục này (Thầy đã viết):

[GPECODE=vb]Sub ShowForm(ByRef frm As Object, rCell As Range)
On Error Resume Next
Dim Arr As Variant
Arr = CellPosition(rCell)
With frm
.StartUpPosition = 0
.Left = Arr(1)
.Top = Arr(2)
.Show
End With
End Sub
[/GPECODE]

Giờ tại File người dùng chỉ việc thực hiện công đoạn gọi form lên thôi:

[GPECODE=vb]Sub GoiFormTuFileKhac()
Application.Run "'CldrAddins.xla'!CalendarShow", ActiveCell
End Sub
[/GPECODE]

Để nó trở thành một thư viện thì em không có thể rồi, còn như Thầy nói thì em đã làm được.

 

[siwtom]

Thí dụ với yêu cầu này:

Theo tôi hiểu thì Nghĩa muốn kéo thả label chẳng hạn như Sunday từ cuối lên đầu và ngược lại, để cho tuần bắt đầu từ chủ nhật thay vì thứ hai.

Tôi mới tải tập tin của Nghĩa ở bài #44 về và thử nhấn và kéo các Label ngày trong tuần thì hình như "kéo thả" không đúng như bạn miêu tả thì phải. "Kéo thả" ở đây chắc là cho phép user "kéo" UserForm sang chỗ khác"
-----------------
@Nghĩa:
Bạn thử nghiên cứu cách này xem - chỉ dùng MouseDown:
À, không biết hiện thời bạn có để ý không: khi bạn kéo Form, nhất là khi kéo nhanh, thì bạn nhìn thấy những "vệt" khung trung gian rất xấu.
Tôi cho rằng cách sau gọn hơn cách trước, và không để lại vệt.

1. Trong Initialize bỏ hForm ra ngoài thành biến của module UserForm

2. Code
[GPECODE=vb]
Private Declare Function ReleaseCapture Lib "user32.dll" () As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2

...

Private Sub DoMove(ByVal Button As Integer)
If Button = 1 Then
ReleaseCapture
SendMessage hForm, WM_NCLBUTTONDOWN, HTCAPTION, 0
End If
End Sub

Private Sub lblDay1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
DoMove Button
End Sub

Private Sub lblDay2_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
DoMove Button
End Sub

Private Sub lblDay3_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
DoMove Button
End Sub

Private Sub lblDay4_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
DoMove Button
End Sub

Private Sub lblDay5_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
DoMove Button
End Sub

Private Sub lblDay6_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
DoMove Button
End Sub

Private Sub lblDay7_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
DoMove Button
End Sub
[/GPECODE]

Nhưng nói cho cùng thì user chỉ cần có khả năng "kéo thả" vậy chả lý gì dùng cả 7 Label cho việc này. Code chỉ vì thế mà rườm rà mà thôi. Vậy chỉ để

[GPECODE=vb]
Private Sub lblDay1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If Button = 1 Then
ReleaseCapture
SendMessage hForm, WM_NCLBUTTONDOWN, HTCAPTION, 0
End If
End Sub
[/GPECODE]

còn lại xóa hết
--------------------------------------
Nói nôm na thì khi bạn nhấn chuột trái trên thanh tiêu đề và giữ thì bạn có thể kéo Form. Khi bạn nhấn chuột trái trên thanh tiêu đề thì thông điệp WM_NCLBUTTONDOWN được gửi tới hàm cửa sổ. Nhưng thông điệp WM_NCLBUTTONDOWN cũng được gửi trong những trường hợp khác vd. khi bạn nhấn vào khung (các cạnh) cửa sổ. Nói chung WM_NCLBUTTONDOWN (tổng quát là các WM_NC***) liên quan tới
"NonClient area" - ý nghĩa của NC là thế.
Vậy làm sao biết được khi nào user nhấn vào tiêu đề và khi nào nhấn vào chỗ khác? Thông điệp trong Windows luôn có 2 thông số đi kèm - bạn cứ nhìn các thông số của hàm SendMessage thì thấy. Nếu thông điệp cần "làm rõ thêm" thì Windows sẽ thiết lập 1 hoặc cả 2 giá trị wParam và lParam. Vd. với WM_NCLBUTTONDOWN và wParam = HTCAPTION thì là user nhấn thanh tiêu đề. Còn nếu wParam = HTLEFT, HTTOP, HTRIGHT, HTBOTTOM thì có nghĩa là user nhấn chuột trái ở "gờ trái", "gờ trên", "gờ phải", "gờ dưới" của cửa sổ. Tất nhiên tôi không liệt kê hết các giá trị của wParam. Bạn có thể đọc trong help về các thông điệp WM_NC***
Vậy ta tự gửi tới cửa sổ thông điệp WM_NCLBUTTONDOWN với wParam = HTCAPTION. Đơn giản quá phải không?

 

[ndu96081631]

Để ý cái calender mà ta vẫn dùng trên Excel (MSCAL.OCX) thì khi ta nhấn chuột vào 1 ngày nào đó, cái nút có vẻ như bị lõm xuống (như thế nhìn mới đẹp)
Để làm điều này cũng không có gì khó. Tôi làm trên 1 file mới, nghĩa mang về tham khảo code nhé (tôi không đủ kiên nhẫn để sửa trên file của Nghĩa)

 

[Hoàng Trọng Nghĩa]

Để ý cái calender mà ta vẫn dùng trên Excel (MSCAL.OCX) thì khi ta nhấn chuột vào 1 ngày nào đó, cái nút có vẻ như bị lõm xuống (như thế nhìn mới đẹp)
Để làm điều này cũng không có gì khó. Tôi làm trên 1 file mới, nghĩa mang về tham khảo code nhé (tôi không đủ kiên nhẫn để sửa trên file của Nghĩa)

Thầy thay 2 thủ tục này: FixDaysInMonth và HandleIndent ở file AddIns trước thành:

Private Sub FixDaysInMonth(intStartDay As Integer)
      Dim intRow As Integer, intCol As Integer, intNumDays As Integer, _
      intCount As Integer, strTemp As String, strTemp1 As String

      intNumDays = DaysInMonth(iMonth)
      If Day > intNumDays Then
            Day = intNumDays
      End If

      intCount = 0
      For intRow = 1 To 6
            For intCol = 1 To 7
                  If (intRow = 1) And (intCol < intStartDay) Then
                        Me("lbl1" & intCol).Visible = False
                        Me("AL1" & intCol).Visible = False
                  Else
                        intCount = intCount + 1
                        strTemp = "lbl" & intRow & intCol
                        strTemp1 = "AL" & intRow & intCol
                        With Me(strTemp)
                              If intCount <= intNumDays Then
                                    If Not .Visible Then
                                          .Visible = True
                                          If .Visible = True Then Me(strTemp1).Visible = True
                                    End If
                                    .Caption = intCount
                                    
                                   [COLOR=#ff0000] If .SpecialEffect <> fmSpecialEffectRaised Then .SpecialEffect = fmSpecialEffectRaised[/COLOR]
                                    
                                    Me(strTemp1).Caption = NgayAL(.Caption & "/" & iMonth & "/" & iYear)
                              Else
                                    If .Visible Then
                                          .Visible = False
                                          If .Visible = False Then Me(strTemp1).Visible = False
                                    End If
                              End If
                        End With
                        
                              Dim a As String, b As String, c As String, d As String
                              a = "lbl" & intRow & 1: b = "lbl" & intRow & 7
                              c = "AL" & intRow & 1: d = "AL" & intRow & 7
                              
                        If Me(strTemp) = mintDayToday And iMonth = mintMonthToday And iYear = mintYearToday Then
                              Me(strTemp).BackColor = ClrMagenta
                              Me(strTemp).ForeColor = ClrWhite
                              Me(strTemp1).ForeColor = ClrLightYellow
                        Else
                              If Me(strTemp).BackColor <> ClrLightCyan Then Me(strTemp).BackColor = ClrLightCyan
                              If Me(strTemp).ForeColor <> ClrDarkBlue Then Me(strTemp).ForeColor = ClrDarkBlue
                              If Me(strTemp1).ForeColor <> ClrLightBlue Then Me(strTemp1).ForeColor = ClrLightBlue
                              
                              With Me(a)
                                    If .Caption = mintDayToday And iMonth = mintMonthToday And iYear = mintYearToday Then
                                          .BackColor = ClrMagenta
                                          .ForeColor = ClrWhite
                                           Me(c).ForeColor = ClrLightYellow
                                    Else
                                          If .BackColor <> ClrPink Then .BackColor = ClrPink
                                          If .ForeColor <> ClrRed Then .ForeColor = ClrRed
                                          If Me(c).ForeColor <> ClrLightRed Then Me(c).ForeColor = ClrLightRed
                                    End If
                              End With
                              
                              With Me(b)
                                    If .Caption = mintDayToday And iMonth = mintMonthToday And iYear = mintYearToday Then
                                          .BackColor = ClrMagenta
                                          .ForeColor = ClrWhite
                                           Me(d).ForeColor = ClrLightYellow
                                    Else
                                          If .BackColor <> ClrLightGreen Then .BackColor = ClrLightGreen
                                          If .ForeColor <> ClrDarkGreen Then .ForeColor = ClrDarkGreen
                                          If Me(d).ForeColor <> ClrGreen Then Me(d).ForeColor = ClrGreen
                                    End If
                              End With
                        End If
                  End If
            Next intCol
      Next intRow
End Sub

Và:

Sub HandleIndent(strNewSelect As String)
      If ErrHdle = 0 Then
HdleIdnt:
            If Len(mstrSelected) > 0 Then
                  With Me(mstrSelected)
                        [COLOR=#ff0000].SpecialEffect = fmSpecialEffectRaised[/COLOR]
                        .Font.Size = 11
                        .Font.Bold = False
                        .BackStyle = 1
                  End With
                  Me(Replace(mstrSelected, "lbl", "AL")).Font.Bold = False
            End If
            
            mstrSelected = strNewSelect
            
            Me(Replace(mstrSelected, "lbl", "AL")).Font.Bold = True
            
            With Me(mstrSelected)
                  .Font.Bold = True
                  .Font.Size = 12
                 [COLOR=#ff0000] .SpecialEffect = fmSpecialEffectSunken[/COLOR]
                  
                  Day = .Caption
            End With
            
            With LbSolar
                  .Caption = DayInWeek(DateSerial(iYear, iMonth, Day))
                  .BackColor = Me(mstrSelected).BackColor
                  .ForeColor = Me(mstrSelected).ForeColor
            End With
            
            With LbLunar
                  .Caption = AmLich(DateSerial(iYear, iMonth, Day))
                  .BackColor = Me(mstrSelected).BackColor
                  .ForeColor = Me(Replace(mstrSelected, "lbl", "AL")).ForeColor
            End With
      Else
            LbSolar_Click
            GoTo HdleIdnt
      End If
End Sub

Riêng với các controls trên Form, Thầy không cần chỉnh sửa thuộc tính gì thêm nữa!

 

[minhluan0409]

cách import calender qua file khác

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.

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...

 

[Hoàng Trọng Nghĩa]

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...

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

 

[Hoàng Trọng Nghĩa]

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]

 

[thanh_tks]

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.

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.

 

[Hoàng Trọng Nghĩa]

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.

Nếu anh thường dùng trong chế độ "Page break preview" này thì nên dùng code này:

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ũ.

 

[Hoàng Trọng Nghĩa]

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.

 

[Hoàng Trọng Nghĩa]

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.

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:

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!

 

[doveandrose]

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

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

 

[Hoàng Trọng Nghĩa]

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

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

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!

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

 

[doveandrose]

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!

ồ đú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

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

 

[Hoàng Trọng Nghĩa]

ồ đú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

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

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.

 

[Hoàng Trọng Nghĩa]

Vừa giải quyết xong cái vụ ZOOM nó lại thêm cái đau đầu khác: FREEZE PANE.

 

[doveandrose]

Vừa giải quyết xong cái vụ ZOOM nó lại thêm cái đau đầu khác: FREEZE PANE.

cụ thể là anh giải quyết sao chỉ em với

 

[Hoàng Trọng Nghĩa]

cụ thể là anh giải quyết sao chỉ em với

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

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:

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!

 

[doveandrose]

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!

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

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

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

 

[Hoàng Trọng Nghĩa]

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

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.

 

[doveandrose]

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.

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

 

[huuthang_bd]

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

Hàm này sao không làm vầy cho khỏe?

Private Function getLastColNum(target As Range) As Long
getLastColNum = target.Column + target.Columns.Count - 1
End Function

 

[huuthang_bd]

Lỡ làm thì làm nốt trường hợp này luôn đi

 

[doveandrose]

Lỡ làm thì làm nốt trường hợp này luôn đi
View attachment 147250

ơ thế là lại thất bại nữa rồi à .
vậy là tối nay lại thêm việc nữa ......
có bạn nào hiến kế tính ra chiều rộng cột tên dòng không nè ?

 

[doveandrose]

Lỡ làm thì làm nốt trường hợp này luôn đi
View attachment 147250

ngạc nhiên chưa ? há há

Public Function CellPositionB(ByVal rCell As Range) As Variant
Dim arr(1 To 2) As Double, r As Byte
With ActiveWindow
    For r = 1 To .Panes.Count Step 1
        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
End With
CellPositionB = arr
End Function

 

[Hoàng Trọng Nghĩa]

ngạc nhiên chưa ? há há

Public Function CellPositionB(ByVal rCell As Range) As Variant
Dim arr(1 To 2) As Double, r As Byte
With ActiveWindow
    For r = 1 To .Panes.Count Step 1
        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
End With
CellPositionB = arr
End Function

Ui trời ơi, thật là tuyệt đó nha! Quá tốt rồi, không chê vào đâu được! Đã thử thường, Zoom và các loại Panes. Code quá ngắn luôn!

 

[doveandrose]

Ui trời ơi, thật là tuyệt đó nha! Quá tốt rồi, không chê vào đâu được! Đã thử thường, Zoom và các loại Panes. Code quá ngắn luôn!

âu cũng là nếp sinh hoạt ở diễn đàn này mà . "cái đó" càng ngắn càng tốt =))

 

[Hoàng Trọng Nghĩa]

À, dùng trong Hàm chớ bao giờ dùng Offset nhé, sẽ phát sinh ra lỗi nếu chọn hàng hay cột cuối cùng.

rCell.Offset(1).Top


Chỉ nên cộng thêm vào phút 89 của trận đấu thôi!

 

[huuthang_bd]

ngạc nhiên chưa ? há há

Public Function CellPositionB(ByVal rCell As Range) As Variant
Dim arr(1 To 2) As Double, r As Byte
With ActiveWindow
    For r = 1 To .Panes.Count Step 1
        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
End With
CellPositionB = arr
End Function

Đang xem bằng điện thoại không có điều kiện test nhưng xem code cảm giác vẫn có vấn đề. Đó là khi rCell nằm trong nhiều hơn 1 Pane.Visiblecell

 

[doveandrose]

Đang xem bằng điện thoại không có điều kiện test nhưng xem code cảm giác vẫn có vấn đề. Đó là khi rCell nằm trong nhiều hơn 1 Pane.Visiblecell

thì cứ thử đi bạn . sai thì khiếu nại . cùng lắm là thêm 1 lần thất bại nữa chứ gì

 

[giangleloi]

Đang xem bằng điện thoại không có điều kiện test nhưng xem code cảm giác vẫn có vấn đề. Đó là khi rCell nằm trong nhiều hơn 1 Pane.Visiblecell

Đã kiểm tra và cảm giác của anh là đúng. Bác "Chim hồng" ra tay phát nữa, cho anh em mở mang thêm với.

 

[doveandrose]

Đã kiểm tra và cảm giác của anh là đúng. Bác "Chim hồng" ra tay phát nữa, cho anh em mở mang thêm với.

chụp cho mình xem tấm hình đi bạn

 

[Hoàng Trọng Nghĩa]

Đang xem bằng điện thoại không có điều kiện test nhưng xem code cảm giác vẫn có vấn đề. Đó là khi rCell nằm trong nhiều hơn 1 Pane.Visiblecell

Đã thử trên nhiều trường hợp rồi Thắng ơi, Hàm chạy OK trong 3 trường hợp của panes, 4 phần pane đặt con trỏ ở vùng nào cũng chạy chuẩn.
Với trường hợp ô được chọn khuất trong pane ta nên active ô đó rồi chạy hàm. Như thế trong hàm cần thêm câu lệnh:

Set rCell=rCell(1, 1) phòng trường hợp rCell là selection

Sau đó là rCell.Activate

Rồi mới đến With ActiveWindow.

(Cũng đang trên đt, nhưng đã test tối qua).

 

[huuthang_bd]

thì cứ thử đi bạn . sai thì khiếu nại . cùng lắm là thêm 1 lần thất bại nữa chứ gì

Chắc lên chức Bà cố ngoại rồi
[video=youtube;XEbynLSDffg]https://www.youtube.com/watch?v=XEbynLSDffg&feature=youtu.be[/video]

 

[doveandrose]

Chắc lên chức Bà cố ngoại rồi
[video=youtube;XEbynLSDffg]https://www.youtube.com/watch?v=XEbynLSDffg&feature=youtu.be[/video]

ủa click vào đó thì nó tự active cell đối xứng bên tay trái => active cell nằm bên tay trái mà . có gì ngạc nhiên

 

[Hoàng Trọng Nghĩa]

ủa click vào đó thì nó tự active cell đối xứng bên tay trái => active cell nằm bên tay trái mà . có gì ngạc nhiên

Thật ra nó tính không sai, nhưng đang thao tác trên vùng này mà nó chạy form bên vùng khác khi 2 vùng cùng hiển thị activecell thì hơi khó chịu đó mà.

 

[huuthang_bd]

ủa click vào đó thì nó tự active cell đối xứng bên tay trái => active cell nằm bên tay trái mà . có gì ngạc nhiên

Thì đúng vẫn là cell đó nhưng hổng lẽ nhập liệu phải như vầy
[video=youtube;3nL-tHkKkyA]https://www.youtube.com/watch?v=3nL-tHkKkyA&amp;feature=youtu.be[/video]

 

[huuthang_bd]

Nên chăng sửa lại như vầy

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

 

[Hoàng Trọng Nghĩa]

Nên chăng sửa lại như vầy

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

OK, vậy là ổn rồi! Đã test!

 

[doveandrose]

Nên chăng sửa lại như vầy

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

hi hi

Public Function CellPositionB(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 And [COLOR=#ff0000][B]False[/B][/COLOR] 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
CellPositionB = arr
End Function

 

[Hoàng Trọng Nghĩa]

Nên chăng sửa lại như vầy

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

Tôi nghĩ là nên như vầy:

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

 

[Hoàng Trọng Nghĩa]

hi hi

Public Function CellPositionB(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 And [COLOR=#ff0000][B]False[/B][/COLOR] 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
CellPositionB = arr
End Function

Lý do gì thêm False vậy? Trường hợp nào phát sinh False?

 

[huuthang_bd]

hi hi

Public Function CellPositionB(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 And [COLOR=#ff0000][B]False[/B][/COLOR] 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
CellPositionB = arr
End Function

Bạn thử với 1 ô thuộc Panes(1) khi đang Freeze Panes xem có đúng không.
@Hoàng Trọng Nghĩa: Ý là bỏ luôn đoạn đó đó.

 

[doveandrose]

Bạn thử với 1 ô thuộc Panes(1) khi đang Freeze Panes xem có đúng không.
@Hoàng Trọng Nghĩa: Ý là bỏ luôn đoạn đó đó.

cần có video để soi đường
a thấy rồi . bỏ đi không được . thật ngại quá hi hi