Forum - Συναρτήσεις Κώδικας που δεν τρέχει σε 64bit περιβάλλον

Forum (https://www.ms-office.gr/forum/)

- Access - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/access-erotiseis-apantiseis/)

- - [ Συναρτήσεις ] Κώδικας που δεν τρέχει σε 64bit περιβάλλον (https://www.ms-office.gr/forum/access-erotiseis-apantiseis/5369-kodikas-poy-den-trexei-se-64bit-periballon.html)

Κώδικας που δεν τρέχει σε 64bit περιβάλλον

Χρησιμοποιώ αυτό τον κώδικα για αρχική splash screen με κωδικό που έχει δημιουργήσει ο Τάσος.Όμως αναβάθμισα την access σε 2010 από 2007 και από τότε μου βγάζει μήνυμα ότι δεν λειτουργεί σε συστήματα 64bit.Υπάρχει λύση;

Option Compare Database
Option Explicit
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOMOVE = &H2
Public Const SPI_GETWORKAREA = 48
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

'Private Declare Function SystemParametersInfo Lib "user32" Alias _
"SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, _
ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long

Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As Rect) As Long

Private Declare Function Movewindow Lib "user32" Alias "MoveWindow" (ByVal hWnd As Long, _
ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long

Public Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal X As Long, _
ByVal Y As Long, _
ByVal cx As Long, _
ByVal cy As Long, _
ByVal wFlags As Long) As Long

Public Sub CenterForm(wHandle&)
Dim oRect As Rect, scrnW&, scrnH&, Vwidth&, Vheight&, Vleft&, Vtop&
If wHandle <> 0 Then
SystemParametersInfo SPI_GETWORKAREA, 0, oRect, 0
scrnW = Abs(oRect.Right - oRect.Left)
scrnH = Abs(oRect.Top - oRect.Bottom)
GetWindowRect wHandle, oRect
Vwidth = Abs(oRect.Right - oRect.Left)
Vheight = Abs(oRect.Top - oRect.Bottom)
Vleft = (scrnW - Vwidth) / 2
Vtop = (scrnH - Vheight) / 2
Movewindow wHandle, Vleft, Vtop, Vwidth, Vheight, True
End If
End Sub

και επίσης

Option Compare Database
Option Explicit
Public Const IDC_ARROW = 32512&
Public Const IDC_SIZEALL = 32646&
Public Const GWL_EXSTYLE = (-20)
Public Const WS_EX_LAYERED = &H80000
Public Const WS_EX_TRANSPARENT = &H20&
Public Const LWA_ALPHA = &H2&
Public Const SW_Hide = 0
Public Const SW_SHOWNORMAL = 1
Public Const SW_SHOWMAXIMIZED = 3
Public IsRunning As Boolean
Public Declare Function ShowAccHwnd Lib "user32" Alias "ShowWindow" _
(ByVal hWnd As Long, ByVal nCmdShow As Long) As Long

Public Declare Function LoadCursorBynum Lib "user32" Alias "LoadCursorA" _
(ByVal hInstance As Long, ByVal lpCursorName As Long) As Long

Public Declare Function LoadCursorFromFile Lib "user32" Alias _
"LoadCursorFromFileA" (ByVal lpFileName As String) As Long

Public Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

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 SetLayeredWindowAttributes Lib "user32" _
(ByVal hWnd As Long, ByVal crey As Byte, ByVal bAlpha As Byte, _
ByVal dwFlags As Long) As Long

Public Sub FadeMe(frmhWnd&, F_In As Boolean, iVal%, Optional FinalOpacity As Integer = 255)
Dim LStyle&, i%
LStyle = GetWindowLong(frmhWnd, GWL_EXSTYLE)
SetWindowLong frmhWnd, GWL_EXSTYLE, LStyle Or WS_EX_LAYERED
Select Case F_In
Case True
For i = 0 To FinalOpacity Step 5
SetLayeredWindowAttributes frmhWnd, 0, CByte(i), LWA_ALPHA
DoEvents
Sleep iVal
Next
Case 0
If iVal = 0 Then
SetLayeredWindowAttributes frmhWnd, 0, CByte(0), LWA_ALPHA
Else
For i = FinalOpacity To 0 Step -5
SetLayeredWindowAttributes frmhWnd&, 0, CByte(i), LWA_ALPHA
DoEvents
Sleep iVal
Next
End If
End Select
End Sub

Public Function MouseCursor(CursorType As Long)
Dim lngRet As Long
lngRet = LoadCursorBynum(0&, CursorType)
lngRet = SetCursor(lngRet)
End Function

Public Function PointM(strPathToCursor As String)
Dim lngRet As Long
lngRet = LoadCursorFromFile(strPathToCursor)
lngRet = SetCursor(lngRet)
End Function

'Code From Microsoft help with some changes
Public Function ChangeProperty(strPropName As String, _
varPropType As Variant, _
varPropValue As Variant) As Integer

Dim dbs As Object, prp As Variant
Const conPropNotFoundError = 3270

Set dbs = CurrentDb
On Error GoTo Change_Err
dbs.Properties(strPropName) = varPropValue
ChangeProperty = varPropValue

Change_Bye:
Exit Function

Change_Err:
If Err = conPropNotFoundError Then ' Property not found.
Set prp = dbs.CreateProperty(strPropName, _
varPropType, varPropValue)
dbs.Properties.Append prp
Resume Next
Else
' Unknown error.
ChangeProperty = 2
Resume Change_Bye
End If
End Function

Public Function OpenForm()
Dim wh&, frmName$
frmName = "frmSplash"
DoCmd.OpenForm frmName, , , , , acHidden
End Function

Καλησπέρα Σάκη,

Στις δηλώσεις σου χρησιμοποίησε το PtrSafe.

Για παράδειγμα

Public Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As LongPtr

Ευχαριστώ.

Έκανα τις αλλαγές και τώρα μου χτυπάει εδώ ....... type mismatch

Public Sub FadeMe(frmhWnd&, F_In As Boolean, iVal%, Optional FinalOpacity As Integer = 255)
Dim LStyle&, i%
LStyle = GetWindowLong(frmhWnd, GWL_EXSTYLE)
SetWindowLong frmhWnd, GWL_EXSTYLE, LStyle Or WS_EX_LAYERED
Select Case F_In
Case True
For i = 0 To FinalOpacity Step 5
SetLayeredWindowAttributes frmhWnd, 0, CByte(i), LWA_ALPHA
DoEvents
Sleep iVal
Next
Case 0
If iVal = 0 Then
SetLayeredWindowAttributes frmhWnd, 0, CByte(0), LWA_ALPHA
Else
For i = FinalOpacity To 0 Step -5
SetLayeredWindowAttributes frmhWnd&, 0, CByte(i), LWA_ALPHA
DoEvents
Sleep iVal
Next
End If
End Select
End Sub

Καλήμερα,

Άλλαξε τον τύπο της μεταβλητής LStyle σε LongPtr.

Ευχαριστώ.

Δεν την δέχεται, χτυπάει.

Καλησπέρα, επανέρχομαι γιατί ότι και να δοκίμασα δεν βρήκα λύση....άλλαξα και την Lstyle σε LongPtr αλλά δεν δουλεύει.

Public Sub FadeMe(frmhWnd&, F_In As Boolean, iVal%, Optional FinalOpacity As Integer = 255)
Dim Lstyle&, i%
Lstyle = GetWindowLong(frmhWnd, GWL_EXSTYLE)
SetWindowLong frmhWnd, GWL_EXSTYLE, Lstyle Or WS_EX_LAYERED
Select Case F_In
Case True
For i = 0 To FinalOpacity Step 5
SetLayeredWindowAttributes frmhWnd, 0, CByte(i), LWA_ALPHA
DoEvents
Sleep iVal
Next
Case 0
If iVal = 0 Then
SetLayeredWindowAttributes frmhWnd, 0, CByte(0), LWA_ALPHA
Else
For i = FinalOpacity To 0 Step -5
SetLayeredWindowAttributes frmhWnd&, 0, CByte(i), LWA_ALPHA
DoEvents
Sleep iVal
Next
End If
End Select
End Sub

Καλησπέρα σε όλους!

Σάκη οι συναρτήσεις που χρησιμοποιείς πρέπει να έχουν αυτή τη μορφή:

Κώδικας:



'Παραδειγματικές συναρτήσεις:
 

Declare PtrSafe Function GetWindowLongPtr Lib "user32" Alias "GetWindowLongPtrA" ( _

        ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
 

Declare PtrSafe Function SetWindowLongPtr Lib "user32" Alias "SetWindowLongPtrA" ( _

        ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
 

Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" ( _

        ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long
 

Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
 

Declare PtrSafe Function MoveWindow Lib "user32" ( _

        ByVal hwnd As LongPtr, ByVal x As Long, ByVal y As Long, _

        ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
 

Declare PtrSafe Function SetWindowPos Lib "user32" ( _

        ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, _

        ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Μπορείς κάνοντας αναζήτηση (CTRL + F στον περιηγητή σου ) στο μήνυμα: http://www.ms-office.gr/forum/access...html#post30363 να βρεις και να πάρεις οποιαδήποτε συνάρτηση στην κατάλληλη μορφή.

Δε θα συνιστούσα τη χρήση Office 64 σε συνδυασμό με αυτοματισμούς αυτού του είδους.

Καλή συνέχεια!

Με εκτίμηση

Τάσος

Τάσο ευχαριστώ για τις συμβουλές.Ότι και να δοκίμασα, ότι αλλαγές έκανα δεν βοήθησαν.
Ακόμη μου βγάζει σφάλμα.

Επισυνάπτω ένα αρχείο που δυστυχώς δεν μπορώ να το δοκιμάσω σε περιβάλλον 64bit.

Δοκίμασε και πες μας τι έγινε.

Τάσος

Καλησπέρα,μετακινείται αλλά δεν αλλάζει μέγεθος