- Код: Выделить всё
Public Sub SaveToFile(fName As String, fFormat As SR2D_FileFormat, Optional ByVal JPGQuality As Long = 80)
Dim tSI As GdiplusStartupInput
Dim Res As Long
Dim GDIP As Long
Dim Bmp As Long
Dim tEncoder As CLSID
Dim tParams As EncoderParameters
Dim sType As String
Dim ArRGB() As Byte
Dim Stride As Long
tSI.GdiplusVersion = 1
Res = GdiplusStartup(GDIP, tSI)
If Res = 0 Then
If fFormat = FF_ARGB_BMP Or fFormat = FF_ARGB_PNG Or fFormat = FF_RGB_JPG Then
Res = GdipCreateBitmapFromScan0(Width, Height, Width * 4, PixelFormat32bppARGB, cBuf(0), Bmp)
Else
Stride = ((Width * 3 - 1) Or 3) + 1
ReDim ArRGB(Stride * Height - 1)
Bpp32to24 cBuf(0), ArRGB(0), Width, Height, Stride
Res = GdipCreateBitmapFromScan0(Width, Height, Stride, PixelFormat24bppRGB, ArRGB(0), Bmp)
End If
If Res = 0 Then
Select Case fFormat
Case FF_ARGB_BMP, FF_RGB_BMP
sType = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Case FF_ARGB_PNG, FF_RGB_PNG
sType = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Case FF_RGB_JPG
sType = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
tParams.count = 1
tParams.Parameter.NumberOfValues = 1
tParams.Parameter.type = 4
tParams.Parameter.value = VarPtr(JPGQuality)
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), tParams.Parameter.GUID
End Select
CLSIDFromString StrPtr(sType), tEncoder
Res = GdipSaveImageToFile(Bmp, StrPtr(fName), tEncoder, tParams)
GdipDisposeImage Bmp
End If
GdiplusShutdown GDIP
End If
End Sub
Изображение в массиве cBuf(), очевидно, что до строки "Select Case fFormat" всё отрабатывает правильно, далее где-то ошибка. В XP и 32-битной семёрке это работает корректно. Подскажите, куда копать? У меня есть возможность проверять только скомпилированные EXE на семёрке.