Results 1 to 2 of 2

Thread: Load ICO From Res or Byte array by vb6,Get All Size ,BitCount

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Load ICO From Res or Byte array by vb6,Get All Size ,BitCount

    Code:
    'FORM1.FRM
    
    Dim NewCursor As Long, OldCursor As Long
    'add 2 control: Text1,picture1
    
    Private Sub Command1_Click()
    Dim bt() As Byte
    
    'bt = OpenBinFile(App.Path & "\02.ico") 
     
     Dim SizeArr() As String
     SizeArr = GetIcoSizeArr(bt)
     MsgBox Join(SizeArr, vbCrLf)
     
     NewCursor = LoadIcoByByte(bt, 256, 32)
     'NewCursor = LoadIcoByByte(bt, 0)
     
    
    Text1.MousePointer = vbCustom
    OldCursor = SetClassLong(Text1.hwnd, GCL_HCURSOR, NewCursor)
    
    Picture1.Width = 256 * Screen.TwipsPerPixelX + Picture1.Width - Picture1.ScaleWidth
    Picture1.Height = 256 * Screen.TwipsPerPixelY + Picture1.Height - Picture1.ScaleHeight
    
    DrawIconEx Picture1.Hdc, 0, 0, NewCursor, 256, 256, 0, 0, DI_NORMAL
    Picture1.Refresh
    End Sub
    
    Private Sub Form_Load()
    Picture1.AutoRedraw = True
    Picture1.AutoSize = True
    Command1_Click
    End Sub
    Code:
    '*.BAS
    
    Option Explicit
    Private Declare Function CreateIconFromResourceEx Lib "user32" (presbits As Byte, ByVal dwResSize As Long, ByVal fIcon As Long, ByVal dwVer As Long, ByVal cxDesired As Long, ByVal cyDesired As Long, ByVal uFlags As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
    
     Private Type ICONDIRENTRY
        bWidth   As Byte
        bHeight   As Byte
        bColorCount   As Byte
        bReserved   As Byte
        wPlanes   As Integer
        wBitCount   As Integer
        dwBytesInRes   As Long
        dwImageOffset   As Long
    End Type
    Public Const GCL_HCURSOR = -12
    
    
    Public Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" (ByVal hwnd As Long, ByVal nIndex As Long, _
    ByVal dwNewLong As Long) As Long
    Public Const DI_NORMAL = &H3 '用常规方式绘图 (DI_IMAGE 和 DI_MASK)
    Public Declare Function DrawIconEx Lib "user32" (ByVal Hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
    
    Public Function GetIcoSizeArr(mIcon() As Byte) As String()
     'good
    '从字节数组内存流中创建ICO图标
    Dim SizeArr() As String
        Dim IDETY As ICONDIRENTRY
        Dim W As Long, H As Long
        Dim i As Long, iLen As Long, pData As Long, id As Long
        iLen = LenB(IDETY)
        pData = VarPtr(mIcon(0))
        ReDim SizeArr(mIcon(4) - 1)
        For i = 1 To mIcon(4)  '第5个字节就是子图标的数目
            CopyMemory IDETY, ByVal pData + 6 + (i - 1) * iLen, iLen '读 图标目录 结构数据
            W = IDETY.bWidth
            H = IDETY.bHeight
            If W = H Then
                If W = 0 Then W = 256: H = 256
                SizeArr(id) = W & "*" & H & "," & IIf(IDETY.wBitCount = 0, "32位透明", IDETY.wBitCount)
                id = id + 1
            Else
                Exit For
            End If
        Next
        If id > 0 Then
            ReDim Preserve SizeArr(id - 1)
        Else
            ReDim SizeArr(-1 To -1)
        End If
        GetIcoSizeArr = SizeArr
    End Function
    Public Function LoadIcoByByte(mIcon() As Byte, Optional ByVal iSize As Long = 16&, Optional BitCount As Long) As Long
    'version 2021-5-13
     'good
    '从字节数组内存流中创建ICO图标,条件:大小,位度
        Dim IDETY As ICONDIRENTRY, FindSize As Long
        Dim i As Long, iLen As Long, pData As Long
        Dim FindBitCount As Boolean
        If iSize = 0 Then iSize = 256
        If iSize = 256 Then
            FindSize = 0
        Else
            FindSize = iSize
        End If
        iLen = LenB(IDETY)
        pData = VarPtr(mIcon(0))
        For i = 1 To mIcon(4)  '第5个字节就是子图标的数目
            CopyMemory IDETY, ByVal pData + 6 + (i - 1) * iLen, iLen '读 图标目录 结构数据
            If BitCount = 0 Then
                FindBitCount = True
            Else
                FindBitCount = IDETY.wBitCount = BitCount
            End If
            If FindBitCount Then
                If iSize = -1 Then
                    iSize = IDETY.bWidth
                    If iSize = 0 Then iSize = 256 'edit:2021-5-13
                    GoTo DoLoadIco
                ElseIf IDETY.bWidth = FindSize Then '寻找符合尺寸的子图标
    DoLoadIco:
                    LoadIcoByByte = CreateIconFromResourceEx(mIcon(IDETY.dwImageOffset) _
                                    , IDETY.dwBytesInRes, -1, &H30000, iSize, iSize, 0)
                    Exit For
                End If
            End If
        Next
    End Function
    
    Function OpenBinFile(filename As String, Optional ErrInfo As String) As Byte()
       '[mycode_id:1903],edittime:2011/7/11 13:27:34
    On Error Resume Next
    Dim hFile As Integer
    hFile = FreeFile
    Open filename For Binary As #hFile
    ReDim OpenBinFile(LOF(hFile) - 1)
    Get #hFile, , OpenBinFile
    Close #hFile
    End Function
    Last edited by xiaoyao; May 12th, 2021 at 11:37 PM.

  2. #2

    Thread Starter
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: Load ICO From Res or Byte array by vb6,Get All Size ,BitCount

    Code:
    Private Declare Sub CreateStreamOnHGlobal Lib "ole32.dll" (ByVal hGlobal As Long, ByVal fDeleteOnRelease As Long, ByRef ppstm As Any)
    
      Sub ShowImage(sPath As String, picbox As PictureBox)
      'oleexp.tlb
      
        On Error Resume Next
        Dim pFact As ShellImageDataFactory, pShImg As IShellImageData
        Set pFact = New ShellImageDataFactory
        Dim tSZ As SIZE, prcD As RECT, prcS As RECT
        pFact.CreateImageFromFile StrPtr(sPath), pShImg
        pShImg.Decode SHIMGDEC_DEFAULT, 10, 10
        pShImg.GetSize tSZ
        prcD.Right = tSZ.cx 'Picture2.ScaleWidth
        prcD.Bottom = tSZ.cy 'Picture2.ScaleHeight
        prcS.Right = tSZ.cx
        prcS.Bottom = tSZ.cy
        picbox.Cls
        pShImg.Draw picbox.hdc, prcD, prcS
    End Sub
    
      Sub ShowImageByStream(PicFileByte() As Byte, picbox As PictureBox)
        On Error Resume Next
        Dim pFact As ShellImageDataFactory, pShImg As IShellImageData
        Set pFact = New ShellImageDataFactory
        Dim tSZ As SIZE, prcD As RECT, prcS As RECT
        
       Dim Image As Long
        Dim pStream As IStream
        Dim hGlobal As Long
        Dim pMem As Long
        
        
        hGlobal = VarPtr(PicFileByte(0))
        Call CreateStreamOnHGlobal(hGlobal, False, pStream)
        pFact.CreateImageFromStream pStream, pShImg
        Set pStream = Nothing
        pShImg.Decode SHIMGDEC_DEFAULT, 10, 10
        pShImg.GetSize tSZ
        prcD.Right = tSZ.cx 'Picture2.ScaleWidth
        prcD.Bottom = tSZ.cy 'Picture2.ScaleHeight
        prcS.Right = tSZ.cx
        prcS.Bottom = tSZ.cy
        picbox.Cls
        pShImg.Draw picbox.hdc, prcD, prcS
    End Sub
    FROM How to load PNG image?-VBForums
    https://www.vbforums.com/showthread....FromResourceEx

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width