Access - Ερωτήσεις / Απαντήσεις Access + VBA... Εδώ δεν υπάρχουν όρια! |
| Εργαλεία Θεμάτων | Τρόποι εμφάνισης |
#1
| |||
| |||
Κώδικας που δεν τρέχει σε 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 |
#2
| |||
| |||
Καλησπέρα Σάκη, Στις δηλώσεις σου χρησιμοποίησε το PtrSafe. Για παράδειγμα Public Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As LongPtr Ευχαριστώ. |
#3
| |||
| |||
Έκανα τις αλλαγές και τώρα μου χτυπάει εδώ ....... 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 |
#4
| |||
| |||
Καλήμερα, Άλλαξε τον τύπο της μεταβλητής LStyle σε LongPtr. Ευχαριστώ. |
#5
| |||
| |||
Δεν την δέχεται, χτυπάει.
|
#6
| |||
| |||
Καλησπέρα, επανέρχομαι γιατί ότι και να δοκίμασα δεν βρήκα λύση....άλλαξα και την 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 |
#7
| ||||
| ||||
Καλησπέρα σε όλους! Σάκη οι συναρτήσεις που χρησιμοποιείς πρέπει να έχουν αυτή τη μορφή: Κώδικας: 'Παραδειγματικές συναρτήσεις: 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 Δε θα συνιστούσα τη χρήση Office 64 σε συνδυασμό με αυτοματισμούς αυτού του είδους. Καλή συνέχεια! Με εκτίμηση Τάσος
__________________ Ms-Office Development Team Ανάπτυξη επαγγελματικών εφαρμογών Τελευταία επεξεργασία από το χρήστη Tasos : 05-12-19 στις 20:29. |
#8
| |||
| |||
Τάσο ευχαριστώ για τις συμβουλές.Ότι και να δοκίμασα, ότι αλλαγές έκανα δεν βοήθησαν. Ακόμη μου βγάζει σφάλμα. |
#9
| ||||
| ||||
Επισυνάπτω ένα αρχείο που δυστυχώς δεν μπορώ να το δοκιμάσω σε περιβάλλον 64bit. Δοκίμασε και πες μας τι έγινε. Τάσος
__________________ Ms-Office Development Team Ανάπτυξη επαγγελματικών εφαρμογών |
#10
| |||
| |||
Καλησπέρα,μετακινείται αλλά δεν αλλάζει μέγεθος
|
« Προηγούμενο Θέμα
|
Επόμενο Θέμα »
| |
Παρόμοια Θέματα | ||||
Θέμα | Δημιουργός | Forum | Απαντήσεις | Τελευταίο Μήνυμα |
[Γενικά] Excel 365 64bit DatePicker | jockey17 | Excel - Ερωτήσεις / Απαντήσεις | 5 | 21-12-18 12:47 |
Κεντράρισμα φορμών και σε 64bit και σε 32bit | lefterisg | Access - Ερωτήσεις / Απαντήσεις | 0 | 15-11-17 10:34 |
Access 64bit? | γιώργοςΚ | Access - Ερωτήσεις / Απαντήσεις | 5 | 12-11-16 13:06 |
[Συναρτήσεις] Ερώτηση για συνάρτηση-περιβάλλον | aristarchosel | Excel - Ερωτήσεις / Απαντήσεις | 1 | 12-10-14 02:11 |
Τερματισμός βάσης που τρέχει στο παρασκήνιο | dimitrisp | Access - Ερωτήσεις / Απαντήσεις | 0 | 02-10-14 23:58 |
Η ώρα είναι 23:13.