Solved

Powerresize fails when running on windows server 2008

Posted on 2012-03-14
28
317 Views
Last Modified: 2012-10-21
In vb6 I have used the code of Powerresize (written by Mark Gordon)  to resize an image.

On most windows versions this is working fine. However on a windows server 2008 the powerresize function results in an "overflow" error.  

The dll's (gdi32.dll and olepro32.dll which are used in this function) has version number 6.1.7600.16385
0
Comment
Question by:LeonKimman
  • 13
  • 11
28 Comments
 
LVL 15

Expert Comment

by:eemit
ID: 37720382
It seems that the error has nothing to do with the Windows version,
but with the type of image.
Please show us the line of code that the error occurs on.
0
 

Author Comment

by:LeonKimman
ID: 37720816
Following the code i've used:

When trying to perform the line "SavePicture"  it fails on a windows server 2008
(It fails to create the output.jpg )
On (for example) windows XP it is no problem
================================================================

Private Sub cmdsearchPicture_Click()
On Local Error GoTo Errorhandler

Dim strTempfile As String
Dim PicSelect As StdPicture
Dim ResizedPic As StdPicture
   
    strTempfile = App.Path & "\testfoto.jpg"          
    If Len(strTempfile) <> 0 Then
        Set PicSelect = LoadPicture(strTempfile)    
        Set ResizedPic = PowerResize(PicSelect, 70, 90)           'calling the Powerresize function
        SavePicture ResizedPic, App.Path & "\Output.jpg"        ' ****  on this point it fails

        Set ResizedPic = Nothing
        Set PicSelect = Nothing
       
        Me.imgMonteur.Picture = LoadPicture()
        Me.imgMonteur.Picture = PicSelect
       
        MsgBox "getting picture succeeded"        
    End If

Exit Sub
Errorhandler:
    MsgBox Err.Number, " ", Err.Description
End Sub

Belowe the complete code of the Powerresize function:
===================================================================
Option Explicit
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32.dll" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, ByRef lpBits As Any) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function GetObject Lib "gdi32.dll" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    bmPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, iPic As StdPicture) As Long

Private Type PictDesc
    cbSizeofStruct As Long
    picType As Long
    hImage As Long
    xExt As Long
    yExt 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 RGBtype
    B As Byte
    R As Byte
    G As Byte
End Type

Private Declare Function GetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long

Private Const DIB_RGB_COLORS = 0&
Public Const BI_RGB = 0&

Type BITMAPINFOHEADER
   biSize As Long
   biWidth As Long
   biHeight As Long
   biPlanes As Integer
   biBitCount As Integer
   biCompression As Long
   biSizeImage As Long
   biXPelsPerMeter As Long
   biYPelsPerMeter As Long
   biClrUsed As Long
   biClrImportant As Long
End Type

Type RGBQUAD
   rgbBlue As Byte
   rgbGreen As Byte
   rgbRed As Byte
   rgbReserved As Byte
End Type

Type BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
  bmiColors As RGBQUAD
End Type

'*****************************************************
'PowerResize
' Returns a resized version of Img with the new dimensions passed.
'
'Written by Mark Gordon aka msg555
'1/16/06
'Free to use/sell/whatever
'*****************************************************
Public Function PowerResize(Img As StdPicture, newWidth As Long, newHeight As Long) As StdPicture

On Error GoTo Errorhandler

    Debug.Assert Img.Type = vbPicTypeBitmap 'Image must be a bitmap
       
    Dim SrcBmp As BITMAP
    GetObject Img.Handle, Len(SrcBmp), SrcBmp
   
    Dim srcBI As BITMAPINFO
    With srcBI.bmiHeader
        .biSize = Len(srcBI.bmiHeader)
        .biWidth = SrcBmp.bmWidth
        .biHeight = -SrcBmp.bmHeight
        .biPlanes = 1
        .biBitCount = 32
        .biCompression = BI_RGB
    End With


    'Create Source Bit Array
    Dim SrcBits() As RGBQUAD
    ReDim SrcBits(0 To SrcBmp.bmWidth - 1, 0 To SrcBmp.bmHeight - 1) As RGBQUAD

    'Grab Source Bits
    Dim lDc As Long

   
    lDc = CreateCompatibleDC(0)
    GetDIBits lDc, Img.Handle, 0, SrcBmp.bmHeight, SrcBits(0, 0), srcBI, DIB_RGB_COLORS
    DeleteDC lDc

    'Create Destination Bit Array
    Dim DblDstBits() As Double
   
    ReDim DblDstBits(0 To 3, 0 To newWidth - 1, 0 To newHeight - 1) As Double

    'Multipliers
    Dim xMult As Double, yMult As Double

    xMult = newWidth / SrcBmp.bmWidth
    yMult = newHeight / SrcBmp.bmHeight

    'Traversing variables
    Dim X As Long, XX As Long
    Dim Y As Long, YY As Long
   
    'Low/High scan X/Y
    Dim lsX As Double, hsX As Double
    Dim lsY As Double, hsY As Double
   
    Dim OverlapWidth As Double
    Dim OverlapHeight As Double
    Dim Overlap As Double
   
    For X = 0 To SrcBmp.bmWidth - 1
        lsX = X * xMult
        hsX = X * xMult + xMult
        For Y = 0 To SrcBmp.bmHeight - 1
            lsY = Y * yMult
            hsY = Y * yMult + yMult
            For XX = Fix(lsX) To IIf(Fix(hsX) = hsX, Fix(hsX), Fix(hsX + 1)) - 1
                For YY = Fix(lsY) To IIf(Fix(hsY) = hsY, Fix(hsY), Fix(hsY + 1)) - 1
                    OverlapWidth = 1
                    OverlapHeight = 1
                   
                    If XX < lsX Then OverlapWidth = 1# - (lsX - XX)
                    If XX + 1# > hsX Then OverlapWidth = OverlapWidth - (XX + 1# - hsX)
                    If YY < lsY Then OverlapHeight = 1# - (lsY - YY)
                    If YY + 1# > hsY Then OverlapHeight = OverlapHeight - (YY + 1# - hsY)
                   
                    Overlap = OverlapHeight * OverlapWidth
                   
                    DblDstBits(0, XX, YY) = DblDstBits(0, XX, YY) + SrcBits(X, Y).rgbRed * Overlap
                    DblDstBits(1, XX, YY) = DblDstBits(1, XX, YY) + SrcBits(X, Y).rgbGreen * Overlap
                    DblDstBits(2, XX, YY) = DblDstBits(2, XX, YY) + SrcBits(X, Y).rgbBlue * Overlap
                    DblDstBits(3, XX, YY) = DblDstBits(3, XX, YY) + Overlap
                Next
            Next
        Next
    Next
   
    Dim DstBits() As RGBQUAD
    ReDim DstBits(0 To newWidth - 1, 0 To newHeight - 1) As RGBQUAD
   
    For X = 0 To newWidth - 1
        For Y = 0 To newHeight - 1
            DstBits(X, Y).rgbRed = Round(DblDstBits(0, X, Y) / DblDstBits(3, X, Y))
            DstBits(X, Y).rgbGreen = Round(DblDstBits(1, X, Y) / DblDstBits(3, X, Y))
            DstBits(X, Y).rgbBlue = Round(DblDstBits(2, X, Y) / DblDstBits(3, X, Y))
        Next
    Next
   
    Dim dstBI As BITMAPINFO
    With dstBI.bmiHeader
        .biSize = Len(dstBI.bmiHeader)
        .biWidth = newWidth
        .biHeight = -newHeight
        .biPlanes = 1
        .biBitCount = 32
        .biCompression = BI_RGB
    End With
   
    Dim hBmp As Long

   
    hBmp = CreateBitmap(newWidth, newHeight, 1, 32, ByVal 0)

    SetDIBits 0, hBmp, 0, newHeight, DstBits(0, 0), dstBI, DIB_RGB_COLORS

    Dim IGuid As Guid
    With IGuid
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With
   
    Dim PicDst As PictDesc
    With PicDst
        .cbSizeofStruct = Len(PicDst)
        .hImage = hBmp
        .picType = vbPicTypeBitmap
    End With
   
   
    OleCreatePictureIndirect PicDst, IGuid, True, PowerResize


Exit Function

Errorhandler:
    MsgBox Err.Number, " ", Err.Description, " ", Erl

End Function
0
 
LVL 15

Expert Comment

by:eemit
ID: 37721059
Hi LeonKimman,
According to SavePicture Statement Documentation:

If a graphic was loaded from a file to the Picture property of an object,
either at design time or at run time, and its a bitmap, icon, metafile, or enhanced
metafile, it's saved using the same format as the original file.
If it is a GIF or JPEG file, it is saved as a bitmap file.

Search the web to find how to save an image as a jpg
You can use GDI+.
Take a look here.
0
 

Author Comment

by:LeonKimman
ID: 37725051
Hi eemit,

Indeed, the savepicture saves the image as a bitmap, but the savepicture still fails when running this on windows server2008. I found out that not the savepicture command itself is the problem, but the powerresize function

 Set ResizedPic = PowerResize(PicSelect, 70, 90)           'calling the Powerresize function
 SavePicture ResizedPic, App.Path & "\Output.jpg"        ' ****  on this point it fails
 
The Powerresize returns probably not a correct stdPicture which causes the error when perfoming  savepicture.
Strange is that I have errorhandler in the Powerresize function, but this function don't give any errors itself
0
 
LVL 15

Expert Comment

by:eemit
ID: 37727413
Try this changes:
'Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, iPic As StdPicture) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As Any, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long

'Private Type PictDesc
'  cbSizeofStruct As Long
'  picType As Long
'  hImage As Long
'  xExt As Long
'  yExt As Long
'End Type

Private Type PictDesc
  Size As Long
  Type As Long
  hHandle As Long
  hPal As Long
End Type

'Private Type Guid
'  Data1 As Long
'  Data2 As Integer
'  Data3 As Integer
'  Data4(0 To 7) As Byte
'End Type

Open in new window


And in Function PowerResize:
'  Dim IGuid As Guid
'  With IGuid
'      .Data1 = &H7BF80980
'      .Data2 = &HBF32
'      .Data3 = &H101A
'      .Data4(0) = &H8B
'      .Data4(1) = &HBB
'      .Data4(2) = &H0
'      .Data4(3) = &HAA
'      .Data4(4) = &H0
'      .Data4(5) = &H30
'      .Data4(6) = &HC
'      .Data4(7) = &HAB
'  End With
'
'  Dim PicDst As PictDesc
'  With PicDst
'      .cbSizeofStruct = Len(PicDst)
'      .hImage = hBmp
'      .picType = vbPicTypeBitmap
'  End With
'
'
'  OleCreatePictureIndirect PicDst, IGuid, True, PowerResize
   
  ' create stdPicture
  Set PowerResize = HandleToStdPicture(hBmp, vbPicTypeBitmap)
 

Open in new window


New Function:
' Creates a stdPicture object from an image handle (bitmap or icon)
Private Function HandleToStdPicture( _
                                ByVal hImage As Long, _
                                ByVal imgType As PictureTypeConstants _
                                ) As IPicture

  Dim lpPictDesc As PictDesc
  Dim aGUID(0 To 3) As Long

  With lpPictDesc
      .Size = Len(lpPictDesc)
      .Type = imgType
      .hHandle = hImage
      .hPal = 0
  End With
  
  ' IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
  aGUID(0) = &H7BF80980
  aGUID(1) = &H101ABF32
  aGUID(2) = &HAA00BB8B
  aGUID(3) = &HAB0C3000

  ' create stdPicture
  Call OleCreatePictureIndirect(lpPictDesc, aGUID(0), True, HandleToStdPicture)

End Function

Open in new window

0
 

Author Comment

by:LeonKimman
ID: 37729802
Hi eemit

Thanks for your code.
I tried it, and it works ok on xp, but not on the windows server 2008

The problem is that i don't have a windows server 2008 machine where i can install vb6
to probably debugging the problem.

What I'm doing now is make the executable on a xp machine (where it runs ok) and than run this executable on the windows server 2008.
I will try to get a virtual machine of windows server 2008 where i can install vb6
0
 
LVL 15

Expert Comment

by:eemit
ID: 37729914
Works fine here on Windows XP and Windows 7, with or without modifications.
Can you post some pictures?.
0
 
LVL 15

Expert Comment

by:eemit
ID: 37732975
Hi LeonKimman,
OleCreatePictureIndirect Function is Exported by both dlls:
olepro32.dll and oleaut32.dll.

Try changing the following line:

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As Any, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long

to:

Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" (lpPictDesc As PictDesc, riid As Any, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
0
 

Author Comment

by:LeonKimman
ID: 37741483
error message on windows server 2008
Hi eemit,

I tried the oleaut32.dll but it is not working.

The errormessage I got at the savepicture is following in the attached printscreen
0
 
LVL 15

Expert Comment

by:eemit
ID: 37742362
Hi LeonKimman,
- Try to install your exe properly.
- Verify in Project References that a Reference to OLE Automation
exists (StdOle2.tlb).
- Post your project references.
- Post an image that causes error.

And very important:
- Don't use App.Path to store your images:
according to Microsoft:
"Applications should be installed to the Program Files folder by default.
User data or application data must never be stored in this location because
of the security permissions."
0
 

Author Comment

by:LeonKimman
ID: 37743104
Hi eemit,

I changed the code so the savepicture saves the output.jpg now not in the app.path but on another location.

I placed the exe in a folder in the c:\program files.    
(I don't have an installer of thist (test) exe, but on the windows 2008 machine there are already vb6 programs running, so I think I don't have to make an installer for this test exe,  or it is better to make an installer?)

After these changes i still have the out of memory error

The following project references are in this exe:
    - Visual Basic for applications  (msvbvm60.dll)
    - Visual Bacic runtime objects and procedures (msvbvm60.dll\3)
    - Visual Basic objects and procedures (vb6.olb)
    - OLE Automation (stdole2.tlb)

I attached an image that causes the error (testfoto.jpg)
testfoto.jpg
0
 
LVL 15

Expert Comment

by:eemit
ID: 37743217
- Don't use App.Path to store your images:
I forgot to say: the same for your images to resize.
0
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 
LVL 15

Expert Comment

by:eemit
ID: 37744580
Hi LeonKimman,
  Your image size is 245 x 270 pixels.
  Works here on Windows XP and Windows 7 with
  image size 2450 x 2700 pixels.

- But you have to limit the maximum size of pictures.

- Make this changes too:

Public Function PowerResize( _
  '...

  Exit Function

Errorhandler:
  MsgBox Err.Number, " ", Err.Description, " ", Erl
 Set PowerResize = Nothing
End Function

Private Sub cmdsearchPicture_Click()
  '...
  Set ResizedPic = PowerResize(PicSelect, 70, 90)
  If Not ResizedPic Is Nothing Then  
      SavePicture ResizedPic ...
      '...
  End If

End Sub
0
 

Author Comment

by:LeonKimman
ID: 37746648
Hi eemit,

I tried your changes. I also placed the image to resize in another location in stead of the app.path

However, the powerresize functions doen't goes in error, so the Resizedpic is still there. So the savepicture starts and then goes in error.

I'm now trying to prevent using the Powerresize function and using another way to resize without using api's.
0
 
LVL 15

Expert Comment

by:eemit
ID: 37747447
Hi LeonKimman,

- I doubt that you get the out of memory error with each picture size.

- With Savepicture method you always get out of memory error with to larger image size.
The problem is that SavePicture method always saves uncompressed images, bmp.

- As I have already said try another method to save your pictures.
You can use GDI+ not only to save image as .jpg, but also
for all your image resizing tasks.

Hope this helps
0
 
LVL 15

Expert Comment

by:eemit
ID: 37748085
Another Problem in your code:
You must verify if source image is indeed loaded.

' Make this changes:
Set PicSelect = LoadPicture(strTempfile)

Dim bSourcePictureNotLoaded As Boolean
If PicSelect Is Nothing Then
    bSourcePictureNotLoaded = True
Else
    If PicSelect = 0 Then
        bSourcePictureNotLoaded = True
    End If
End If
If bSourcePictureNotLoaded Then
    MsgBox "Source Picture not Loaded"
    Exit Sub
End If
Set ResizedPic = PowerResize(PicSelect, 70, 90)
0
 

Author Comment

by:LeonKimman
ID: 37815272
Hi eemit

Sorry for the late answer.

I now have found a way to resize images without using the powerresize function, so I don't need the api's anymore.
With the function beneath it works ok now, also on windows server 2008

    Dim PicWidth    As Long
    Dim PicHeight   As Long
    Dim picTmp      As Picture
    Dim pictboxTmp  As Control
           
    Set picTmp = LoadPicture(strImage)
    Set pictboxTmp = Me.Controls.Add("VB.Picturebox", "Picture1", Me)
           
    pictboxTmp.Visible = False
    pictboxTmp.Container.ScaleMode = vbPixels
    pictboxTmp.ScaleMode = vbPixels
    pictboxTmp.BorderStyle = 0
    pictboxTmp.AutoRedraw = True
             
    PicWidth = pictboxTmp.ScaleX(picTmp.Width, vbHimetric, vbPixels)
    PicHeight = pictboxTmp.ScaleY(picTmp.Height, vbHimetric, vbPixels)
   
    pictboxTmp.Width = 70
    pictboxTmp.Height = 90
    pictboxTmp.Cls
    pictboxTmp.PaintPicture picTmp, 0, 0, 70, 90
       
    SavePicture pictboxTmp.Image, App.Path & "\Output.jpg"
    DoEvents
           
    Set picTmp = Nothing
    Controls.Remove ("Picture1")
    Set pictboxTmp = Nothing

    ResizePic = True
0
 
LVL 15

Accepted Solution

by:
eemit earned 500 total points
ID: 37876928
Hi LeonKimman,
You're right not to use it more.
To ensure that PowerResize Function works well, computer's color
setting must be set to true color (32-bit)!

Furthermore, it seems that CreateBitmap always creates a bitmap that matches the current system color depth.

As a workaround one can determine current color depth:

In ModResize:
Private Const BITSPIXEL = 12
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long

In PowerResize Function,
abowe the line: DeleteDC lDc
Dim nColorDepthBits As Long
nColorDepthBits = GetDeviceCaps(lDc, BITSPIXEL)

and change line:
hBmp = CreateBitmap(newWidth, newHeight, 1, 32, ByVal 0)
to:
hBmp = CreateBitmap(newWidth, newHeight, 1, nColorDepthBits, ByVal 0)
0
 
LVL 45

Expert Comment

by:Martin Liss
ID: 37968133
I've requested that this question be deleted for the following reason:

Not enough information to confirm an answer.
0
 
LVL 15

Expert Comment

by:eemit
ID: 37968134
The workaround as I described in ID: 37876928
is a solution to the Asker's initial question.
0
 

Author Comment

by:LeonKimman
ID: 37974029
Hi eemit

Sorry fot the late answer, but the past weeks i was not involved further more in the issue of the powerresize.

I will try the workaround as described in ID: 37876928
0
 

Author Comment

by:LeonKimman
ID: 38505491
The workartound is working.
0
 

Author Comment

by:LeonKimman
ID: 38507243
I've requested that this question be closed as follows:

Accepted answer: 0 points for LeonKimman's comment #a38505491

for the following reason:

The workaround in this solution is working fine
0
 
LVL 15

Expert Comment

by:eemit
ID: 38507244
Hi LeonKimman,
I suppose you wanted to accept http:#a37876928 as a solution.
Thanks
0
 

Author Comment

by:LeonKimman
ID: 38508718
Yes, indeed

I want accept  http:#a37876928 as a solution.
0

Featured Post

How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

Join & Write a Comment

Article by: Martin
Here are a few simple, working, games that you can use as-is or as the basis for your own games. Tic-Tac-Toe This is one of the simplest of all games.   The game allows for a choice of who goes first and keeps track of the number of wins for…
Enums (shorthand for ‘enumerations’) are not often used by programmers but they can be quite valuable when they are.  What are they? An Enum is just a type of variable like a string or an Integer, but in this case one that you create that contains…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
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…

762 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

23 Experts available now in Live!

Get 1:1 Help Now