Powerresize fails when running on windows server 2008
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
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
ASKER
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
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
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.
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.
ASKER
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
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
Try this changes:
And in Function PowerResize:
New Function:
'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 TypeAnd 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)
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 FunctionASKER
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
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
Works fine here on Windows XP and Windows 7, with or without modifications.
Can you post some pictures?.
Can you post some pictures?.
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
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
ASKER
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
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."
- 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."
ASKER
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
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
- Don't use App.Path to store your images:I forgot to say: the same for your images to resize.
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
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
ASKER
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.
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.
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
- 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
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)
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)
ASKER
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.Pictur
pictboxTmp.Visible = False
pictboxTmp.Container.Scale
pictboxTmp.ScaleMode = vbPixels
pictboxTmp.BorderStyle = 0
pictboxTmp.AutoRedraw = True
PicWidth = pictboxTmp.ScaleX(picTmp.W
PicHeight = pictboxTmp.ScaleY(picTmp.H
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
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.Pictur
pictboxTmp.Visible = False
pictboxTmp.Container.Scale
pictboxTmp.ScaleMode = vbPixels
pictboxTmp.BorderStyle = 0
pictboxTmp.AutoRedraw = True
PicWidth = pictboxTmp.ScaleX(picTmp.W
PicHeight = pictboxTmp.ScaleY(picTmp.H
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
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
I've requested that this question be deleted for the following reason:
Not enough information to confirm an answer.
Not enough information to confirm an answer.
The workaround as I described in ID: 37876928
is a solution to the Asker's initial question.
is a solution to the Asker's initial question.
ASKER
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
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
ASKER
The workartound is working.
ASKER
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
Accepted answer: 0 points for LeonKimman's comment #a38505491
for the following reason:
The workaround in this solution is working fine
ASKER
but with the type of image.
Please show us the line of code that the error occurs on.