patriciaxxx
Programmer
I have an MS ACCESS 2002 database with a UserForm code as follows
And a Class module code as follows
Problems are
When I compile the code the UserForm gives compile error 'Invalid use of property' on the following line
And i get Runtime Error 13 Type Mismatch on the following line
I'm not sure what else might be wrong with the code because I can't get past these errors.
I have attached a small sample db which may help simplify things, or not.
Any help would be much appreciated.
Code:
Option Compare Database
Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type PICTDESC
Size As Long
Type As Long
#If VBA7 Then
hPic As LongPtr
hPal As LongPtr
#Else
hPic As Long
hPal As Long
#End If
End Type
#If VBA7 Then
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As LongPtr, IPic As IPicture) 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 GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As Long, ByVal bErase As Long) As Long
Private Declare PtrSafe Function MessageBeep Lib "user32" (ByVal wType As Long) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function PlaySoundAPI Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As LongPtr, ByVal dwFlags As Long) As Long
Private lFrmHwnd As LongPtr
#Else
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Long, ByVal bErase As Long) As Long
Private Declare Function MessageBeep Lib "user32" (ByVal wType As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function PlaySoundAPI Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
Private lFrmHwnd As Long
#End If
Private Const PICTYPE_BITMAP = &H1
Private Const SRCCOPY = &HCC0020
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const SND_ASYNC = &H1
Private Const SND_FILENAME = &H20000
Private Const SND_LOOP = &H8
Private Const SND_PURGE = &H40
'Module level variables
Private oCol As Collection
Private oPic As Object
Private bScore As Boolean
Private bExit As Boolean
Private bAbort As Boolean
Private InitialFormLeft As Single
Private InitialFormTop As Single
Private lCounter As Long
Private lTotalImageParts As Long
Private lColumns As Long
Private lRows As Long
Private sLevel As String
Private sUserName As String
Private vFileName As Variant
Private Sub UserForm_Initialize()
sUserName = InputBox("Please, enter your name", "Player Name")
If Len(sUserName) = 0 And StrPtr(sUserName) <> 0 Then MsgBox "You must enter a player name", vbInformation: End
If StrPtr(sUserName) = 0 Then End
End Sub
Private Sub UserForm_Activate()
StartUpPosition = 2
InitialFormLeft = Me.Left
InitialFormTop = Me.Top
Set oPic = frameSourcePic.Picture
lFrmHwnd = FindWindow(vbNullString, Me.Caption)
frameSourcePic.BorderStyle = fmBorderStyleSingle
frameSourcePic.BorderColor = vbYellow
With Me.ComboLevel
.AddItem "Easy " & " (3x6 Parts)"
.AddItem "low " & " (3x8 Parts)"
.AddItem "Medium " & "(4x10 Parts)"
.AddItem "High " & "(6x13 Parts)"
.ListIndex = 0
End With
lblTimer.Caption = ""
CBtnAbort.Enabled = False
Call EnableControls(True)
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If MsgBox("Are you sure you want to quit ?", vbQuestion + vbYesNo) = vbNo Then
Cancel = 1
Exit Sub
End If
bExit = True
End Sub
'***************************************************************************************************
'Event handlers of form's controls
Private Sub ComboLevel_Change()
Select Case True
Case UCase(ComboLevel.Value) Like "EASY*"
lRows = 3
lColumns = 6
Case UCase(ComboLevel.Value) Like "LOW*"
lRows = 3
lColumns = 8
Case UCase(ComboLevel.Value) Like "MEDIUM*"
lRows = 4
lColumns = 10
Case UCase(ComboLevel.Value) Like "HIGH*"
lRows = 6
lColumns = 13
End Select
sLevel = UCase(ComboLevel.Value)
End Sub
Private Sub CBtnAbort_Click()
Call EnableControls(False)
bAbort = True
End Sub
Private Sub CBtnClose_Click()
Unload Me
End Sub
Private Sub CBtnNewPic_Click()
On Error GoTo errHandler
'Dim varFile As Variant
'Dim strSQL As String
With Application.FileDialog(dialogType:=3)
.AllowMultiSelect = False 'Allow the user to make multiple selections in the dialog box.
' ' .Title = "Browse" 'Set the title of the dialog box.
' .Filters.Clear 'Clear out the current filters and add our own.
' .Filters.Add Description:="Images", Extensions:="*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png", Position:=1 'Make this filter the first item in the list.
' .Filters.Add Description:="All Files", Extensions:="*.*"
If .Show = True Then 'Show the dialog box.
vFileName = .SelectedItems(1)
Else
'Cancel pressed.
End If
End With
' vFileName = Application.GetOpenFilename(FileFilter:="Picture Files (*.gif;*.jpg;*.jpeg;*.bmp),*.gif;*.jpg;*.jpeg;*.bmp", _
Title:="Select Picture")
If vFileName <> False Then
frameSourcePic.Picture = LoadPicture(vFileName)
Call DeletePreviousImages
End If
Exit Sub
errHandler:
MsgBox Err.Description
End Sub
Private Sub CBtnStart_Click()
Dim oImagePartCls As oImagePartCls
Dim oTextBox As MSForms.TextBox
Dim tRect As RECT
Dim tPt1 As POINTAPI, tPt2 As POINTAPI
Dim BasePicframeHwnd As Long
Dim lImgPartWidth As Long, lImgPartHeight As Long
Dim lImgPartLeft As Long, lImgPartTop As Long
Dim lColumn As Long, lRow As Long
Dim lControlCounter As Long
bScore = False
bAbort = False
Call EnableControls(False)
BasePicframeHwnd = frameSourcePic.[_GethWnd]
GetWindowRect BasePicframeHwnd, tRect
tPt1.x = tRect.Left
tPt1.y = tRect.Top
tPt2.x = tRect.Right
tPt2.y = tRect.Bottom
If IsFormClipped(tPt1, tPt2) Then
Me.Move InitialFormLeft, InitialFormTop
GetWindowRect BasePicframeHwnd, tRect
DoEvents
End If
Call DeletePreviousImages
'add the image parts controls
Set oCol = New Collection
For lColumn = 1 To lRows
For lRow = 1 To lColumns
lControlCounter = lControlCounter + 1
Set oImagePartCls = New oImagePartCls
Set oImagePartCls.GetForm = Me
Set oImagePartCls.PicturePart = Controls.Add("Forms.Image.1", "Image" & lControlCounter)
With oImagePartCls.PicturePart
.PictureSizeMode = fmPictureSizeModeStretch
.BorderStyle = fmBorderStyleSingle
.BorderColor = vbYellow
.MousePointer = fmMousePointerSizeAll
.Width = frameSourcePic.Width / lRows
.Height = frameSourcePic.Height / lColumns
.Left = frameSourcePic.Left + (((lRow - 1) * (frameSourcePic.Width + 20) / lRows))
.Top = 20 + (((lColumn - 1) * (frameSourcePic.Height + 20) / lColumns))
.ZOrder 0
.ControlTipText = "Drag the Picture down to its corresponding empty frame below"
End With
oCol.Add oImagePartCls
Next
Next
'add the textbox holder controls
lControlCounter = 0
For lRow = 1 To lColumns
For lColumn = 1 To lRows
lControlCounter = lControlCounter + 1
Set oTextBox = Controls.Add("Forms.TextBox.1", "TextBox" & lControlCounter)
With oTextBox
.Enabled = False
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.SpecialEffect = fmSpecialEffectEtched
.Left = frameSourcePic.Left + frameSourcePic.Width + 80 + lColumn * frameSourcePic.Width / lRows
.Top = frameSourcePic.Top + (lRow - 1) * frameSourcePic.Height / lColumns
.Width = oImagePartCls.PicturePart.Width
.Height = oImagePartCls.PicturePart.Height
.ZOrder 1
End With
Next
Next
'randomly shuffle the image part controls
lTotalImageParts = lColumns * lRows
Me.Tag = lTotalImageParts
ReDim iArray(1 To lTotalImageParts) As Integer '
Call ShufflePictureParts(lTotalImageParts, iArray)
'set the Pic property of each image part
lControlCounter = 0
For lColumn = 1 To lColumns
For lRow = 1 To lRows
With tRect
lImgPartWidth = (.Right - .Left) / lRows
lImgPartHeight = (.Bottom - .Top) / lColumns
lImgPartLeft = .Left + ((lRow - 1) * lImgPartWidth)
lImgPartTop = .Top + ((lColumn - 1) * lImgPartHeight)
End With
lControlCounter = lControlCounter + 1
Controls("image" & iArray(lControlCounter)).Tag = Controls("TextBox" & lControlCounter).Name
CropPic lImgPartWidth, lImgPartHeight, lImgPartLeft, lImgPartTop, Me.Controls("image" & iArray(lControlCounter))
InvalidateRect lFrmHwnd, 0, 0
Next
Next
frameSourcePic.BorderStyle = fmBorderStyleSingle
frameSourcePic.BorderColor = vbYellow
Call UpdateTimerLabel
End Sub
'*************************************************************************************************
' Private Supporting routines
Private Sub UpdateTimerLabel()
Dim ss As Long
Dim mm As Long
Dim hh As Long
Dim sglTimer As Single
Const WAV_FILE As String = "C:\WINDOWS\MEDIA\tada.WAV"
sglTimer = Timer
Do
ss = Int(Timer - sglTimer)
If ss = 60 Then mm = mm + 1: ss = 0: sglTimer = Timer
If mm = 60 Then hh = hh + 1: mm = 0: sglTimer = Timer
lblTimer.Caption = Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs"
DoEvents
Loop Until bExit Or bScore Or bAbort
If bScore Then
PlaySoundAPI WAV_FILE, ByVal 0&, SND_FILENAME Or SND_LOOP Or SND_ASYNC
If MsgBox("Congratulations " & sUserName & " !!" & vbCrLf & vbCrLf & _
"You scored in : " & Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs" & vbCrLf & _
"Do you want to save this score to your scores history ?", vbQuestion + vbYesNo) = vbYes Then
Call SaveTheScore(hh, mm, ss)
End If
PlaySoundAPI WAV_FILE, ByVal 0&, SND_FILENAME Or SND_PURGE
End If
lblTimer.Caption = ""
Call EnableControls(True)
Call DeletePreviousImages
Set frameSourcePic.Picture = oPic
End Sub
Private Sub SaveTheScore(ByVal hh As Long, mm As Long, ByVal ss As Long)
Dim bProtection As Boolean
' bProtection = ActiveSheet.ProtectContents
' If bProtection Then
' ActiveSheet.Unprotect
' End If
' With Cells(Cells.Rows.Count, 1).End(xlUp)
' .Offset(1, 0) = sUserName
' .Offset(1, 1) = Now
' .Offset(1, 2) = IIf(vFileName = Empty, "Default Picture", vFileName)
' .Offset(1, 3) = sLevel
' .Offset(1, 4) = Format(hh, "00") & " Hrs : " & Format(mm, "00") & " mins : " & Format(ss, "00") & " Secs"
' End With
' If bProtection Then
' ActiveSheet.Protect
' End If
' ThisWorkbook.Save
End Sub
Private Sub CropPic(ByVal nWidth, ByVal nHeight, ByVal x, ByVal y, DestCtrl As Image)
#If VBA7 Then
Dim hdc, hDCMemory, hBmp, OldBMP As LongPtr
#Else
Dim hdc, hDCMemory, hBmp, OldBMP As Long
#End If
Dim IID_IDispatch As GUID
Dim uPicinfo As PICTDESC
Dim IPic As IPicture
hdc = GetDC(0)
hDCMemory = CreateCompatibleDC(hdc)
hBmp = CreateCompatibleBitmap(hdc, nWidth, nHeight)
OldBMP = SelectObject(hDCMemory, hBmp)
Call BitBlt(hDCMemory, 0, 0, nWidth, nHeight, hdc, x, y, SRCCOPY)
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With uPicinfo
.Size = Len(uPicinfo)
.Type = PICTYPE_BITMAP
.hPic = hBmp
.hPal = 0
End With
OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
Set DestCtrl.Picture = IPic
ReleaseDC 0, hdc
DeleteObject OldBMP
DeleteDC hDCMemory
End Sub
Private Sub ShufflePictureParts(ByVal NumOfPics, ByRef Arr() As Integer)
Dim i As Integer, lRandomNumber As Integer, temp As Integer
For i = 1 To NumOfPics
Arr(i) = i
Next i
Randomize Timer
For i = 1 To NumOfPics
lRandomNumber = Int(Rnd * (UBound(Arr) - LBound(Arr) + 1) + LBound(Arr))
temp = Arr(i)
Arr(i) = Arr(lRandomNumber)
Arr(lRandomNumber) = temp
Next i
End Sub
Private Sub DeletePreviousImages()
Dim i As Long
Dim oCtl As Control
On Error Resume Next
If Not oCol Is Nothing Then
For i = 1 To oCol.Count
Controls.Remove Controls("Image" & i).Name
Next
For Each oCtl In Me.Controls
If TypeName(oCtl) = "TextBox" Then
Controls.Remove oCtl.Name
End If
If TypeName(oCtl) = "Image" Then
Controls.Remove oCtl.Name
End If
Next
End If
End Sub
Private Function IsFormClipped(tLeftTop As POINTAPI, tRightBottom As POINTAPI) As Boolean
IsFormClipped = _
tLeftTop.x <= 1 Or tLeftTop.y <= 1 Or tRightBottom.x >= GetSystemMetrics(SM_CXSCREEN) - 1 Or _
tRightBottom.y >= GetSystemMetrics(SM_CYSCREEN) - 1
End Function
Private Sub EnableControls(ByVal Bool As Boolean)
CBtnAbort.Enabled = Not Bool
CBtnNewPic.Enabled = Bool
CBtnStart.Enabled = Bool
ComboLevel.Enabled = Bool
End Sub
'*************************************************************************************************************
' Public Methods
Public Sub MsgbBeep()
MessageBeep &H40&
End Sub
Public Sub FlashImagePart(ByVal Img As Image, ByVal ct As MSForms.TextBox)
Dim i As Long
Dim t As Single
For i = 0 To 1
Img.BorderStyle = fmBorderStyleSingle
Img.BorderColor = vbRed
t = Timer
Do
DoEvents
Loop Until Timer - t >= 0.1
Img.BorderStyle = fmBorderStyleNone
Next
End Sub
Public Sub CheckIfSuccess()
Dim oCtrl As Control
Dim lCounter As Long
For Each oCtrl In Me.Controls
If TypeName(oCtrl) = "Image" Then
If InStr(1, oCtrl.Tag, "Success") Then
lCounter = lCounter + 1
If lCounter = lTotalImageParts Then
bScore = True
End If
End If
End If
Next
End Sub
And a Class module code as follows
Code:
Option Compare Database
Option Explicit
Public WithEvents PicturePart As MSForms.Image
Private initialY As Single, initialX As Single
Private oUForm As Object
Public Property Set GetForm(ByVal vNewValue As Object)
Set oUForm = vNewValue
End Property
Private Sub PicturePart_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
initialX = x: initialY = y
PicturePart.ZOrder 0
End Sub
Private Sub PicturePart_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Dim oCtrl As Control
Static oPrevCtrl As Control
If Button = 1 Then
With PicturePart
.Move .Left + (x - initialX), .Top + (y - initialY)
For Each oCtrl In oUForm.Controls
If TypeName(oCtrl) = "TextBox" Then
If Not oPrevCtrl Is Nothing Then
oPrevCtrl.Enabled = False
oPrevCtrl.BackStyle = fmBackStyleTransparent
oPrevCtrl.SpecialEffect = fmSpecialEffectEtched
End If
If .Left + .Width / 2 > oCtrl.Left And .Left + .Width / 2 < oCtrl.Left + oCtrl.Width _
And .Top + .Height / 2 > oCtrl.Top And .Top + .Height / 2 < oCtrl.Top + oCtrl.Height Then
oCtrl.Enabled = True
oCtrl.BackStyle = fmBackStyleOpaque
oCtrl.SpecialEffect = 6
oCtrl.BackColor = vbWhite
Set oPrevCtrl = oCtrl
Exit For
End If
End If
Next
End With
End If
End Sub
Private Sub PicturePart_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
Dim oCtrl As Control
For Each oCtrl In oUForm.Controls
If TypeName(oCtrl) = "TextBox" Then
With PicturePart
If .Left + .Width / 2 > oCtrl.Left And .Left + .Width / 2 < oCtrl.Left + oCtrl.Width _
And .Top + .Height / 2 > oCtrl.Top And .Top + .Height / 2 < oCtrl.Top + oCtrl.Height Then
.Move oCtrl.Left, oCtrl.Top
PicturePart.BorderStyle = fmBorderStyleNone
Call oUForm.FlashImagePart(PicturePart, oCtrl)
If InStr(1, PicturePart.Tag, oCtrl.Name) Then
PicturePart.Tag = PicturePart.Tag & "Success"
Else
If Right(PicturePart.Tag, 7) = "Success" Then
PicturePart.Tag = Mid(PicturePart.Tag, 1, Len(PicturePart.Tag) - 7)
End If
End If
Call oUForm.MsgbBeep
Call oUForm.CheckIfSuccess
Exit For
End If
End With
End If
Next
End Sub
Problems are
When I compile the code the UserForm gives compile error 'Invalid use of property' on the following line
Code:
Set DestCtrl.Picture = IPic
Code:
CropPic lImgPartWidth, lImgPartHeight, lImgPartLeft, lImgPartTop, Me.Controls("image" & iArray(lControlCounter))
I'm not sure what else might be wrong with the code because I can't get past these errors.
I have attached a small sample db which may help simplify things, or not.
Any help would be much appreciated.