Macro para calendario emergente en windows 10 64bits
-----------------
Buena tarde
Solicito su ayuda
Tengo este codigo para calendario emergente pero funciona en sistema de 32 bits y necesito que funcione en windows 10 de 64 bits
Option Explicit
Public ini_Fecha As Date, tb As MSForms.TextBox
Dim inProc As Boolean, CtrlMatrix(0 To 41) As New cal_Clase
'-------------------\
'by Cacho Rodríguez ||
'-------------------/
Const GWL_STYLE = -16
Const WS_CAPTION = &HC00000
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Sub UserForm_Initialize()
Dim lngWindow As Long, lFrmHdl As Long
lFrmHdl = FindWindowA(vbNullString, Me.Caption)
lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE)
lngWindow = lngWindow And (Not WS_CAPTION)
Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow)
Call DrawMenuBar(lFrmHdl)
Dim i%, iTop!, iLeft!, iHeight!, iWidth!
IHeight = 18: iWidth = 23
For i = 3 To 9
With Controls("Label" & i)
.Width = iWidth: .Left = 67 + 24 * (i - 3)
End With
Next
TextBox3.Width = Label9.Left + Label9.Width - Label3.Left
Me.Width = 2 + Label9.Left + Label9.Width + Label1.Left: DoEvents
For i = 0 To 41
With Controls.Add("Forms.TextBox.1", "tb_" & i)
Set CtrlMatrix(i).TextBoxGenérico = Controls(.Name)
iTop = 39 + 20 * Int(i / 7): iLeft = 67 + 24 * (i Mod 7)
.Left = iLeft: .Top = iTop: .Height = iHeight: .Width = iWidth
.SpecialEffect = 6: .SelectionMargin = False
.TextAlign = 2: .Locked = True
End With
Next
End Sub
Private Sub UserForm_Activate()
inProc = True
If IsDate(tb) Then
SpinButton1 = Year(tb)
SpinButton2 = Month(tb)
Else
SpinButton1 = Year(Date)
SpinButton2 = Month(Date)
End If
inProc = False
Llenar_calendario
End Sub
Private Sub SpinButton1_Change()
If Not inProc Then Llenar_calendario
End Sub
Private Sub SpinButton2_Change()
If inProc Then Exit Sub
inProc = True
On Error Resume Next
Select Case SpinButton2
Case 0: SpinButton2 = 12: SpinButton1 = SpinButton1 - 1
Case 13: SpinButton2 = 1: SpinButton1 = SpinButton1 + 1
End Select
On Error GoTo 0
inProc = False
Llenar_calendario
End Sub
Private Sub TextBox4_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
inProc = True
SpinButton1 = Year(Date)
SpinButton2 = Month(Date)
inProc = False
Llenar_calendario
End Sub
Private Sub Llenar_calendario()
Dim i%
ini_Fecha = DateSerial(SpinButton1, SpinButton2, 1)
TextBox3 = StrConv(Format(ini_Fecha, "mmmm / yyyy"), vbProperCase)
ini_Fecha = ini_Fecha - Weekday(ini_Fecha) + 1
If Month(ini_Fecha) = SpinButton2 Then ini_Fecha = ini_Fecha - 7
For i = 0 To 41
Controls("tb_" & i) = Day(ini_Fecha + i)
If ini_Fecha + i = Date Then
Controls("tb_" & i).BackColor = vbGreen
Else
Controls("tb_" & i).BackColor = Label3.BackColor
End If
If Month(ini_Fecha + i) = SpinButton2 Then
Controls("tb_" & i).BackStyle = 1
Else
Controls("tb_" & i).BackStyle = 0
End If
Next
If IsDate(tb) Then
If Year(CDate(tb)) = SpinButton1 And Month(CDate(tb)) = SpinButton2 Then
Controls("tb_" & (CDate(tb) - ini_Fecha)).BackColor = vbRed
End If
End If
End Sub
2 Respuestas
Respuesta de Julián González Cabarcos
Respuesta de Joaom Manuel


