hdc怎么转stdpicture?

Question

已把相关的图片设置好hdc
怎么把hdc装进
    Dim stdpicture1 As New StdPicture
???

Answer 1

Option Explicit
  Const RC_PALETTE     As Long = &H100
  Const SIZEPALETTE     As Long = 104
  Const RASTERCAPS     As Long = 38
  Private Type PALETTEENTRY
          peRed   As Byte
          peGreen   As Byte
          peBlue   As Byte
          peFlags   As Byte
  End Type
  Private Type LOGPALETTE
          palVersion   As Integer
          palNumEntries   As Integer
          palPalEntry(255)   As PALETTEENTRY     '   Enough   for   256   colors
  End Type
  Private Type GUID
          Data1   As Long
          Data2   As Integer
          Data3   As Integer
          Data4(7)   As Byte
  End Type
  Private Type PicBmp
          Size   As Long
          Type   As Long
          hBmp   As Long
          hPal   As Long
          Reserved   As Long
  End Type
  Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
  Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
  Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
  Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long
  Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
  Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
  Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
  Private Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
  Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
  Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
  Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
  Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
          Dim R     As Long, Pic       As PicBmp, IPic       As IPicture, IID_IDispatch       As GUID
    
          'Fill   GUID   info
          With IID_IDispatch
                  .Data1 = &H20400
                  .Data4(0) = &HC0
                  .Data4(7) = &H46
          End With
    
          'Fill   picture   info
          With Pic
                  .Size = Len(Pic)       '   Length   of   structure
                  .Type = vbPicTypeBitmap       '   Type   of   Picture   (bitmap)
                  .hBmp = hBmp       '   Handle   to   bitmap
                  .hPal = hPal       '   Handle   to   palette   (may   be   null)
          End With
    
          'Create   the   picture
          R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
    
          'Return   the   new   picture
          Set CreateBitmapPicture = IPic
  End Function
  Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
          Dim hDCMemory     As Long, hBmp       As Long, hBmpPrev       As Long, R       As Long
          Dim hPal     As Long, hPalPrev       As Long, RasterCapsScrn       As Long, HasPaletteScrn       As Long
          Dim PaletteSizeScrn     As Long, LogPal       As LOGPALETTE
Dim lt, ff, ers, erslog
On Error GoTo writeerlog:
lt = "start"
          'Create   a   compatible   device   context
          hDCMemory = CreateCompatibleDC(hDCSrc)
          'Create   a   compatible   bitmap
          hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
          'Select   the   compatible   bitmap   into   our   compatible   device   context
          hBmpPrev = SelectObject(hDCMemory, hBmp)lt = "Raster   capabilities?"          'Raster   capabilities?
          RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)         '   Raster
          'Does   our   picture   use   a   palette?
          HasPaletteScrn = RasterCapsScrn And RC_PALETTE           '   Palette
          'What's   the   size   of   that   palette?
          PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)         '   Size   of
lt = "HasPaletteScrn And (PaletteSizeScrn = 256)"
          If HasPaletteScrn And (PaletteSizeScrn = 256) Then
                  'Set   the   palette   version
                  LogPal.palVersion = &H300
                  'Number   of   palette   entries
                  LogPal.palNumEntries = 256
                  'Retrieve   the   system   palette   entries
                  R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
                  'Create   the   palette
                  hPal = CreatePalette(LogPal)
                  'Select   the   palette
                  hPalPrev = SelectPalette(hDCMemory, hPal, 0)
                  'Realize   the   palette
                  R = RealizePalette(hDCMemory)
          End If
lt = "copy source image"
          'Copy   the   source   image   to   our   compatible   device   context
          R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)
            
          'Restore   the   old   bitmap
          hBmp = SelectObject(hDCMemory, hBmpPrev)
            
          If HasPaletteScrn And (PaletteSizeScrn = 256) Then
                  'Select   the   palette
                  hPal = SelectPalette(hDCMemory, hPalPrev, 0)
          End If
lt = "Delete   our   memory   DC"
          'Delete   our   memory   DC
          R = DeleteDC(hDCMemory)
lt = "CreateBitmapPicture hDCToPicture"
          Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
lt = "write file"
ff = FreeFile
Open App.Path & "\hDCToPicture.log" For Append As #ff
erslog = Now() & "ok.hDCToPicture:" & Err & "|" & Err.Number & "|" & Err.Source & "|" & Err.Description & ":" & ers & lt
Print #ff, erslog
Close ff
lt = "ok"
writeerlog:
ff = FreeFile
Open App.Path & "\hDCToPicture.log" For Append As #ff
erslog = Now() & "出错在应答处理过程.hDCToPicture:" & Err & "|" & Err.Number & "|" & Err.Source & "|" & Err.Description & ":" & ers & lt
Print #ff, erslog
Close ff  End Function
  'Private Sub Form_Load()
  '        '   now   start
  '        Set Me.Picture = hDCToPicture(GetDC(0), 0, 0, Screen.Width / Screen.TwipsPerPixelX, Screen.Height / Screen.TwipsPerPixelY)
  'End Sub

Answer 2

搞定...续另一个问题.
我建了几个CreateCompatibleDC(0)    hDCSrc = CreateCompatibleDC(0)'来源图片
    hdcSrcMark = CreateCompatibleDC(0)'水印图片
    hdcSrcMark1 = CreateCompatibleDC(0)'临时用的dc通过GetPixel和SetPixel的方法,建立好了hdcSrcMark1,让hdcSrcMark=hdcSrcMark1
现在的问题是.
把hdcSrcMark通过..XXXX......以后,存成文件的话.证实图片是正确的..BMP或压缩过的JPG都正确.
而直接把hdcSrcMark或hdcSrcMark1在内存操作的时候,读取数组什么的写出来的文件,是一片黑色的....
怎么解决?

Answer 3

还是没好.
原来是调错了...
直接调到原本就没问题的hdcSrcMark了
hdcSrcMark = hdcSrcMark1
一但调用正确的hdcSrcMark1中间就出来一块黑块.