VBA Excel에서 캘린더 입력을 만들려면 어떻게 해야 합니까?

programing

VBA Excel에서 캘린더 입력을 만들려면 어떻게 해야 합니까?

megabox 2023. 4. 29. 09:10

VBA Excel에서 캘린더 입력을 만들려면 어떻게 해야 합니까?

문제 설명

VBA에서는 관리자 권한을 사용하여 특정 OCX를 등록한 경우 세 가지 주요 유형의 날짜 시간 컨트롤을 사용할 수 있습니다.이러한 컨트롤은 VB6 컨트롤이며 VBA 환경에 기본적으로 제공되지 않습니다.Montview Control 및 Datetime Picker를 설치하려면 mscomct2.ocx의 등록을 높여야만 액세스할 수 있는 Microsoft MonthView Control 6.0(SP4)에 대한 참조를 설정해야 합니다.마찬가지로 mscal.ocx 및 mscomctl.ocx 형식입니다.그러나 사용되지 않는 mscal.ocx는 Windows 10에서 작동할 수도 있고 작동하지 않을 수도 있습니다.

Windows 및 Office 버전(32비트 또는 64비트)에 따라 이러한 Ocx를 등록하는 것이 매우 어려울 수 있습니다.

월 보기 컨트롤, 날짜 선택기 및 사용되지 않는 달력 컨트롤은 다음과 같습니다.

그래서 이것들을 신청서에 포함시키면 어떤 문제에 직면할 수 있습니까?

만약 당신이 그것들을 당신의 프로젝트에 포함시키고 그것들을 당신의 친구들, 이웃들, 고객들 등에게 배포한다면, 그들이 ocx를 설치했는지 여부에 따라 애플리케이션이 작동하지 않을 수도 있습니다.

따라서 프로젝트에 사용하지 않는 것이 좋습니다.

다른 방법이 있습니까?

사용자 양식과 워크시트를 사용하는 이 달력은 이전에 제안되었으며 매우 기본적입니다.

시스템 트레이에서 날짜와 시간을 클릭하면 나타나는 Windows 10 달력을 보고 VBA로 복제할 수 있는지 궁금했습니다.

이 게시물은 ocx 또는 32bit/64bit에 종속되지 않고 프로젝트와 함께 자유롭게 배포할 수 있는 캘린더 위젯을 만드는 방법에 관한 것입니다.

Windows 10(윈도우 10)의 달력은 다음과 같습니다.

그리고 이것이 당신이 그것과 상호 작용:

샘플 파일(게시물 끝에 추가)에는 사용자 양식, 모듈 및 클래스 모듈이 있습니다.이를 프로젝트에 통합하려면 샘플 파일에서 사용자 양식, 모듈 및 클래스 모듈을 내보내고 프로젝트로 가져오기만 하면 됩니다.

클래스 모듈 코드

에서 (s call it (Let's call it)CalendarClass이 코드를 붙여넣습니다.

Public WithEvents CommandButtonEvents As MSForms.CommandButton

'~~> Unload the form when the user presses Escape
Private Sub CommandButtonEvents_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
    If Not f Is Nothing Then If KeyAscii = 27 Then Unload f
End Sub

'~~> This section delas with showing/displaying controls
'~~> and updating different labels
Private Sub CommandButtonEvents_Click()
    f.Label6.Caption = CommandButtonEvents.Tag

    If Left(CommandButtonEvents.Name, 1) = "Y" Then
        If Len(Trim(CommandButtonEvents.Caption)) <> 0 Then
            CurYear = Val(CommandButtonEvents.Caption)                
            With f
                .HideAllControls
                .ShowMonthControls

                .Label4.Caption = CurYear
                .Label5.Caption = 2

                .CommandButton1.Visible = False
                .CommandButton2.Visible = False
            End With
        End If
    ElseIf Left(CommandButtonEvents.Name, 1) = "M" Then
        Select Case UCase(CommandButtonEvents.Caption)
            Case "JAN": CurMonth = 1
            Case "FEB": CurMonth = 2
            Case "MAR": CurMonth = 3
            Case "APR": CurMonth = 4
            Case "MAY": CurMonth = 5
            Case "JUN": CurMonth = 6
            Case "JUL": CurMonth = 7
            Case "AUG": CurMonth = 8
            Case "SEP": CurMonth = 9
            Case "OCT": CurMonth = 10
            Case "NOV": CurMonth = 11
            Case "DEC": CurMonth = 12
        End Select

        f.HideAllControls
        f.ShowSpecificMonth
    End If
End Sub

모듈 코드

s it (Let's call it)CalendarModule이 코드를 붙여넣습니다.

Option Explicit

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

#If VBA7 Then
    #If Win64 Then
        Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias _
        "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr

        Public Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias _
        "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, _
        ByVal dwNewLong As LongPtr) As LongPtr
    #Else
        Public Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias _
        "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr

        Private Declare Function SetWindowLongPtr Lib "user32" Alias _
        "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, _
        ByVal dwNewLong As LongPtr) As LongPtr
    #End If

    Public Declare PtrSafe Function DrawMenuBar Lib "user32" _
    (ByVal hwnd As LongPtr) As LongPtr

    Private Declare PtrSafe Function FindWindow Lib "user32" Alias _
    "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As LongPtr

    Private Declare PtrSafe Function SetTimer Lib "user32" _
    (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, _
    ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As LongPtr

    Public Declare PtrSafe Function KillTimer Lib "user32" _
    (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As LongPtr

    Public TimerID As LongPtr

    Dim lngWindow As LongPtr, lFrmHdl As LongPtr
#Else

    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 DrawMenuBar _
    Lib "user32" (ByVal hwnd As Long) As Long

    Public Declare Function FindWindowA _
    Lib "user32" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long

    Public Declare Function SetTimer Lib "user32" ( _
    ByVal hwnd As Long, ByVal nIDEvent As Long, _
    ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long

    Public Declare Function KillTimer Lib "user32" ( _
    ByVal hwnd As Long, ByVal nIDEvent As Long) As Long

    Public TimerID As Long
    Dim lngWindow As Long, lFrmHdl As Long
#End If

Public TimerSeconds As Single, tim As Boolean
Public CurMonth As Integer, CurYear As Integer
Public frmYr As Integer, ToYr As Integer

Public f As frmCalendar

Enum CalendarThemes
    Venom = 0
    MartianRed = 1
    ArcticBlue = 2
    Greyscale = 3
End Enum

Sub Launch()
    Set f = frmCalendar

    With f
        .Caltheme = Greyscale
        .LongDateFormat = "dddd dd. mmmm yyyy" '"dddd mmmm dd, yyyy" etc
        .ShortDateFormat = "dd/mm/yyyy"  '"mm/dd/yyyy" or "d/m/y" etc
        .Show
    End With
End Sub

'~~> Hide the title bar of the userform
Sub HideTitleBar(frm As Object)
    #If VBA7 Then
        Dim lngWindow As LongPtr, lFrmHdl As LongPtr
        lFrmHdl = FindWindow(vbNullString, frm.Caption)
        lngWindow = GetWindowLongPtr(lFrmHdl, GWL_STYLE)
        lngWindow = lngWindow And (Not WS_CAPTION)
        Call SetWindowLongPtr(lFrmHdl, GWL_STYLE, lngWindow)
        Call DrawMenuBar(lFrmHdl)
    #Else
        Dim lngWindow As Long, lFrmHdl As Long
        lFrmHdl = FindWindow(vbNullString, frm.Caption)
        lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE)
        lngWindow = lngWindow And (Not WS_CAPTION)
        Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow)
        Call DrawMenuBar(lFrmHdl)
    #End If
End Sub

'~~> Start Timer
Sub StartTimer()
    '~~ Set the timer for 1 second
    TimerSeconds = 1
    TimerID = SetTimer(0&, 0&, TimerSeconds * 1000&, AddressOf TimerProc)
End Sub

'~~> End Timer
Sub EndTimer()
    On Error Resume Next
    KillTimer 0&, TimerID
End Sub

'~~> Update Time
#If VBA7 And Win64 Then ' 64 bit Excel under 64-bit windows  ' Use LongLong and LongPtr
    Public Sub TimerProc(ByVal hwnd As LongPtr, ByVal uMsg As LongLong, _
    ByVal nIDEvent As LongPtr, ByVal dwTimer As LongLong)
        frmCalendar.Label1.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(0)
        frmCalendar.Label2.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(1)
    End Sub
#ElseIf VBA7 Then ' 64 bit Excel in all environments
    Public Sub TimerProc(ByVal hwnd As LongPtr, ByVal uMsg As Long, _
    ByVal nIDEvent As LongPtr, ByVal dwTimer As Long)
        frmCalendar.Label1.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(0)
        frmCalendar.Label2.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(1)
    End Sub
#Else ' 32 bit Excel
    Public Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, _
    ByVal nIDEvent As Long, ByVal dwTimer As Long)
        frmCalendar.Label1.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(0)
        frmCalendar.Label2.Caption = Split(Format(Time, "h:mm:ss AM/PM"))(1)
    End Sub
#End If

'~~> Improvement suggested by T.M (https://stackoverflow.com/users/6460297/t-m)
'(1) Get weekday name
Function wday(ByVal wd&, ByVal lang As String) As String
    ' Purpose: get weekday in "DDD" format
    wday = Application.Text(DateSerial(6, 1, wd), cPattern(lang) & "ddd")    ' the first day in year 1906 starts with a Sunday
End Function

'~~> Improvement suggested by T.M (https://stackoverflow.com/users/6460297/t-m)
'(2) Get month name
Function mon(ByVal mo&, ByVal lang As String) As String
    ' Example call: mon(12, "1031") or mon(12, "de")
    mon = Application.Text(DateSerial(6, mo, 1), cPattern(lang) & "mmm")
End Function

'~~> Improvement suggested by T.M (https://stackoverflow.com/users/6460297/t-m)
'(3) International patterns
Function cPattern(ByVal ctry As String) As String
    ' Purpose: return country code pattern for above functions mon() and wday()
    ' Codes: see https://msdn.microsoft.com/en-us/library/dd318693(VS.85).aspx
    ctry = LCase(Trim(ctry))
    Select Case ctry
        Case "1033", "en-us": cPattern = "[$-409]" ' English (US)
        Case "1031", "de": cPattern = "[$-C07]" ' German
        Case "1034", "es": cPattern = "[$-C0A]" ' Spanish
        Case "1036", "fr": cPattern = "[$-80C]" ' French
        Case "1040", "it": cPattern = "[$-410]" ' Italian
        ' more ...
    End Select
End Function

사용자 양식 코드

양식 (s call it 사양식자 (Let's call it)frmCalendar코드가 너무 커서 여기에 게시할 수 없습니다.샘플 파일을 참조하시기 바랍니다.

스크린샷

테마

하이라이트

dll/ocx를 등록할 필요가 없습니다.
쉽게 배포할 수 있습니다.무료입니다.
이를 사용하는 데 관리자 권한이 필요하지 않습니다.
일정 위젯의 스킨을 선택할 수 있습니다.Venom, Martian Red, Artic Blue, GreyScale의 4가지 테마 중에서 선택할 수 있습니다.
언어를 선택하여 월/일 이름을 확인합니다.4개 언어 지원.
긴 날짜 및 짧은 날짜 형식 지정

샘플 파일

샘플 파일

개선 사항을 제안하는 @Pʜchris, @pᴇnelilsen and @T.M. fo r 인정.

새로운 기능:

@RobinApperspach 및 @Josefixed에서 보고된 버그

이것은 제가 여기에 처음으로 올린 글입니다.엑셀에서 달력을 잃어버리는 것은 엄청난 일이었고, SiddhartRout이 만든 달력은 놀랍기 때문에 공유할 수 밖에 없었습니다.@SiddhartRoute가 정말 놀라운 달력을 만들어 주셔서 감사합니다.저는 화장품을 변경했지만, 대부분의 기본 고기는 여전히 제 사용 사례를 충족시키기 위해 약간의 변경을 가한 Sidhart의 작업입니다.

외관 변경:

모든 단추를 테두리 없는 레이블로 교체하여 Windows 10 달력과 더욱 유사하게 표시
마우스 입력/종료 시 레이블의 테두리가 표시/사라집니다.
현재 달에 해당하지 않는 날짜를 회색으로 표시했습니다.'회색'은 각 주제에 더 잘 어울리는 다른 색입니다.
테마 색상을 내 취향에 맞게 수정했습니다.테마를 순환하기 위해 클릭할 레이블이 추가되었습니다.
글꼴을 Calibri로 변경했습니다.
월/년 및 화살표 컨트롤에 마우스 항목의 색상 변경 추가
당신의 모든 색상 코드 필요에 이 사이트를 사용하세요 --> RGB 색상 코드

코드 변경 사항

속성 최적화 테마를 변경하여 테마 색상 또는 완전히 새로운 테마를 쉽게 설정하고 추가할 수 있습니다.
'ESC to exit'이 안정적으로 작동하지 않아 'X'로 교체했습니다.그것은 충돌도 많이 멈췄습니다.
현지화 작업을 제거했습니다. 필요하지 않을 것이기 때문입니다.
버튼에서 레이블로 변경하려면 프로젝트 전반에 걸쳐 필요한 경우 일부 개체 변수를 수정해야 합니다.
프로젝트 전반에 걸쳐 테마 색상을 사용할 수 있도록 RGB 값을 저장하는 데 사용되는 공개 변수가 추가되어 선택한 테마를 보다 일관되고 쉽게 적용할 수 있습니다.
숨겨진 시트에 저장된 사용자가 선택한 테마는 실행 간에 지속됩니다.
체크 표시 버튼을 제거하고 클릭 한 번으로 바로 실행할 수 있습니다.

각 테마의 스크린샷:

코드 다운로드 링크:

Win10ExcelCal.xlsm

국제 일 및 월 이름 가져오기

이 답변은 국제화와 관련된 Sid의 접근 방식에 도움이 되기 위한 것이므로 사용자 양식을 작성하는 데 충분히 명확하다고 생각되는 다른 코드 부분을 반복하지 않습니다.원한다면 Vers. 4.0에 통합된 후 삭제할 수 있습니다.

Sid의 유효한 솔루션 외에도 국제 평일 및 월 이름(c.f)을 얻기 위한 단순화된 코드를 시연합니다.기본 Excel 언어로 평일 이름을 동적으로 표시

수정된ChangeLanguage양식 모듈의 절차frmCalendar

Sub ChangeLanguage(ByVal LCID As Long)
    Dim i&
    '~~> Week Day Name
     For i = 1 To 7
         Me.Controls("WD" & i).Caption = Left(wday(i, LCID), 2)
     Next i
    '~~> Month Name
     For i = 1 To 12
         Me.Controls("M" & i).Caption = Left(mon(i, LCID), 3)
     Next i
End Sub

호출된 함수CalendarModule

이 세 가지 기능이 다음을 대체할 수 있습니다.LanguageTranslations()기능.장점: 코드가 짧고 메모리가 적으며 유지보수가 용이하며 이름이 정확합니다.

'(1) Get weekday name
Function wday(ByVal wd&, ByVal lang As String) As String
' Purpose: get weekday in "DDD" format
  wday = Application.Text(DateSerial(6, 1, wd), cPattern(lang) & "ddd")    ' the first day in year 1906 starts with a Sunday
End Function

'(2) Get month name
Function mon(ByVal mo&, ByVal lang As String) As String
' Example call: mon(12, "1031") or mon(12, "de")
  mon = Application.Text(DateSerial(6, mo, 1), cPattern(lang) & "mmm")
End Function

'(3) International patterns
Function cPattern(ByVal ctry As String) As String
' Purpose: return country code pattern for above functions mon() and wday()
' Codes: see https://msdn.microsoft.com/en-us/library/dd318693(VS.85).aspx
ctry = lcase(trim(ctry))
Select Case ctry
  Case "1033", "en-us"
    cPattern = "[$-409]" ' English (US)
  Case "1031", "de"
    cPattern = "[$-C07]" ' German
  Case "1034", "es"
    cPattern = "[$-C0A]" ' Spanish
  Case "1036", "fr"
    cPattern = "[$-80C]" ' French
  Case "1040", "it"
    cPattern = "[$-410]" ' Italian
' more ...
End Select
End Function

언급URL : https://stackoverflow.com/questions/54650417/how-can-i-create-a-calendar-input-in-vba-excel

'programing' 카테고리의 다른 글

SQL 다중 열을 다중 변수로 선택 (0)	2023.04.29
Eclipse에서 .* 파일을 표시하려면 어떻게 해야 합니까? (0)	2023.04.29
Log4net이 로그 파일에 로그를 기록하지 않음 (0)	2023.04.29
콘솔 경고가 표시되는 이유: iOS 13.2에서 WKebView를 로드할 때 [Process] kill()이 예기치 않은 오류 1을 반환했습니다. (0)	2023.04.29
이클립스 / 안드로이드 : "프로젝트에서 빌더 '안드로이드 프리 컴파일러'를 실행하는 중 오류가 발생했습니다.." (0)	2023.04.29

현재글VBA Excel에서 캘린더 입력을 만들려면 어떻게 해야 합니까?

각종 프로그래밍 정보를 다루는 블로그입니다.

ReactJS, PYTHON, wordpress, json, C, Excel, Android, Git, SWIFT, MariaDB, mongodb, asp.net, spring-boot, jQuery, mysql, PowerShell, Oracle, ajax, sql-server, angularJS,

Today :
Yesterday :

megabox

VBA Excel에서 캘린더 입력을 만들려면 어떻게 해야 합니까?

VBA Excel에서 캘린더 입력을 만들려면 어떻게 해야 합니까?

'programing' 카테고리의 다른 글

'programing'의 다른글

티스토리툴바

« 2025/01 »
일	월	화	수	목	금	토
			1	2	3	4
5	6	7	8	9	10	11
12	13	14	15	16	17	18
19	20	21	22	23	24	25
26	27	28	29	30	31

VBA Excel에서 캘린더 입력을 만들려면 어떻게 해야 합니까?

VBA Excel에서 캘린더 입력을 만들려면 어떻게 해야 합니까?

'programing' 카테고리의 다른 글

'programing'의 다른글

관련글

티스토리툴바