Solved

Access 2003 module not working on Vista?

Posted on 2009-05-13
4
272 Views
Last Modified: 2012-05-06
Does anyone know why the attached code works on XP with Access 2003 and not on Vista with Access 2003?

Any help would be much appreciated.

Option Compare Database

Option Explicit
 

Private Const conGraphiixFolder As String * 11 = "\InterFace\"
 

Public Declare Function SetWindowRgn Lib "user32" ( _

                ByVal hWnd As Long, _

                    ByVal hRgn As Long, _

                        ByVal bRedraw As Boolean) As Long

                        

                 

Public Declare Function DeleteObject Lib "gdi32" ( _

                ByVal hObject As Long) As Long

                

                

Private Declare Function CreateCompatibleDC Lib "gdi32" ( _

                    ByVal hDC As Long) As Long

 

Private Declare Function SelectObject Lib "gdi32" ( _

                    ByVal hDC As Long, _

                        ByVal hgdiObj As Long) As Long
 
 

Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" ( _

                    ByVal hdiObj As Long, _

                        ByVal cbBuffer As Long, _

                            lpvObject As Any) As Long

 

Private Declare Function CreateRectRgn Lib "gdi32" ( _

                    ByVal nLeftRect As Long, _

                        ByVal nTopRect As Long, _

                            ByVal nRightRect As Long, _

                                ByVal nBottomRect As Long) As Long
 
 

Private Declare Function CombineRgn Lib "gdi32" ( _

                    ByVal hRgnDest As Long, _

                        ByVal hRgnSrc1 As Long, _

                            ByVal hRgnSrc2 As Long, _

                                ByVal fnCombineMode As Long) As Long
 
 

Private Declare Function DeleteDC Lib "gdi32" ( _

                    ByVal hDC As Long) As Long
 

Private Declare Function GetPixel Lib "gdi32" ( _

                    ByVal hDC As Long, _

                        ByVal nXPos As Long, _

                            ByVal nYPos As Long) As Long
 
 

Private Type typPicStructure

    bmType As Long

    bmWidth As Long

    bmHeight As Long

    bmWidthBytes As Long

    bmPlanes As Integer

    bmBitsPixel As Integer

    bmBits As Long

End Type
 

Private Const RGN_OR As Long = 4
 

Public Function fInitFormShape( _

                    frm As Form, _

                        stPictureName As String, _

                            TransparentColor As Long, _

                                Optional FolderPath As String, _

                                    Optional IndexCollection As Boolean) As Boolean

                            

'// dimension variables

Dim f As Form

Dim objBitmap As StdPicture

Dim hRgn As Long
 
 

'// in the event of an error process to our

'// predefined error handler

On Error GoTo Err_finitformshape
 

    '// set the new picture to scan

    Set objBitmap = fLoadShapedPicture(frm, stPictureName)

    

    '// first check if the image is found to avoid

    '// any errors down the line, if the image to be used

    '// is not a valid one then exit the function

    If objBitmap Is Nothing Then Exit Function

    

    '// create object instance

    '// of the form to be shaped

    Set f = frm

        

    '// reference the created instance

    With f

                

        '// function to create shaped region region

        '// and return the handle to the new shaped region

        '// which resides in the system's memory buffer

        hRgn = fCreateShapedRegion(objBitmap, TransparentColor)

    

        '// set the new shaped region of our form

        SetWindowRgn .hWnd, hRgn, True

        

        fInitFormShape = True

        

    End With

        
 

Exit_finitformshape:

    '// clean up

    Set f = Nothing

    Set objBitmap = Nothing
 

    '// delete region from memory

    DeleteObject hRgn

    

    Exit Function
 

Err_finitformshape:

    '// notify user of error

    MsgBox Err.NUMBER & " : " & Err.Description, vbOKOnly, "Microsoft Access Error"

    '// resume to exit the funtion

    Resume Exit_finitformshape

    

End Function
 
 

Private Function fFileExists(stFileName) As Boolean
 

'// dimension variable(s)

Dim objFSO As Object

    

    '// create FileSystemObject

    Set objFSO = CreateObject("Scripting.FileSystemObject")

    

    '// return True if file is found

    '// return False if not

    fFileExists = objFSO.FileExists(stFileName)

            

    '// clean up

    Set objFSO = Nothing

    

End Function
 

Private Function fLoadShapedPicture(frm As Form, PictureName As String) As StdPicture
 

'// dimension varible(s)

Dim stBitmapPath  As String

Dim iWidth As Integer

Dim iHeight As Integer
 

    '// assign picture name & path

    stBitmapPath = CurrentProject.Path & conGraphiixFolder & PictureName

    

    '// check for file

    If fFileExists(stBitmapPath) Then

    

        '// reference the background image control

        With frm.Controls("imgFormBG")

        

            '// load the picture to the form's

            '// background image control

            .Picture = stBitmapPath

            

            '// move image control to align to form

            '// if you ommit this you will some parts of

            '// image display the transparent color

            .top = 10

            .Left = 10

            

            '// get image dimensions

            iWidth = .ImageWidth

            iHeight = .ImageHeight

            

            '// rezise the form to match picture

            .Parent.InsideWidth = iWidth

            .Parent.InsideHeight = iHeight + 10

            

            '// resize image control to match image

            .Width = iWidth

            .Height = iHeight

            

        End With

        

        '// load and return the picture data

        Set fLoadShapedPicture = LoadPicture(stBitmapPath)

        

    Else

    

        '// notify user image was not found

        MsgBox "The background image for this form was not found.", vbOKOnly + vbInformation

    

    End If
 

End Function
 

Private Property Get fCreateShapedRegion( _

                        BitmapPicture As StdPicture, _

                            TransColor As Long) As Long
 

'// dimension variable(s)

Dim hRgn As Long

Dim tmpRgn As Long

Dim lngRow As Integer

Dim lngCol As Integer

Dim lngPosition As Integer

Dim hDC As Long

Dim pic As typPicStructure

Dim lngTransColor As Long
 

    '// assign transparent color

    lngTransColor = TransColor
 

    '// create a new memory DC(Device Context),

    '// where we will scan the picture

    hDC = CreateCompatibleDC(0)

    

    '// if the DC exist process procedure

    If hDC Then

    

        '// let the new DC select the Picture

        SelectObject hDC, BitmapPicture

        

        '// get the picture dimensions

        GetObject BitmapPicture, Len(pic), pic

        

        '// create a new empty rectangular region using the

        hRgn = CreateRectRgn(0, 0, pic.bmWidth, pic.bmHeight)

        

        '// scan the picture pixel by pixel from top to bottom

        For lngRow = 0 To pic.bmHeight

            

            '// scan the picture pixel by pixel from left to right

            For lngCol = 0 To pic.bmWidth
 

                '// scan and skip non-transparent pixels

                While lngCol <= pic.bmWidth And GetPixel(hDC, lngCol, lngRow) <> lngTransColor

                    

                    '// add 1 to the variable lngCol

                    '// and we move to the next pixel

                    lngCol = lngCol + 1

                

                Wend

                

                '// remember the position of the first transparent pixel

                lngPosition = lngCol

                

                '// scan a line for transparent pixels

                While lngCol <= pic.bmWidth And GetPixel(hDC, lngCol, lngRow) = lngTransColor

                    

                    '// add 1 to the variable lngCol

                    '// and move to the next pixel

                    lngCol = lngCol + 1

                

                Wend

                

                If lngPosition < lngCol Then

                

                    '// create a new temporary transparent region and return it's handle

                    tmpRgn = CreateRectRgn(lngPosition, lngRow, lngCol, lngRow + 1)

                    

                    '// combine the two regions

                    CombineRgn hRgn, hRgn, tmpRgn, RGN_OR

                    

                    '// release memory, delete temporary region

                    DeleteObject tmpRgn

                    

                End If

                

            Next lngCol

        Next lngRow

        

        '// return the handle to the new shaped region

        fCreateShapedRegion = hRgn

        

        '// release memory by deleting the hDc

        DeleteObject SelectObject(hDC, BitmapPicture)

        

    End If

    

    '// clean up, release memory by deleting the created DC

    DeleteDC hDC

    

End Property

Open in new window

0
Comment
Question by:weedavie
  • 2
4 Comments
 
LVL 65

Expert Comment

by:rockiroads
ID: 24373872
Im wondering whether you have hit the problem identified here
http://stackoverflow.com/questions/144774/why-does-getwindowrgn-fail-on-vista

0
 
LVL 38

Accepted Solution

by:
puppydogbuddy earned 500 total points
ID: 24374067
Does the code intract with the ms graphics filters? If so, then they are not installed when you only install Access, and may not be installed.


Take your Office CD and do a custom install;
- expand Office Shared Features
- expand converters and filters, install them.
0
 
LVL 1

Author Comment

by:weedavie
ID: 24430951
Apologies for not replying sooner, I haven't had an opportunity to test your suggestions.
I'll give it a go this afternoon / tomorrow.

Many thanks.

David
0
 
LVL 1

Author Closing Comment

by:weedavie
ID: 31580916
Many thanks, sorry for the late reply
0

Featured Post

How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

Join & Write a Comment

Introduction When developing Access applications, often we need to know whether an object exists.  This article presents a quick and reliable routine to determine if an object exists without that object being opened. If you wanted to inspect/ite…
QuickBooks® has a great invoice interface that we were happy with for a while but that changed in 2001 through no fault of Intuit®. Our industry's unit names are dictated by RUS: the Rural Utilities Services division of USDA. Contracts contain un…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
In Microsoft Access, learn the trick to repeating sub-report headings at the top of each page. The problem with sub-reports and headings: Add a dummy group to the sub report using the expression =1: Set the “Repeat Section” property of the dummy…

707 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now