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

Aunque el Excel no es lo mío, tienes que añadirle PTRSafe, por ejemplo

Private Declare PTRSafe Function

ya hice eso

y sigue dando error

Private Declare PtrSafe Function GetWindowLongptr Lib "user32" Alias "GetWindowLongptrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As LongPtr
Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

aqui en la segunda linea

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)

Lo siento, pero ya te dije que el Excel no es lo mío. Mira esto

https://docs.microsoft.com/es-es/office/vba/language/reference/user-interface-help/ptrsafe-keyword 

Por ejemplo, en Access, si elijo un mes en el combinado(no te fijes en el formato fecha, ya que lo uso para otra cosa. Cuando elijo un mes, por ejemplo, Octubre del 2021

Automáticamente

Pero, el código es distinto.

Respuesta

Sobre las API para que funcione en x64 y x32, pásame tu mail y te envío un DOC que conseguí en la WEB.

De eso no entiendo muy bien, puede que logres resolver tu problema co nel doc

Verifica y ve si puedes resolverlo. Como dije anteriormente, entiendo muy poco sobre ese detalle

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas