图像问题，请帮忙解决。

[loise11]

一个从6.0升级过来的程序，调试不成功，可能是封送处理的问题，请指教。
Private Structure PALETTEENTRY
Dim peRed As Byte
Dim peGreen As Byte
Dim peBlue As Byte
Dim peFlags As Byte
End Structure

Private Structure LOGPALETTE
Dim palVersion As Short
Dim palNumEntries As Short
<VBFixedArray(255)> Dim palPalEntry() As PALETTEENTRY
Public Sub Initialize()
ReDim palPalEntry(255)
End Sub
End Structure
Private Structure GUID
Dim Data1 As Integer
Dim Data2 As Short
Dim Data3 As Short
<VBFixedArray(7)> Dim Data4() As Byte
Public Sub Initialize()
ReDim Data4(7)
End Sub
End Structure
Private Const RASTERCAPS As Integer = 38
Private Const RC_PALETTE As Integer = &H100s
Private Const SIZEPALETTE As Integer = 104
Private Structure RECT
Dim Left_Renamed As Integer
Dim Top_Renamed As Integer
Dim Right_Renamed As Integer
Dim Bottom_Renamed As Integer
End Structure
Private Declare Function CreateCompatibleDC Lib "GDI32" (ByVal hDC As Integer) As Integer
Private Declare Function CreateCompatibleBitmap Lib "GDI32" (ByVal hDC As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer) As Integer
Private Declare Function GetDeviceCaps Lib "GDI32" (ByVal hDC As Integer, ByVal iCapabilitiy As Integer) As Integer
Private Declare Function GetSystemPaletteEntries Lib "GDI32" (ByVal hDC As Integer, ByVal wStartIndex As Integer, ByVal wNumEntries As Integer, ByRef lpPaletteEntries As PALETTEENTRY) As Integer
Private Declare Function CreatePalette Lib "GDI32" (ByRef lpLogPalette As LOGPALETTE) As Integer
Private Declare Function SelectObject Lib "GDI32" (ByVal hDC As Integer, ByVal hObject As Integer) As Integer
Private Declare Function BitBlt Lib "GDI32" (ByVal hDCDest As Integer, ByVal XDest As Integer, ByVal YDest As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hDCSrc As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal dwRop As Integer) As Integer
Private Declare Function DeleteDC Lib "GDI32" (ByVal hDC As Integer) As Integer
Private Declare Function GetForegroundWindow Lib "USER32" () As Integer
Private Declare Function SelectPalette Lib "GDI32" (ByVal hDC As Integer, ByVal hPalette As Integer, ByVal bForceBackground As Integer) As Integer
Private Declare Function RealizePalette Lib "GDI32" (ByVal hDC As Integer) As Integer
Private Declare Function GetWindowDC Lib "USER32" (ByVal hWnd As Integer) As Integer
Private Declare Function GetDC Lib "USER32" (ByVal hWnd As Integer) As Integer
Private Declare Function GetWindowRect Lib "USER32" (ByVal hWnd As Integer, ByRef lpRect As RECT) As Integer
Private Declare Function ReleaseDC Lib "USER32" (ByVal hWnd As Integer, ByVal hDC As Integer) As Integer
Private Declare Function GetDesktopWindow Lib "USER32" () As Integer
Private Structure PicBmp
Dim Size_Renamed As Integer
Dim Type As Integer
Dim hBmp As Integer
Dim hPal As Integer
Dim Reserved As Integer
End Structure
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (ByRef PicDesc As PicBmp, ByRef RefIID As GUID, ByVal fPictureOwnsHandle As Integer, ByRef IPic As System.Drawing.Image) As Integer
Public Function CaptureWindow(ByVal hWndSrc As Integer, ByVal Client As Boolean, ByVal LeftSrc As Integer, ByVal TopSrc As Integer, ByVal WidthSrc As Integer, ByVal HeightSrc As Integer) As System.Drawing.Image
Dim hDCMemory As Integer
Dim hBmp As Integer
Dim hBmpPrev As Integer
Dim r As Integer
Dim hDCSrc As Integer
Dim hPal As Integer
Dim hPalPrev As Integer
Dim RasterCapsScrn As Integer
Dim HasPaletteScrn As Integer
Dim PaletteSizeScrn As Integer
Dim LogPal As LOGPALETTE
LogPal.Initialize()
' Depending on the value of Client get the proper device context.
If Client Then
hDCSrc = GetDC(hWndSrc) ' Get device context for client area.
Else
hDCSrc = GetWindowDC(hWndSrc) ' Get device context for entire
' window.
End If

' Create a memory device context for the copy process.
hDCMemory = CreateCompatibleDC(hDCSrc)
' Create a bitmap and place it in the memory DC.
hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
hBmpPrev = SelectObject(hDCMemory, hBmp)

' Get screen properties.
RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster
' capabilities.
HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette
' support.
PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of
' palette.

' If the screen has a palette make a copy and realize it.
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
' Create a copy of the system palette.
LogPal.palVersion = &H300s
LogPal.palNumEntries = 256
r = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
hPal = CreatePalette(LogPal)
' Select the new palette into the memory DC and realize it.
hPalPrev = SelectPalette(hDCMemory, hPal, 0)
r = RealizePalette(hDCMemory)
End If
r = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, &HCC0020)

' Remove the new copy of the on-screen image.
hBmp = SelectObject(hDCMemory, hBmpPrev)

' If the screen has a palette get back the palette that was
' selected in previously.
If HasPaletteScrn And (PaletteSizeScrn = 256) Then
hPal = SelectPalette(hDCMemory, hPalPrev, 0)
End If

' Release the device context resources back to the system.
r = DeleteDC(hDCMemory)
r = ReleaseDC(hWndSrc, hDCSrc)

' Call CreateBitmapPicture to create a picture object from the
' bitmap and palette handles. Then return the resulting picture
' object.
CaptureWindow = CreateBitmapPicture(hBmp, hPal)
End Function


Public Function CreateBitmapPicture(ByVal hBmp As Integer, ByVal hPal As Integer) As System.Drawing.Image

Dim r As Integer
Dim Pic As PicBmp
' IPicture requires a reference to "Standard OLE Types."
Dim IPic As System.Drawing.Image

'UPGRADE_WARNING: 结构 IID_IDispatch 中的数组可能需要先初始化才可以使用。 单击以获得更多信息:“ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1063"”
Dim IID_IDispatch As New Guid
IID_IDispatch.Initialize()
' Fill in with IDispatch Interface ID.
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0s
.Data4(7) = &H46s
End With

' Fill Pic with necessary parts.
With Pic
.Size_Renamed = Len(Pic) ' Length of structure.
.Type = 1 ' Type of Picture (bitmap).
.hBmp = hBmp ' Handle to bitmap.
.hPal = hPal ' Handle to palette (may be null).
End With
' Create Picture object.
××××××××××××××××××下面一句出现了问题
r = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)

' Return the new Picture object.
CreateBitmapPicture = IPic
End Function
Private Sub Command2_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles Command2.Click
Dim G As System.Drawing.Graphics
G = Picture1.CreateGraphics
G.DrawImage(CaptureWindow(Picture1.Handle.ToInt32, False, 0, 0, Picture1.Width, Picture1.Height), 0, 0)
'Picture1.PaintPicture(CaptureWindow(Picture1.Handle.ToInt32, False, 0, 0, Picture1.ScaleX(VB6.PixelsToTwipsX(Picture1.Width), vbTwips, vbPixels), Picture1.ScaleY(VB6.PixelsToTwipsY(Picture1.Height), vbTwips, vbPixels)), 0, 0)
Picture1.BackgroundImage.Save("c:\test2.bmp")
End Sub
Private Sub Command1_Click(ByVal eventSender As System.Object, ByVal eventArgs As System.EventArgs) Handles Command1.Click
CaptureWindow(Picture1.Handle.ToInt32, False, 0, 0, Picture1.Width, Picture1.Height).Save("C:\test1.bmp")
End Sub

[chamys]

關注中

[loise11]

大家多支持一下啊，拜托拜。

[yezhq]

现存的代码参考一下：
'贴相片
Dim openFileDialog1 As New OpenFileDialog
Dim PictureFilePath As String
openFileDialog1.InitialDirectory = "c:\"
openFileDialog1.Filter = "jpg files (*.jpg)|*.jpg|gif files (*.gif)|*.gif|All files (*.*)|*.*"
openFileDialog1.FilterIndex = 1
'存储目录
openFileDialog1.RestoreDirectory = True

If openFileDialog1.ShowDialog() = DialogResult.OK Then
'图片的路径赋给变量


PictureFilePath = openFileDialog1.FileName
'在pinturebox中显示图片
PictureBox1.SizeMode = PictureBoxSizeMode.StretchImage
PictureBox1.Image = Image.FromFile(PictureFilePath)
End If
'SavePicture(PictureFilePath, "update T_Z_bys set zp=values(@pic) where xh='10810510000020804'")
Try
Dim cString As String = SQL_CONNECTION_STRING()
Dim myconn As SqlClient.SqlConnection
'Dim mycmd As SqlClient.SqlCommand
myconn = New SqlClient.SqlConnection(cString)
myconn.Open()
'Dim StrInsert As String
'StrInsert = "insert into " & TableName & "value (@pic)"
'mycmd = New SqlClient.SqlCommand(SavePictString, myconn)

Dim mycmd As SqlCommand = New SqlCommand("update T_Z_bys set zp =@pic where xh=" & "'" & TextBox1.Text & "'", myconn)
Dim ib(60000) As Byte
Dim fs As FileStream = New FileStream(PictureFilePath, FileMode.Open, FileAccess.Read)
fs.Read(ib, 0, 60000)
mycmd.Parameters.Add("@pic", SqlDbType.Image, fs.Length).Value = ib
mycmd.ExecuteNonQuery()
myconn.Close()
Catch ex As Exception
MessageBox.Show(ex.Message)
Exit Sub
End Try
MessageBox.Show("图像保存成功！")

'读取图片的数据
Try
Dim conn As SqlConnection = New SqlConnection(cString)
conn.Open()
Dim cmd As SqlCommand = New SqlCommand("select zp from t_z_bys where xh=" & "'" & TextBox1.Text & "'", conn)
Dim reader As SqlDataReader = cmd.ExecuteReader()
reader.Read() '由于只有一条记录所以直接读取就是图片的数据
Dim t() As Byte = reader(0)
Dim buf As MemoryStream = New MemoryStream(t)
Dim image As Image = image.FromStream(buf, True) 'true意味着使用流中嵌入的颜色管理信息
PictureBox1.Image = image
Catch ex As Exception
MessageBox.Show(ex.ToString)
End Try

[sw95588]

写的什么阿，来点具体的

[bluebirdme]

看的晕乎乎，帮你顶一下吧

[loise11]

代码的目的是将一个picturebox中载入的图片及其里面的lable控件之类的东东一起保存成为一幅图像！
哎，忘了说明，没办法！

[fan2c]

一行注释都没有。当前流行？
帮你顶了