VB6 SHOW 3DMAX (Cult3D ActiveX Player)，CO File format

February 17, 2021, 11:10 pm

≫ Next: VB6 2D-ChartPlotting (using the RC6.cChart HelperClass)

≪ Previous: events for late-bound objects (vb6 com events IIDSTR_IConnectionPointContainer)

$

0

0

Cult3D ActiveX Player

Cult3DP1.Visible = True
Cult3DP1.LoadCult3D App.Path & "\sun.co"

download 3d ocx:
http://www.web3d.com.cn/plugin/cult3d.html

how to use Cult3DP1?
Cult3DP1.***
Private Sub Cult3DP1_OnSendMessage(ByVal Message As String)
Me.Caption = "Message=" & Message
End Sub

---

VB6 2D-ChartPlotting (using the RC6.cChart HelperClass)

February 18, 2021, 8:29 am

≫ Next: [Add-In] Large Project Organiser (alternative Project Explorer) - No sub-classing!

≪ Previous: VB6 SHOW 3DMAX (Cult3D ActiveX Player)，CO File format

$

0

0

Just a little Demo, how to work with the new RC6.cChart-Class (requiring an RC6-version >= 6.0.3).

This Class follows a somewhat different pattern, compared to other Chart-Controls -
because it supports a "virtual concept" which:
- doesn't define the Chart-behaviour (or Type) as much via Properties
- but via OwnerDraw-Events instead

To "catch" these Events (to draw your own "ChartType"):
- you have to define your own Class (per ChartType)
- and in this Class, you will receive the OwnerDraw-Events

Example for such a UserDefined CharType-Class
(taken from the zipped example below, responsible for rendering the chart at the right-hand-side of the following ScreenShot):

Code:

---

Option Explicit

Public WithEvents Chart As cChart

Private Sub Class_Initialize()
  Set Chart = New_c.Chart
End Sub
 
'**** Class-specific Implementation of the Chart-Events *****
Private Sub Chart_DrawChartBackGroundAndTitle(CC As cCairoContext, ByVal Title As String)
  CC.Paint 1, Cairo.CreateSolidPatternLng(vbWhite)
  CC.SelectFont "Times New Roman", 13, &H222222, True, True
  CC.DrawText 0, 0, CC.Surface.Width, 50, Title, True, vbCenter, 3, True
End Sub
 
Private Sub Chart_OverrideAxisProps(Axis As cChartAxis, ByVal CurrentMin As Double, ByVal CurrentMax As Double, ByVal CurrentTickIntervals As Long)
  If Axis.Name = "X" Then Axis.TickIntervals = 10
End Sub

Private Sub Chart_DrawSingleTickForAxis(Axis As cChartAxis, CC As cCairoContext, ByVal TickValue, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long)
  Select Case UCase$(Axis.Name)
    Case "X"
      CC.DrawLine x, y, x, y + dy + 4, True, 1, vbRed, 0.5
      Axis.DrawTickText CC, x, y + 6, Format$(TickValue, "0.00")
    Case "Y"
      CC.DrawLine x - 4, y, x + dx, y, True, 1, vbBlue, 0.5
      Axis.DrawTickText CC, x - 4, y, Format$(TickValue, "0.00")
  End Select
End Sub
 
Private Sub Chart_DrawData(CC As cCairoContext, DataArr() As Variant, ByVal dx As Long, ByVal dy As Long)
  Dim PolyArr As cArrayList
  Set PolyArr = Chart.GetAxisScaledPolyArrXY(DataArr, Chart.AxisCol("X"), Chart.AxisCol("Y"))
 
  CC.SetLineWidth 2
  CC.PolygonPtr PolyArr.DataPtr, PolyArr.Count \ 2, False, splNormal, True, True
  CC.Stroke , Cairo.CreateSolidPatternLng(vbGreen)
End Sub

---

Here a ScreenShot:


Here is the zipped Demo-Code, which produced the above output:
ChartPlot.zip

Have fun,

Olaf

Attached Files

• ChartPlot.zip (5.2 KB)

[Add-In] Large Project Organiser (alternative Project Explorer) - No sub-classing!

February 21, 2021, 6:29 am

≫ Next: vb6 Secure Websocket

≪ Previous: VB6 2D-ChartPlotting (using the RC6.cChart HelperClass)

$

0

0

Undeterred by the lukewarm reception of my tab-Strip Add-In :D, here I am with another one. Gotta fill-up those lock-down days doing something, eh?

This one is thought as a replacement for the built-in Project Explorer, and may be useful to somebody who is working with a large project. The idea (and not an original one!) is that you can organise your projects into something more meaningful than simply a list of Component Types: As illustrated below, create appropriate Groups and drag/drop into those

Overview




Cloning

And one is not limited to doing this on a one-to-one basis, either. Here I am cloning an item into more than one Group (via the CTRL key), just to show that that's possible, too:





Ordering

And, finally, one can order the Groups, however they see fit....



Download

...and here's the code:

ProjEx Addin.zip

Updated with the problem identified in post #2 fixed.

Attached Files

• ProjEx Addin.zip (20.6 KB)

vb6 Secure Websocket

February 26, 2021, 10:19 pm

≫ Next: Bind Cdecl Api To vb6 Function(stdcall),support run in IDE

≪ Previous: [Add-In] Large Project Organiser (alternative Project Explorer) - No sub-classing!

$

0

0

Secure webSocket in Pure VB6 no external Libraries or ActiveX.
Now wss://localhost:8088 is possible.
Now Lengthy(char length more than 65536) messages possible.

Thanks goes to :
Vladimir Vissoultchev(wqweto)
Olaf Schmidt
and many others.
https://github.com/wqweto/VbAsyncSocket

https://www.vbforums.com/showthread....ushServer-Demo

https://github.com/bloatless/php-websocket

https://www.cnblogs.com/xiii/p/5165303.html



In order to create a self-signed ssl certificate you need open-ssl. In my case I have done it in my cloud server and downloaded.
Follow the instructions given here :

https://www.freecodecamp.org/news/ho...-7af615770eec/

after install the certificate. open rootCa.crt -> Install Certificate - > Next -> Place all certificates in the following store -> Browse
-> Trusted Root Certification Authorities - > OK -> Next - > Finish - > Install/Approve

Download the attachment
Attachment 180338

Notes:

I have combined and ported codes from here and there, and given the references, detailed code explanations can be found there.

Attached Files

• vb-websocket.zip (294.4 KB)

Bind Cdecl Api To vb6 Function(stdcall),support run in IDE

March 2, 2021, 9:52 pm

≫ Next: [VB6] - sSlide - User Control

≪ Previous: vb6 Secure Websocket

$

0

0

'bind cdecl api to vb6 function
FixCdecl AddressOf VB_Add, CdeclApi, 2
c = VB_Add(a, b)

FORM1 CODE:

Code:

---

Dim h As Long
Dim CdeclApi_Add As Long

Private Sub Command1_Click()
If CdeclApi_Add = 0 Then
    h = LoadLibrary("cdecl.dll")
    CdeclApi_Add = GetProcAddress(h, "Add")
    FixCdecl GetAddress(AddressOf VB_Add), CdeclApi_Add, 2
End If

Dim a As Long, b As Long, c As Long
a = 44
b = 55

c = VB_Add(a, b)
MsgBox "c=" & c
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
RestoreFunctionMemory
FreeLibrary h
End Sub

---

Module1.bas

Code:

---

Option Explicit
Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Public Const PAGE_EXECUTE_READWRITE As Long = &H40
Private Declare Sub CopyMemory2 Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Declare Function WriteProcessMemory2 Lib "kernel32" Alias "WriteProcessMemory" (ByVal hProcess As Long, ByVal lpBaseAddress As Any, ByVal lpBuffer As Any, ByVal nSize As Long, lpNumberOfBytesWritten As Long) As Long
Private Declare Function VirtualProtect2 Lib "kernel32" Alias "VirtualProtect" (ByRef lpAddress As Any, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long  '设置内存可读写
Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Dim OldFunctionAsm(18) As Byte, FunctionPtr As Long, THUNK_SIZE As Long
'演示用，最简化代码
Function VB_Add(ByVal a As Long, ByVal b As Long, Optional NoUsed As Long) As Long
    MsgBox 1
    MsgBox 1
    MsgBox 1
End Function

Sub FixCdecl(VbFunction As Long, CdeclApi As Long, Args As Long) 'GOOD
  'MsgBox "call-FixCdecl"
    Dim Asm(4) As String, Stub() As Byte ', THUNK_SIZE As Long
    '  0: 58                  pop        eax
    '  1: 89 84 24 XX XX XX XX mov        dword ptr [esp+Xh],eax
    Asm(0) = "58 89 84 24 " & LongToHex(Args * 4) '&H24848958
    Asm(1) = "B8 " & LongToHex(CdeclApi)      'B8 90807000    MOV EAX,708090
    Asm(2) = "FF D0"                          'FFD0          CALL EAX
    Asm(3) = "83 C4 " & Hex(Args * 4) '83 C4 XX      add esp, XX    'cleanup args
    Asm(4) = "C3"
   
    Stub() = toBytes(Join(Asm, " "))
    THUNK_SIZE = UBound(Stub) + 1
   
    Dim bInIDE          As Boolean
    Debug.Assert pvSetTrue(bInIDE)
 
    If bInIDE Then
        CopyMemory2 VbFunction, ByVal VbFunction + &H16, 4
    Else
        VirtualProtect2 VbFunction, THUNK_SIZE, PAGE_EXECUTE_READWRITE, 0    '更改函数地址所在页面属性
    End If
    FunctionPtr = VbFunction
   
    CopyMemory2 ByVal VarPtr(OldFunctionAsm(0)), ByVal VbFunction, THUNK_SIZE '保存函数旧数据
    WriteProcessMemory2 -1, VbFunction, VarPtr(Stub(0)), THUNK_SIZE, 0
End Sub
Sub RestoreFunctionMemory() '恢复原来函数的部分汇编代码,必不可少，否则会崩
    If THUNK_SIZE > 0 Then
        WriteProcessMemory2 -1, FunctionPtr, VarPtr(OldFunctionAsm(0)), THUNK_SIZE, 0
    End If
End Sub
Function toBytes(x As String) As Byte()
    Dim tmp() As String
    Dim fx() As Byte
    Dim i As Long
    tmp = Split(x, " ")
    ReDim fx(UBound(tmp))
    For i = 0 To UBound(tmp)
        fx(i) = CInt("&h" & tmp(i))
    Next
    toBytes = fx()
End Function
 Function LongToHex(x As Long) As String
    Dim b(1 To 4) As Byte
    CopyMemory2 b(1), x, 4
    LongToHex = Hex(b(1)) & " " & Hex(b(2)) & " " & Hex(b(3)) & " " & Hex(b(4))
End Function
 Function pvSetTrue(bValue As Boolean) As Boolean
    bValue = True
    pvSetTrue = True
End Function

Function GetAddress(ByVal V As Long) As Long
GetAddress = V
End Function

---

[VB6] - sSlide - User Control

March 6, 2021, 1:19 am

≫ Next: Freehand drawing with GDI+

≪ Previous: Bind Cdecl Api To vb6 Function(stdcall),support run in IDE

$

0

0

SSlide.zip

This is a user-control likes progressbar.

Attached Images

 

Attached Files

• SSlide.zip (1.7 KB)

Freehand drawing with GDI+

March 9, 2021, 10:11 am

≫ Next: Path Rotation with GDI+

≪ Previous: [VB6] - sSlide - User Control

$

0

0

Illustrates how to perform freehand drawing within a GDI+ path. I needed this capability in an application some time ago but was only able to find one example which used GDI+, but it was done there by continuously updating an array of path points and so it was slow and produced ragged edges.

So I wrote this and it worked fine for me. It is very simple and fast. One caveat - using more transparency i.e. less opacity may cause line caps to become more visible.

Attached Files

• GDIpFreehand.zip (3.5 KB)

Path Rotation with GDI+

March 9, 2021, 10:56 am

≫ Next: (VB6) Compare two controls interfaces

≪ Previous: Freehand drawing with GDI+

$

0

0

Illustrates how to rotate a GDI+ path around a center axis. Uses a simple transformation matrix. Useful for certain drawing applications. I originally wrote this for use with certain elements of a custom user interface.

Attached Files

• GDIP_Path_Rotation.zip (5.1 KB)

---

(VB6) Compare two controls interfaces

March 9, 2021, 1:11 pm

≫ Next: CreateThread Sample--Vfb(Visual Freebasic),vb7,WinFBE

≪ Previous: Path Rotation with GDI+

$

0

0

And tell the differences.

This project is related to the other one: Replicate control interface or encapsulate control into UserControl.

Attached Images

  

Attached Files

• CompareControlsInterfaces_2021-03-10.zip (14.3 KB)

CreateThread Sample--Vfb(Visual Freebasic),vb7,WinFBE

March 11, 2021, 4:11 am

≫ Next: All Freebasic Code Sample,Vfb(Visual Freebasic),Like VB6,VB7

≪ Previous: (VB6) Compare two controls interfaces

$

0

0

Code:

---

Sub Form1_Command2_BN_Clicked(hWndForm As hWnd, hWndControl As hWnd)  '单击
  Dim ABC As String Ptr = New String
  *ABC = "China"

  'CreateThread (NULL,0,@ThreadSub,ABC,0,0)
    Threaddetach ThreadCreate(Cast(Any Ptr ,@ThreadSub) ,ABC)
End Sub

Sub ThreadSub(StrAPtr As String Ptr)
  MsgBox *StrAPtr
  Delete  StrAPtr
End Sub
sub ThreadSub2(Arg1 As LPVOID)
  MsgBox *Cast(String Ptr,Arg1)
  Delete  Arg1
End Sub

Sub ThreadSub3(Arg1 As Any Ptr)
  MsgBox *Cast(String Ptr,Arg1)
  Delete  Arg1
End Sub

---

VB6 has stopped updating for 25 years. We have a development tool similar to VB6. Everyone is welcome to use it together and let the VISUAL BASIC syntax last forever.

vfb(visual freebasic),ide like vb6,vb7.support x64,createthread,asm code
(94) Vfb IDE【Visual Freebasic】Like vb6,vb7,Update2021-2-23 - freebasic.net
https://www.freebasic.net/forum/view...hp?f=8&t=28522
download vfb ide:
https://github.com/xiaoyaocode163/VisualFreeBasic
http://www.yfvb.com/soft-48.htm (version 5.5.3,update:2021-2-23)

All Freebasic Code Sample,Vfb(Visual Freebasic),Like VB6,VB7

March 11, 2021, 4:13 am

≫ Next: Call PrintF,MessageboxW by Asm,Call windows api--Vfb(Visual Freebasic),vb7,WinFBE

≪ Previous: CreateThread Sample--Vfb(Visual Freebasic),vb7,WinFBE

$

0

0

VB6 has stopped updating for 25 years. We have a development tool similar to VB6. Everyone is welcome to use it together and let the VISUAL BASIC syntax last forever.

vfb(visual freebasic),ide like vb6,vb7.support x64,createthread,asm code
(94) Vfb IDE【Visual Freebasic】Like vb6,vb7,Update2021-2-23 - freebasic.net
https://www.freebasic.net/forum/view...hp?f=8&t=28522
download vfb ide:
https://github.com/xiaoyaocode163/VisualFreeBasic
http://www.yfvb.com/soft-48.htm (version 5.5.3,update:2021-2-23)

============================
sample 1:CreateThread Sample--Vfb(Visual Freebasic),vb7,WinFBE-VBForums
https://www.vbforums.com/showthread....68#post5513868

sample2:vfb use Miniblink ,chromium,Chrome core only one dll-VBForums

Sample3: Call PrintF,MessageboxW by Asm,Call windows api--Vfb(Visual Freebasic),vb7,WinFBE

Call PrintF,MessageboxW by Asm,Call windows api--Vfb(Visual Freebasic),vb7,WinFBE

March 11, 2021, 5:13 am

≫ Next: sorry,Chrome OCX,Miniblink,VB6 chromium,Chrome core only one dll

≪ Previous: All Freebasic Code Sample,Vfb(Visual Freebasic),Like VB6,VB7

$

0

0

Code:

---

dim as string frmt = !"%s %s\n"
dim as string hello = "Hello"
dim as string world = "world"
asm
      mov  eax, [world]
      push eax
      mov  eax, [hello]
      push eax
      mov  eax, [frmt]
      push eax
      call printf
      'clean up the stack so that main can exit cleanly
      'use the unused register ebx to do the cleanup
      pop  ebx
      pop  ebx
      pop  ebx
end asm   

Sub AsmMessageboxW()
  Dim sText as WString*50="Info"
  Dim sCaption as WString*50="TitleStr"
  Asm
      push 0
      lea edi,[sCaption]
      lea esi,[sText]
      PUSH EDI
      push esi
      push 0
      Call MessageBoxw
  End asm
End Sub

---

Code:

---

Sub AsmMessageboxA()
Dim sText as String
sText="Info" 
Dim sCaption as String
sCaption ="TitleStr"       

  Asm
      push 0
      lea edi,[sCaption]
      lea esi,[sText]
      PUSH [edi]
      push [esi]
      push 0
      Call MessageBoxA   
  End asm

End Sub

---

Code:

---

  Sub AsmMessageboxW()
'Need to set the properties of the project to :UNICODE mode
' This is the standard way of writing. Remember, the string that interacts with the API must be a zStr or wStr pointer.
Dim sText as WString PTR
Dim sCaption as WString PTR
sText=@"Info" 
sCaption =@"TitleStr"       

  Asm
      push 0
      push [sCaption]
      push [sText]
      push 0
      Call MessageBoxW   
  End asm
End Sub

---

VB6 has stopped updating for 25 years. We have a development tool similar to VB6. Everyone is welcome to use it together and let the VISUAL BASIC syntax last forever.

vfb(visual freebasic),ide like vb6,vb7.support x64,createthread,asm code
(94) Vfb IDE【Visual Freebasic】Like vb6,vb7,Update2021-2-23 - freebasic.net
https://www.freebasic.net/forum/view...hp?f=8&t=28522
download vfb ide:
https://github.com/xiaoyaocode163/VisualFreeBasic
http://www.yfvb.com/soft-48.htm (version 5.5.3,update:2021-2-23)

sorry,Chrome OCX,Miniblink,VB6 chromium,Chrome core only one dll

March 13, 2021, 7:21 am

≫ Next: [VB6] Simple VNC Server using DXGI Desktop Duplication

≪ Previous: Call PrintF,MessageboxW by Asm,Call windows api--Vfb(Visual Freebasic),vb7,WinFBE

$

0

0

Chrome OCX,Miniblink,VB6 chromium,Chrome core only one dll
download node.dll from here:
https://github.com/weolar/miniblink49/releases
GitHub - imxcstar/vb6-miniblink-SBrowser: Miniblink control made with vb6 encapsulates all APIs of miniblink free version
https://github.com/imxcstar/vb6-miniblink-SBrowser

GitHub - weolar/miniblink49: a lighter, faster browser kernel of blink to integrate HTML UI in your app. A small, lightweight browser kernel to replace wke和libcef
https://github.com/weolar/miniblink49

This is a good Google Chrome control, free and open source. And the author is not me.

I've been sharing and uploading for free for almost a year. And I've never used it myself.


one developer was working on a software development project the other day and needed to use this control. He can't use it, and he needs me to develop many new functions for him. He contacted me on his own initiative and wanted to pay me some fees to help him develop the work project. This project is not mine, I have no obligation to unconditionally fix all bugs free of charge,If someone needs to develop Russian language for him or spend tens of thousands of dollars to add other functions, I have to give him free production, I can't help it.


Other people's projects were originally free, and I share them with you. Am I obligated to answer all technical questions unconditionally?

We just found some good source code, free to share for everyone to use.
If you need to add some functions, or fix some software technical bugs, you can ask to share it. Can you complete the free and unconditional modification and ask him to add any more functions? Am I his boss? But I didn't pay him salary.

[VB6] Simple VNC Server using DXGI Desktop Duplication

March 14, 2021, 3:22 pm

≫ Next: The fastest way to download web pages(GET,POST)

≪ Previous: sorry,Chrome OCX,Miniblink,VB6 chromium,Chrome core only one dll

$

0

0

https://github.com/wqweto/VbVncServer

A single-class VNC server for embedding in LOB applications for built-in client support.

Very much work in progress but first cut seems to work.

Based on RFC 6143 and can be used with any VNC viewer like RealVNC or any other you prefer best.

cheers,
</wqw>

The fastest way to download web pages(GET,POST)

March 16, 2021, 5:35 am

≫ Next: vb6 Show Gif Movie by ActiveMovie control(DirectShow),WebBrowser

≪ Previous: [VB6] Simple VNC Server using DXGI Desktop Duplication

$

0

0

Research using multiple methods to download web pages and choose the fastest solution

One of the test application examples：
best way to get or save utf-8 content url faster?(https support)-VBForums
https://www.vbforums.com/showthread....https-support)

in my computer, i don't khnow why WinHttpRequest is slowly
WinHttp.WinHttpRequest.5.1,Used 28 seconds
Xmlhttp used 5 seconds

Download Sample Xmlhttp_WithEvent-2.zip

test result:
2021/3/16 21:39:29 --Xmlhttp DownStart
2021/3/16 21:39:29 --XmlhttpState=1(UsedTime=6.8953 Ms)
2021/3/16 21:39:34 --XmlhttpState=2(UsedTime=4597.2895 Ms)
2021/3/16 21:39:34 --XmlhttpState=3(UsedTime=4598.3393 Ms)
2021/3/16 21:39:34 --XmlhttpState=4(UsedTime=4599.6692 Ms)
DownLoad Url UsedTime=4599.6692 Milliseconds ,Size=318284
------------
2021/3/16 21:31:57 --XmlhttpState=1
2021/3/16 21:32:01 --XmlhttpState=2
2021/3/16 21:32:01 --XmlhttpState=3
2021/3/16 21:32:13 --XmlhttpState=4
DownLoad Url UsedTime=15834.51 Milliseconds

Code:

---

Private Declare Function timeBeginPeriod Lib "winmm.dll" _
  (ByVal uPeriod As Long) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long

Private Sub Form_Load()
timeBeginPeriod 1
End Sub

---

Method 1:
Reference DLL:Microsoft scripting runtime,Microsoft Active Data Object,Microsoft MsXml

Code:

---

Public Function doSome() 'Set AS Class Default Method
    QueryPerformanceCounter CPUv2
    UsedTime1 = (CPUv2 - CPUv1) / MsCount
    Debug.Print Now & " --XmlhttpState=" & XmlhttpObj.readyState & "(UsedTime=" & UsedTime1 & " Ms)"
 
  If XmlhttpObj.readyState = 4 Then
    On Error Resume Next
    Dim bt() As Byte, Bytes As Long
    bt = XmlhttpObj.responseBody
    Bytes = UBound(bt) + 1
    Debug.Print "DownLoad Url UsedTime=" & UsedTime1 & " Milliseconds ,Size=" & Bytes
        Form1.Command1.Caption = "DownLoad Used " & UsedTime1 & " Milliseconds"
    Call SaveByte
  End If
End Function

---

Form1 code

Code:

---


  Public a As MSXML2.XMLHTTP
 

Private Sub Command1_Click()
  Dim d As Class1
  Set a = New MSXML2.XMLHTTP
  a.open "get", "http://www.ljc.com/sll.txt", True
  Set d = New Class1
  a.onreadystatechange = d
  a.send
End Sub

---

Class1 CODE：

Code:

---

Dim b As ADODB.Stream
 Dim fso As Scripting.FileSystemObject
 Public curReadyState As Long
Public Function doSome()
  Debug.Print Form1.a.readyState
  If Form1.a.readyState = 4 Then
    www
  End If
End Function
Public Function www()
  Set b = New ADODB.Stream
  b.Type = 1
  b.open
  Set fso = New Scripting.FileSystemObject
  If Form1.a.readyState = 4 Then
        b.Write (Form1.a.responseBody)
        If Not fso.FileExists("c:/mmm.txt") Then
          b.SaveToFile "c:/mmm.txt"
        End If
  End If
  b.Close
  Set b = Nothing
  Set fso = Nothing
End Function

---

Attached Files

• Xmlhttp_WithEvent-2.zip (12.7 KB)

---

vb6 Show Gif Movie by ActiveMovie control(DirectShow),WebBrowser

March 16, 2021, 7:25 am

≫ Next: vb6 Gif Ocx/Png OCX,Show Movie by DirectShow,WebBrowser,AniGif.OCX

≪ Previous: The fastest way to download web pages(GET,POST)

$

0

0

Code:

---

Private pMC As FilgraphManager
Private pVW As IVideoWindow

Private Sub Form_Load()
'Reference quartz.dll#ActiveMovie control type library

Me.ScaleMode = 3
Picture1.ScaleMode = 3
End Sub

Private Sub Command1_Click()
ActiveMovie_ShowGif App.Path & "\001.gif"
End Sub

Private Sub Command2_Click()
    StopClear
End Sub
Sub ActiveMovie_ShowGif(GifFile As String)
        On Error Resume Next
        Set pMC = New FilgraphManager
        pMC.Stop
        pMC.RenderFile ""
       
 
        On Error GoTo Lhandle
        pMC.RenderFile GifFile
       
        On Error Resume Next
        Set pVW = pMC
        pVW.WindowStyle = CLng(&H6000000)
       

        pVW.Left = 0: pVW.Top = 0
        Picture1.Width = pVW.Width
        Picture1.Height = pVW.Width
        'pVW.Width = Picture1.ScaleWidth
        'pVW.Height = Picture1.ScaleHeight
       
        pVW.Owner = Picture1.hWnd
        pVW.MessageDrain = Picture1.hWnd
        pMC.Run
       
        Exit Sub
Lhandle:
        MsgBox ("err")
End Sub

Sub StopClear()
        pMC.Stop
        Set pVW = Nothing
        Set pMC = Nothing
End Sub

---

vb6 Gif Ocx/Png OCX,Show Movie by DirectShow,WebBrowser,AniGif.OCX

March 16, 2021, 7:25 am

≫ Next: Neumorphism Design

≪ Previous: vb6 Show Gif Movie by ActiveMovie control(DirectShow),WebBrowser

$

0

0

Usercontrol.ctl about Webbrowser GIF(PNG ,JPG),Support Url,Localdisk File
[gif ocx,Png ocx] activex control

Code:

---

Dim WithEvents M_Dom As MSHTML.HTMLDocument
Public Event ImgClick()
Private Url As String
'Usercontrol Name:WebImgOcx

Private Sub UserControl_Initialize()
'add Webbrowser to Usercontrol
UserControl.ScaleMode = 3
WebBrowser1.Visible = False
End Sub

Public Property Get ImgUrl() As String
    ImgUrl = Url
End Property

Public Property Let ImgUrl(ByVal vNewValue As String)
Url = vNewValue
If Url <> "" Then
    WebBrowser1.Visible = True
    SetImg Url
Else
    WebBrowser1.Visible = False
End If
End Property
 

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  ImgUrl = PropBag.ReadProperty("ImgUrl", "")
End Sub
 

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
 PropBag.WriteProperty "ImgUrl", ImgUrl
End Sub
 

Sub SetImg(UrlA As String)
    Url = UrlA
    WebBrowser1.Navigate Url
End Sub
Private Function M_Dom_onclick() As Boolean
    RaiseEvent ImgClick
End Function

Private Sub WebBrowser1_DocumentComplete(ByVal pDisp As Object, Url As Variant)
If Url = "" Then Exit Sub
    Dim body As Object
    Set M_Dom = WebBrowser1.Document
    Set body = WebBrowser1.Document.body
   
    body.Scroll = "no"
    body.Style.border = "none"
    body.leftMargin = 0
    body.topMargin = 0
   
       
    WebBrowser1.Width = body.All(0).clientWidth
    WebBrowser1.Height = body.All(0).clientHeight
    UserControl.Width = WebBrowser1.Width * Screen.TwipsPerPixelX
    UserControl.Height = WebBrowser1.Height * Screen.TwipsPerPixelY
   
   
    Call WebBrowser1.Document.parentWindow.execScript("document.body.ondragstart=function(){return false}", "javascript") 'good
    Call WebBrowser1.Document.parentWindow.execScript("document.body.oncontextmenu=function(){return false}", "javascript") 'good '禁止右键
End Sub

---

CALL Usercontrol OCX IN FORM1

Code:

---

WebImgOcx2.Imgurl="http://www.a.com/123.gif"

Private Sub WebImgOcx2_ImgClick()
 MsgBox WebImgOcx2.ImgUrl
End Sub

---

Attached Images

 

Attached Files

• GifOcx_PngOcx.zip (60.1 KB)
• WebBrowserShowGif.zip (7.5 KB)

Neumorphism Design

March 16, 2021, 7:31 pm

≫ Next: [VB6] In memory convert to JPEG using WIC

≪ Previous: vb6 Gif Ocx/Png OCX,Show Movie by DirectShow,WebBrowser,AniGif.OCX

$

0

0

In this case, it is, on the one hand, a class Module and, on the other, a Usercontrol to create a modern user interface called Neumorphism, which began to become fashionable as of 2020, although it is designed for mobile applications or webs I see no reason not to implement it in our beloved vb6, at least in small applications so as not to overload memory and slow down our app. The whole engine is based on GDI +.

With the class module there is an example where we can play with the properties of the class and other forms with some graphical examples.
In addition, this allows you to draw a GDI + Path with which an extra module was used, where you can create different shapes (Shapes) and the style can be applied to them, I take the opportunity to thank Eduardo for taking part in the routines of his ShapeEx. and thank you very much to SomeYguy for the rutine to rotate path.

With the Usercontrol there are three applied examples. I am not going to detail all the properties, it is a matter of reaching out and playing a bit, they are the same as the module. Accompanying the examples is the "LabelPlus" usercontrol, which is to add text and icons to the forms, (I didn't want to reprogram all this, that's why I used two usercontrols).

Later I am going to upload a music player in which I am working where you can see all this applied.

Finally I want to clarify that all this works faster when it is compiled.



Neumorphism.zip

Attached Images

    

Attached Files

• Neumorphism.zip (237.4 KB)

[VB6] In memory convert to JPEG using WIC

March 21, 2021, 10:35 am

≫ Next: Get Rgb info by GdipBitmapLockBits,Read Bitmap into a 2D array

≪ Previous: Neumorphism Design

$

0

0

This uses Windows Imaging Component to convert a bitmap (a 32-bit DIB) to a JPEG stream purely in memory.

Paste the following code in a .bas module:

Code:

---

Option Explicit

Private Declare Function SHCreateMemStream Lib "shlwapi" Alias "#12" (pInit As Any, ByVal cbInit As Long) As stdole.IUnknown
Private Declare Function IStream_Size Lib "shlwapi" (ByVal pStream As stdole.IUnknown, uiSize As Any) As Long
Private Declare Function IStream_Reset Lib "shlwapi" (ByVal pStream As stdole.IUnknown) As Long
Private Declare Function IStream_Read Lib "shlwapi" (ByVal pStream As stdole.IUnknown, pvBuf As Any, ByVal cbSize As Long) As Long
'--- WIC
Private Declare Function WICCreateImagingFactory_Proxy Lib "windowscodecs" (ByVal SDKVersion As Long, ppIImagingFactory As stdole.IUnknown) As Long
Private Declare Function IWICImagingFactory_CreateStream_Proxy Lib "windowscodecs" (ByVal pFactory As stdole.IUnknown, ppIWICStream As stdole.IUnknown) As Long
Private Declare Function IWICImagingFactory_CreateEncoder_Proxy Lib "windowscodecs" (ByVal pFactory As stdole.IUnknown, guidContainerFormat As Any, pguidVendor As Any, ppIEncoder As stdole.IUnknown) As Long
Private Declare Function IWICImagingFactory_CreateBitmapFromMemory_Proxy Lib "windowscodecs" (ByVal pFactory As stdole.IUnknown, ByVal uiWidth As Long, ByVal uiHeight As Long, pixelFormat As Any, ByVal cbStride As Long, ByVal cbBufferSize As Long, pbBuffer As Any, ppIBitmap As stdole.IUnknown) As Long
Private Declare Function IWICStream_InitializeFromIStream_Proxy Lib "windowscodecs" (ByVal pIWICStream As stdole.IUnknown, ByVal pIStream As stdole.IUnknown) As Long
Private Declare Function IWICBitmapEncoder_Initialize_Proxy Lib "windowscodecs" (ByVal pIEncoder As stdole.IUnknown, ByVal pIStream As stdole.IUnknown, ByVal cacheOption As Long) As Long
Private Declare Function IWICBitmapEncoder_CreateNewFrame_Proxy Lib "windowscodecs" (ByVal pIEncoder As stdole.IUnknown, ppIFrameEncode As stdole.IUnknown, ppIEncoderOptions As stdole.IUnknown) As Long
Private Declare Function IWICBitmapEncoder_Commit_Proxy Lib "windowscodecs" (ByVal pIEncoder As stdole.IUnknown) As Long
Private Declare Function IWICBitmapFrameEncode_Initialize_Proxy Lib "windowscodecs" (ByVal pIFrameEncode As stdole.IUnknown, ByVal pIEncoderOptions As stdole.IUnknown) As Long
Private Declare Function IWICBitmapFrameEncode_SetSize_Proxy Lib "windowscodecs" (ByVal pIFrameEncode As stdole.IUnknown, ByVal uiWidth As Long, ByVal uiHeight As Long) As Long
Private Declare Function IWICBitmapFrameEncode_WriteSource_Proxy Lib "windowscodecs" (ByVal pIFrameEncode As stdole.IUnknown, ByVal pIBitmapSource As stdole.IUnknown, pWicRect As Any) As Long
Private Declare Function IWICBitmapFrameEncode_Commit_Proxy Lib "windowscodecs" (ByVal pIFrameEncode As stdole.IUnknown) As Long
Private Declare Function IPropertyBag2_Write_Proxy Lib "windowscodecs" (ByVal pPropBag As stdole.IUnknown, ByVal cProperties As Long, pBag As Any, pvarValue As Variant) As Long

Private m_pWicFactory          As stdole.IUnknown

Public Function WicConvertToJpeg(baOutput() As Byte, ByVal lWidth As Long, ByVal lHeight As Long, baInput() As Byte, ByVal lQuality As Long) As Boolean
    Const WINCODEC_SDK_VERSION1  As Long = &H236&
    Const WINCODEC_SDK_VERSION2  As Long = &H237&
    Const WICBitmapEncoderNoCache As Long = 2
    Dim aGUID(0 To 3)  As Long
    Dim pBitmap        As stdole.IUnknown
    Dim pWicStream      As stdole.IUnknown
    Dim pStream        As stdole.IUnknown
    Dim pEncoder        As stdole.IUnknown
    Dim pFrame          As stdole.IUnknown
    Dim pPropBag        As stdole.IUnknown
    Dim cSize          As Currency
    Dim aBag(0 To 7)    As Long
   
    On Error GoTo EH
    If m_pWicFactory Is Nothing Then
        If WICCreateImagingFactory_Proxy(WINCODEC_SDK_VERSION2, m_pWicFactory) < 0 Then
            If pvCheckHResult(WICCreateImagingFactory_Proxy(WINCODEC_SDK_VERSION1, m_pWicFactory)) < 0 Then
                GoTo QH
            End If
        End If
    End If
    '--- GUID_WICPixelFormat32bppPBGRA
    aGUID(0) = &H6FDDC324
    aGUID(1) = &H4BFE4E03
    aGUID(2) = &H773D85B1
    aGUID(3) = &H10C98D76
    If pvCheckHResult(IWICImagingFactory_CreateBitmapFromMemory_Proxy(m_pWicFactory, lWidth, lHeight, aGUID(0), lWidth * 4, UBound(baInput) + 1, baInput(0), pBitmap)) < 0 Then
        GoTo QH
    End If
    If pvCheckHResult(IWICImagingFactory_CreateStream_Proxy(m_pWicFactory, pWicStream)) < 0 Then
        GoTo QH
    End If
    Set pStream = SHCreateMemStream(ByVal 0, 0)
    If pvCheckHResult(IWICStream_InitializeFromIStream_Proxy(pWicStream, pStream)) < 0 Then
        GoTo QH
    End If
    '--- GUID_ContainerFormatJpeg
    aGUID(0) = &H19E4A5AA
    aGUID(1) = &H4FC55662
    aGUID(2) = &H5817C0A0
    aGUID(3) = &H57108E02
    If pvCheckHResult(IWICImagingFactory_CreateEncoder_Proxy(m_pWicFactory, aGUID(0), ByVal 0, pEncoder)) < 0 Then
        GoTo QH
    End If
    If pvCheckHResult(IWICBitmapEncoder_Initialize_Proxy(pEncoder, pWicStream, WICBitmapEncoderNoCache)) < 0 Then
        GoTo QH
    End If
    If pvCheckHResult(IWICBitmapEncoder_CreateNewFrame_Proxy(pEncoder, pFrame, pPropBag)) < 0 Then
        GoTo QH
    End If
    aBag(3) = StrPtr("ImageQuality")
    If pvCheckHResult(IPropertyBag2_Write_Proxy(pPropBag, 1, aBag(0), CSng(lQuality) / 100!)) < 0 Then
        GoTo QH
    End If
    If pvCheckHResult(IWICBitmapFrameEncode_Initialize_Proxy(pFrame, pPropBag)) < 0 Then
        GoTo QH
    End If
    If pvCheckHResult(IWICBitmapFrameEncode_SetSize_Proxy(pFrame, lWidth, lHeight)) < 0 Then
        GoTo QH
    End If
    If pvCheckHResult(IWICBitmapFrameEncode_WriteSource_Proxy(pFrame, pBitmap, ByVal 0)) < 0 Then
        GoTo QH
    End If
    If pvCheckHResult(IWICBitmapFrameEncode_Commit_Proxy(pFrame)) < 0 Then
        GoTo QH
    End If
    If pvCheckHResult(IWICBitmapEncoder_Commit_Proxy(pEncoder)) < 0 Then
        GoTo QH
    End If
    If pvCheckHResult(IStream_Size(pStream, cSize)) < 0 Then
        GoTo QH
    End If
    cSize = cSize * 10000
    If pvCheckHResult(IStream_Reset(pStream)) < 0 Then
        GoTo QH
    End If
    If cSize > 0 Then
        ReDim baOutput(0 To cSize - 1) As Byte
        If pvCheckHResult(IStream_Read(pStream, baOutput(0), cSize)) < 0 Then
            GoTo QH
        End If
    Else
        baOutput = vbNullString
    End If
    '--- success
    WicConvertToJpeg = True
QH:
    Exit Function
EH:
    Debug.Print Err.Description
End Function

Private Function pvCheckHResult(ByVal hResult As Long) As Long
    If hResult < 0 Then
        Err.Raise hResult
    End If
    pvCheckHResult = pvCheckHResult
End Function

---

Here is the sample Form1 that exercises the WicConvertToJpeg function above

Code:

---

Option Explicit

Private Declare Function DeleteFile Lib "kernel32" Alias "DeleteFileA" (ByVal lpFileName As String) As Long

Private Sub Form_Load()
    Dim lWidth          As Long
    Dim lHeight        As Long
    Dim baBitmap()      As Byte
    Dim baJpeg()        As Byte
   
    If Not WicLoadPicture("d:\temp\aaa.bmp", lWidth, lHeight, baBitmap) Then
        GoTo QH
    End If
    If Not WicConvertToJpeg(baJpeg, lWidth, lHeight, baBitmap, 80) Then
        GoTo QH
    End If
    WriteBinaryFile "d:\temp\aaa.jpg", baJpeg
QH:
End Sub

Public Sub WriteBinaryFile(sFile As String, baBuffer() As Byte)
    Dim nFile          As Integer
   
    Call DeleteFile(sFile)
    nFile = FreeFile
    Open sFile For Binary Access Write Shared As nFile
    If UBound(baBuffer) >= 0 Then
        Put nFile, , baBuffer
    End If
    Close nFile
End Sub

---

The test code above needs another .bas module with the WicLoadPicture function

Code:

---

Option Explicit

'--- WIC
Private Declare Function WICCreateImagingFactory_Proxy Lib "windowscodecs" (ByVal SDKVersion As Long, ppIImagingFactory As stdole.IUnknown) As Long
Private Declare Function IWICImagingFactory_CreateDecoderFromFilename_Proxy Lib "windowscodecs" (ByVal pFactory As stdole.IUnknown, ByVal wzFilename As Long, pguidVendor As Any, ByVal dwDesiredAccess As Long, ByVal lMetadataOptions As Long, ppIDecoder As stdole.IUnknown) As Long
Private Declare Function IWICImagingFactory_CreateFormatConverter_Proxy Lib "windowscodecs" (ByVal pFactory As stdole.IUnknown, ppIFormatConverter As stdole.IUnknown) As Long
Private Declare Function IWICBitmapDecoder_GetFrame_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, ByVal lIndex As Long, ppIBitmapFrame As stdole.IUnknown) As Long
Private Declare Function IWICBitmapSource_CopyPixels_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, prc As Any, ByVal cbStride As Long, ByVal cbBufferSize As Long, pbBuffer As Any) As Long
Private Declare Function IWICBitmapSource_GetSize_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, puiWidth As Long, puiHeight As Long) As Long
Private Declare Function IWICFormatConverter_Initialize_Proxy Lib "windowscodecs" (ByVal pThis As stdole.IUnknown, ByVal pISource As stdole.IUnknown, dstFormat As Any, ByVal lDither As Long, ByVal pIPalette As stdole.IUnknown, ByVal dblAlphaThresholdPercent As Double, ByVal lPaletteTranslate As Long) As Long

Private m_pWicFactory          As stdole.IUnknown

Public Function WicLoadPicture( _
            sFileName As String, _
            lWidth As Long, _
            lHeight As Long, _
            baOutput() As Byte) As Boolean
    Const WINCODEC_SDK_VERSION1 As Long = &H236&
    Const WINCODEC_SDK_VERSION2 As Long = &H237&
    Const GENERIC_READ          As Long = &H80000000
    Dim pDecoder        As stdole.IUnknown
    Dim pFrame          As stdole.IUnknown
    Dim pConverter      As stdole.IUnknown
    Dim aGUID(0 To 3)  As Long
   
    If m_pWicFactory Is Nothing Then
        If WICCreateImagingFactory_Proxy(WINCODEC_SDK_VERSION2, m_pWicFactory) < 0 Then
            If pvCheckHResult(WICCreateImagingFactory_Proxy(WINCODEC_SDK_VERSION1, m_pWicFactory)) < 0 Then
                GoTo QH
            End If
        End If
    End If
    If pvCheckHResult(IWICImagingFactory_CreateDecoderFromFilename_Proxy(m_pWicFactory, StrPtr(sFileName), ByVal 0, GENERIC_READ, 0, pDecoder)) < 0 Or pDecoder Is Nothing Then
        GoTo QH
    End If
    If pvCheckHResult(IWICBitmapDecoder_GetFrame_Proxy(pDecoder, 0, pFrame)) < 0 Or pFrame Is Nothing Then
        GoTo QH
    End If
    If pvCheckHResult(IWICBitmapSource_GetSize_Proxy(pFrame, lWidth, lHeight)) < 0 Then
        GoTo QH
    End If
    If pvCheckHResult(IWICImagingFactory_CreateFormatConverter_Proxy(m_pWicFactory, pConverter)) < 0 Or pConverter Is Nothing Then
        GoTo QH
    End If
    '--- GUID_WICPixelFormat32bppPBGRA
    aGUID(0) = &H6FDDC324
    aGUID(1) = &H4BFE4E03
    aGUID(2) = &H773D85B1
    aGUID(3) = &H10C98D76
    If pvCheckHResult(IWICFormatConverter_Initialize_Proxy(pConverter, pFrame, aGUID(0), 0, Nothing, 0#, 0)) < 0 Then
        GoTo QH
    End If
    ReDim baOutput(0 To lWidth * lHeight * 4 - 1) As Byte
    If pvCheckHResult(IWICBitmapSource_CopyPixels_Proxy(pConverter, ByVal 0&, lWidth * 4, lWidth * lHeight * 4, baOutput(0))) < 0 Then
        GoTo QH
    End If
    '--- success
    WicLoadPicture = True
QH:
End Function

Private Function pvCheckHResult(ByVal hResult As Long) As Long
    If hResult < 0 Then
        Err.Raise hResult
    End If
    pvCheckHResult = pvCheckHResult
End Function

---

Posted all this code with all API declares to be searchable in the forums as WIC is quite apocryphal technology here.

cheers,
</wqw>

Get Rgb info by GdipBitmapLockBits,Read Bitmap into a 2D array

March 22, 2021, 9:10 pm

≫ Next: Transparent Control By Multiple transparent windows form

≪ Previous: [VB6] In memory convert to JPEG using WIC

$

0

0

Read Bitmap into a 2D array
test in form1.frm

Code:

---

Private Sub Form_Load()
StartUpGDIPlus

Dim Data() As RgbType
Data = GetPicBmpData_RGB(App.Path & "\BMP1.bmp")

MsgBox "One Pixel rgb=" & Data(0, 0).Red & "," & Data(0, 0).Green & "," & Data(0, 0).Blue
'One Pixel rgb=2,22,222
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
CloseGdiPlus
End Sub

---

in bas:

Code:

---

Option Explicit

  Enum Status
    OK = 0
    GenericError = 1
    InvalidParameter = 2
    OutOfMemory = 3
    ObjectBusy = 4
    InsufficientBuffer = 5
    NotImplemented = 6
    Win32Error = 7
    WrongState = 8
    Aborted = 9
    FileNotFound = 10
    ValueOverflow = 11
    AccessDenied = 12
    UnknownImageFormat = 13
    FontFamilyNotFound = 14
    FontStyleNotFound = 15
    NotTrueTypeFont = 16
    UnsupportedGdiplusVersion = 17
    GdiplusNotInitialized = 18
    PropertyNotFound = 19
    PropertyNotSupported = 20
    ProfileNotFound = 21
End Enum

Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type

Private Type GdiplusStartupOutput
    NotificationHook As Long
    NotificationUnhook As Long
End Type

Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal image As Long) As Status
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Status
Private Declare Function GdiplusStartup Lib "GDIPlus" (ByRef token As Long, ByRef lpInput As GdiplusStartupInput, ByRef lpOutput As GdiplusStartupOutput) As Status
Private Const GdiplusVersion As Long = 1&
 

Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, Bitmap As Long) As Long

Public Declare Function GdipGetImageWidth Lib "GDIPlus" ( _
    ByVal pImage As Long, _
    ByRef nWidth As Long _
) As Long
Public Declare Function GdipGetImageHeight Lib "GDIPlus" ( _
    ByVal pImage As Long, _
    ByRef nHeight As Long _
) As Long
Public Declare Function GdipBitmapLockBits Lib "GDIPlus" ( _
    ByVal pBitmap As Long, _
    ByRef prect As RECTL, _
    ByVal Flags As Long, _
    ByVal pixelFormat As Long, _
    ByRef lockedBitmapData As BitmapData _
) As Long

Public Type BitmapData
  Width As Long
  Height As Long
  Stride As Long
  pixelFormat As Long
  Scan0 As Long
  Reserved As Long
End Type
'
Public Type RECTL
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Public Type Argb
    Blue As Byte
    Green As Byte
    Red As Byte
    Alphi As Byte
End Type

Public Type RgbType
    Blue As Byte
    Green As Byte
    Red As Byte
End Type

Public Enum ImageLockMode
    ImageLockModeRead = &H1
    ImageLockModeWrite = &H2
    ImageLockModeUserInputBuf = &H4
End Enum
'
Public Enum PixelFormats
    PixelFormat24bppRGB = &H21808
    PixelFormat32bppRGB = &H22009
    PixelFormat32bppARGB = &H26200A
    PixelFormat32bppPARGB = &HD200B
End Enum
 Dim lngGdipToken As Long
  Function StartUpGDIPlus(Optional ByVal GdipVersion As Long = GdiplusVersion) As Boolean
 
    Dim GdipStartupInput As GdiplusStartupInput
    Dim GdipStartupOutput As GdiplusStartupOutput
    GdipStartupInput.GdiplusVersion = GdipVersion
    If GdiplusStartup(lngGdipToken, GdipStartupInput, GdipStartupOutput) = OK Then
        StartUpGDIPlus = True
    End If
End Function
Sub CloseGdiPlus()
    GdiplusShutdown lngGdipToken
End Sub


Function GetPicBmpData(File1 As String, Optional W As Long, Optional H As Long) As Byte()
Dim Bitmap As Long, RC As RECTL
Dim Data() As Byte

 
    GdipCreateBitmapFromFile StrPtr(File1), Bitmap
    GdipGetImageWidth Bitmap, W
    GdipGetImageHeight Bitmap, H
RC.Right = W
RC.Bottom = H

 Dim FormatID As Long, Wsize As Long
 FormatID = PixelFormat32bppARGB
 Wsize = 4
 
' FormatID = PixelFormat24bppRGB
'Wsize = 3
    ReDim Data(RC.Right * Wsize * RC.Bottom - 1)
 
    Dim BmpData As BitmapData
    With BmpData
        .Width = W
        .Height = H
 
        .pixelFormat = FormatID
        '.Scan0 = VarPtr(data(0, 0))
        .Scan0 = VarPtr(Data(0))
        .Stride = Wsize * CLng(W)
    End With
 
    GdipBitmapLockBits Bitmap, RC, ImageLockModeUserInputBuf Or ImageLockModeWrite Or ImageLockModeRead, FormatID, BmpData
    GetPicBmpData = Data
    GdipDisposeImage Bitmap
End Function

 
Function GetPicBmpDataXY(File1 As String) As Long()
Dim Bitmap As Long
Dim RC As RECTL
Dim Data() As Long 'DATA(W,H),LONG TYPE=4 BYTE,ARGB
Dim tdata() As Long

GdipCreateBitmapFromFile StrPtr(File1), Bitmap
GdipGetImageWidth Bitmap, RC.Right
  GdipGetImageHeight Bitmap, RC.Bottom
  ReDim Data(RC.Bottom - 1, RC.Right - 1)
  ReDim tdata(RC.Bottom - 1, RC.Right - 1)
  Dim BmpData As BitmapData
  Dim FormatID As Long
  FormatID = PixelFormat32bppARGB

  With BmpData
    .Width = RC.Right
    .Height = RC.Bottom
    .pixelFormat = FormatID
    .Scan0 = VarPtr(Data(0, 0))
    .Stride = 4 * CLng(RC.Right)
  End With
  GdipBitmapLockBits Bitmap, RC, ImageLockModeUserInputBuf Or ImageLockModeWrite Or ImageLockModeRead, FormatID, BmpData
  GetPicBmpDataXY = Data()
End Function

 

Function GetPicBmpData_Argb(File1 As String) As Argb()
Dim Bitmap As Long
Dim RC As RECTL
Dim Data() As Argb 'DATA(W,H),LONG TYPE= ARGB

GdipCreateBitmapFromFile StrPtr(File1), Bitmap
GdipGetImageWidth Bitmap, RC.Right
  GdipGetImageHeight Bitmap, RC.Bottom
 
  ReDim Data(RC.Bottom - 1, RC.Right - 1)

  Dim BmpData As BitmapData
  Dim FormatID As Long
  FormatID = PixelFormat32bppARGB

  With BmpData
    .Width = RC.Right
    .Height = RC.Bottom
    .pixelFormat = FormatID
    .Scan0 = VarPtr(Data(0, 0))
    .Stride = 4 * CLng(RC.Right)
  End With
  GdipBitmapLockBits Bitmap, RC, ImageLockModeUserInputBuf Or ImageLockModeWrite Or ImageLockModeRead, FormatID, BmpData
  GetPicBmpData_Argb = Data()
  GdipDisposeImage Bitmap
End Function

---

get rgb info:

Code:

---

Public Type RgbType
    Blue As Byte
    Green As Byte
    Red As Byte
End Type

Function GetPicBmpData_RGB(File1 As String) As RgbType()
Dim Bitmap As Long
Dim RC As RECTL
Dim Data() As RgbType 'DATA(W,H),LONG TYPE= RGB

GdipCreateBitmapFromFile StrPtr(File1), Bitmap
GdipGetImageWidth Bitmap, RC.Right
  GdipGetImageHeight Bitmap, RC.Bottom
 
  ReDim Data(RC.Bottom - 1, RC.Right - 1)

  Dim BmpData As BitmapData
  Dim FormatID As Long
  FormatID = PixelFormat24bppRGB

  With BmpData
    .Width = RC.Right
    .Height = RC.Bottom
    .pixelFormat = FormatID
    .Scan0 = VarPtr(Data(0, 0))
    .Stride = 3 * CLng(RC.Right)
  End With
  GdipBitmapLockBits Bitmap, RC, ImageLockModeUserInputBuf Or ImageLockModeWrite Or ImageLockModeRead, FormatID, BmpData
  GdipDisposeImage Bitmap
  GetPicBmpData_RGB = Data()
End Function

---

Attached Images