VB6 modArrInfo (Array-introspection without Error-Handlers)

October 17, 2021, 10:39 am

≫ Next: Color Pickers six different styles

≪ Previous: My Simple Marquee

$

0

0

Since there's so many often badly written (or incomplete) Array-check-routines floating around,
here's a Drop-In-Module (you might name it e.g. modArrInfo.bas).

With that, you can then perform complete Array-instrospection, like shown in the Test-Formcode below:

Code:

---

Option Explicit
 
Private Sub Form_Load()
  Dim Arr() As String
      Arr = Split("") 'check with an intialized, but not yet redimmed Array (comment out to test an un-initialized case)
      'ReDim Arr(1 To 5, 0 To 0) 'to re-check the calls below with a 2D-redimmed array
     
  Debug.Print "TypeName:", " "; TypeName(Arr)
  Debug.Print "ArrPtrSym:", ArrPtrSym(Arr)
  Debug.Print "ArrPtrSaf:", ArrPtrSaf(Arr)
  Debug.Print "ArrPtrDat:", ArrPtrDat(Arr)
  Debug.Print "ArrDimens:", ArrDimens(Arr)
  Debug.Print "ArrLBound:", ArrLBound(Arr)
  Debug.Print "ArrUBound:", ArrUBound(Arr)
  Debug.Print "ArrLength:", ArrLength(Arr) '<- this is the recommended call, when you check for the necessity of redimensioning
  Debug.Print "ArrElemSz:", ArrElemSz(Arr)
  Debug.Print "ArrMemory:", ArrMemory(Arr); ", ...and the Struct itself:"; ArrMemory(Arr, True) - ArrMemory(Arr)
End Sub

---

Ok, and here the Code for the Drop-In-Module

Code:

---

Option Explicit 'SafeArray-Helpers O. Schmidt

'UDT-Arrays have to use the following call for symbol-ptr retrieval
'(one should pass the return-value of this function, and not the UDT-array directly)
Public Declare Function ArrPtrUdt& Lib "msvbvm60" Alias "VarPtr" (Arr() As Any)

Private Declare Function ArrPtr& Lib "msvbvm60" Alias "__vbaRefVarAry" (Arr)
Private Declare Function DeRef& Lib "msvbvm60" Alias "GetMem4" (ByVal pSrc&, pRes&)
Private Declare Function SafeArrayGetDim% Lib "oleaut32" (ByVal pSA&)
Private Declare Function SafeArrayGetElemsize% Lib "oleaut32" (ByVal pSA&)
Private Declare Function SafeArrayGetLBound& Lib "oleaut32" (ByVal pSA&, ByVal nDim%, pRes&)
Private Declare Function SafeArrayGetUBound& Lib "oleaut32" (ByVal pSA&, ByVal nDim%, pRes&)
Private Declare Function SafeArrayAccessData& Lib "oleaut32" (ByVal pSA&, pData&)
Private Declare Function SafeArrayUnaccessData& Lib "oleaut32" (ByVal pSA&)

'All of the functions below will throw no Errors when used with normal-Arrays (which can be passed directly)
'The same routine-behaviour is ensured also with UDT-Arrays, but then with one caveat:
'You need one additional, indirect FuncCall (using the API-call which was defined Public above)
'Example: Dim Points() As PointAPI
'        If ArrLength(ArrPtrUdt(Points)) Then 'the UDT-Arr is already redimmed

Function ArrPtrSym(Arr) As Long 'returns the Symbol-Ptr of the Arr-Variable (0 when not initialized)
  If IsArray(Arr) Then ArrPtrSym = ArrPtr(Arr) Else ArrPtrSym = Arr
End Function

Function ArrPtrSaf(Arr) As Long 'returns a Ptr to the SafeArray-Struct (0 when not initialized)
  If IsArray(Arr) Then DeRef ArrPtrSym(Arr), ArrPtrSaf Else DeRef Arr, ArrPtrSaf
End Function

Function ArrPtrDat(Arr) As Long 'returns a Ptr to the begin of the underlying data (0 when not initialized)
  SafeArrayAccessData ArrPtrSaf(Arr), ArrPtrDat: SafeArrayUnaccessData ArrPtrSaf(Arr)
End Function

Function ArrDimens(Arr) As Long 'returns the Arr-Dimensions (0 when not initialized)
  ArrDimens = SafeArrayGetDim(ArrPtrSaf(Arr))
End Function

Function ArrElemSz(Arr) As Long 'returns the size of an Array-Element in Bytes (0 when not initialized)
  ArrElemSz = SafeArrayGetElemsize(ArrPtrSaf(Arr))
End Function

Function ArrLBound(Arr, Optional ByVal DimIdx As Long = 1) As Long
  SafeArrayGetLBound ArrPtrSaf(Arr), DimIdx, ArrLBound
End Function

Function ArrUBound(Arr, Optional ByVal DimIdx As Long = 1) As Long
  If ArrPtrSaf(Arr) Then SafeArrayGetUBound ArrPtrSaf(Arr), DimIdx, ArrUBound Else ArrUBound = -1
End Function

Function ArrLength(Arr, Optional ByVal DimIdx As Long = 1) As Long 'returns the amount of Array-Slots (for a given dimension)
  ArrLength = ArrUBound(Arr, DimIdx) - ArrLBound(Arr, DimIdx) + 1
End Function

'returns the memory-size in Bytes, the Data-Allocation of the array currently occupies
'(optionally adds the mem-size of the SafeArray-Struct itself)
Function ArrMemory(Arr, Optional ByVal IncludeStructSize As Boolean) As Long
  Dim i As Long
  For i = 1 To ArrDimens(Arr): ArrMemory = IIf(ArrMemory, ArrMemory, 1) * ArrLength(Arr, i): Next
  ArrMemory = ArrMemory * ArrElemSz(Arr)
  If IncludeStructSize Then If ArrPtrSaf(Arr) Then ArrMemory = ArrMemory + ArrDimens(Arr) * 8 + 16
End Function

---

Have fun with it (plus safer ArrayHandling) ;)

Olaf

---

Color Pickers six different styles

October 23, 2021, 6:08 am

≫ Next: Voronoi Draw

≪ Previous: VB6 modArrInfo (Array-introspection without Error-Handlers)

$

0

0

There are six small color programs here , all user controls, dealing with color selection. See if any are any help for you. The color names was written by Robert Rayment (one of my favorite programmers form PSC), I just made a control out of it.

Attached Images

 

Attached Files

• ColorPickers.zip (23.5 KB)

Voronoi Draw

October 23, 2021, 9:15 am

≫ Next: Is it possible to change the system date from an English date to an Arabic date ?

≪ Previous: Color Pickers six different styles

$

0

0

This is a fun app using flood fill . Original code is by David Rutten but I have highly modified it to create this drawing app . All it does is past time . Oh yes, pictures can be saved to use as background or whatever. Hope you like what I've done.

Attached Images

 

Attached Files

• Voronoi Draw.zip (37.4 KB)

Is it possible to change the system date from an English date to an Arabic date ?

October 25, 2021, 5:56 am

≫ Next: Draw on StdPicture objects

≪ Previous: Voronoi Draw

$

0

0

hi

Is it possible to change the system date from an English date to an Arabic date through a batch file code, and how is that?
:confused:

Draw on StdPicture objects

September 26, 2021, 1:54 am

≫ Next: SHA3_224 for vb6,Hash224 for vb6

≪ Previous: Is it possible to change the system date from an English date to an Arabic date ?

$

0

0

I'm not sure why you might need this, but this example shows how you can draw onto a StdPicture (type of bitmap only). Works whether currently assigned to a control or freestanding, such as loaded via LoadPicture().

The demo uses GDI calls by using the IPicture interface's SelectPicture() method to open/close the picture for drawing operations.

This demo doesn't show it, but it can also be used to draw to the persistent bitmap (Image property) of a Form, UserControl, or PictureBox while AutoRedraw = False. However it does show drawing to an Image control's Picture property.

Once again: these can't be icons or metafiles, only bitmaps.

Attached Files

• Draw on StdPicture.zip (4.3 KB)

SHA3_224 for vb6,Hash224 for vb6

October 27, 2021, 6:46 am

≫ Next: [VB6] Draw 2D shapes using Signed Distance Function

≪ Previous: Draw on StdPicture objects

$

0

0

Code:

---


Sub MAIN()
TestSHA3Functions
End Sub
Sub TestSHA3Functions()
 
 
' Create a new test
Dim SHATestTxt As String
 
SHATestTxt = "Cc123456"
MsgBox SHA3_224(SHATestTxt) & vbCrLf & "The correct value should be：" & vbCrLf & "4d9a9b213f1518cb46243b5676365b08312d57eeb124874b16767697"
'正确值应
End Sub

Function SHA3_224(msg As String, Optional opt As Dictionary) As String
'Hash224
'Generates 224-bit SHA-3 / Keccak hash of message.
'String msg - String to be hashed (Unicode-safe).
'Dictionary options - padding: sha-3 / keccak; msgFormat: string / hex; outFormat: hex / hex-b / hex-w.
SHA3_224 = Keccak1600(1152, 448, msg, opt)

End Function

Function Keccak1600(R As Integer, C As Integer, msg As String, Optional opt As Dictionary) As String
   
'Generates SHA-3 / Keccak hash of message M.
'Integer r - Bitrate 'r' (b-c)
'Integer c - Capacity 'c' (b-r), md length ?2
'String msg - Message
'Dictionary options - padding: sha-3 / keccak; msgFormat: string / hex; outFormat: hex / hex-b / hex-w.
'{string} Hash as hex-encoded string.
   
   
'const defaults = { padding: 'sha-3', msgFormat: 'string', outFormat: 'hex' };
Set OptDefaults = New Scripting.Dictionary
OptDefaults.Add "padding", "sha-3"
OptDefaults.Add "msgFormat", "string"
OptDefaults.Add "outFormat", "hex"
   
If opt Is Nothing Then Set opt = New Scripting.Dictionary
For Each k In OptDefaults.Keys
    If Not opt.Exists(k) Then
        opt.Add k, OptDefaults(k)
    End If
Next k
   
MsgLen = C / 2
' message digest output length in bits
   
'
If opt("msgFormat") = "hex-bytes" Then
    'NOT IMPLEMENTED YET, hexBytesToString(M)
    'msg = StrConv(msg, vbUnicode)
Else
    'utf8Encode(M)
    'msg = StrConv(msg, vbUnicode)
End If

'2d array
Dim state(0 To 4, 0 To 4, 0 To 1) As Currency
Dim squeezeState(0 To 4, 0 To 4) As String
' last dimension: 0 = lo, 1 = hi
' * Keccak state is a 5 ?5 x w array of bits (w=64 for keccak-f[1600] / SHA-3).
' * Here, it is implemented as a 5 ?5 array of Long. The first subscript (x) defines the
' * sheet, the second (y) defines the plane, together they define a lane. Slices, columns,
' * and individual bits are obtained by bit operations on the hi,lo components of the Long
' * representing the lane.

q = (R / 8) - Len(msg) Mod (R / 8)
If q = 1 Then
    If opt("padding") = "keccak" Then
        msg = msg & Chr$(129)
    Else
        msg = msg & Chr$(134)
    End If
Else
    If opt("padding") = "keccak" Then
        msg = msg & Chr$(1)
    Else
        msg = msg & Chr$(6)
    End If
    msg = msg & String(q - 2, Chr$(0))
    msg = msg & Chr$(128)
End If

'Debug.Print "q", q, Len(msg), msg,

w = 64  'for keccak-f[1600]
blocksize = R / w * 8

'Debug.Print w, blocksize

i = 0
Do While i < Len(msg)
    j = 0
    Do While j < R / w
        lo = LeftShift(CLng(Asc(Mid(msg, i + j * 8 + 0 + 1, 1))), 0, 32) + _
                LeftShift(CLng(Asc(Mid(msg, i + j * 8 + 1 + 1, 1))), 8, 32) + _
                LeftShift(CLng(Asc(Mid(msg, i + j * 8 + 2 + 1, 1))), 16, 32) + _
                LeftShift(CLng(Asc(Mid(msg, i + j * 8 + 3 + 1, 1))), 24, 32)
        hi = LeftShift(CLng(Asc(Mid(msg, i + j * 8 + 4 + 1, 1))), 0, 32) + _
                LeftShift(CLng(Asc(Mid(msg, i + j * 8 + 5 + 1, 1))), 8, 32) + _
                LeftShift(CLng(Asc(Mid(msg, i + j * 8 + 6 + 1, 1))), 16, 32) + _
                LeftShift(CLng(Asc(Mid(msg, i + j * 8 + 7 + 1, 1))), 24, 32)
        x = j Mod 5
        y = Int(j / 5)
       
        'Debug.Print "x,y lo,hi ", i & "," & j & "  " & lo & "," & hi
        state(x, y, 0) = state(x, y, 0) Xor lo
        state(x, y, 1) = state(x, y, 1) Xor hi
        j = j + 1
    Loop

    newstate = keccak_f_1600(state)
   
    i = i + blocksize
Loop

'Squeeze state
For i = 0 To 4
    For j = 0 To 4
        v1 = state(i, j, 0)
        v2 = state(i, j, 1)
        If v1 >= 2 ^ (32 - 1) Then v1 = v1 - 2 ^ (32)
        If v2 >= 2 ^ (32 - 1) Then v2 = v2 - 2 ^ (32)
        s1 = Hex(v1)
        s2 = Hex(v2)
        If Len(s1) < 8 Then s1 = String$(8 - Len(s1), "0") & s1
        If Len(s2) < 8 Then s2 = String$(8 - Len(s2), "0") & s2
       
        squeezeState(i, j) = LCase(s2 & s1)
        'Debug.Print i, j, squeezeState(i, j)
    Next j
Next i

ResStr = ""
For j = 0 To 4
    For i = 0 To 4
        For k = 8 To 1 Step -1
            ResStr = ResStr & Mid(squeezeState(i, j), 2 * k - 1, 2)
        Next k
        'Debug.Print ResStr
    Next i
Next j

Keccak1600 = Left(ResStr, MsgLen / 4)

'// if required, group message digest into bytes or words
'if (opt.outFormat == 'hex-b') md = md.match(/.{2}/g).join(' ');
'if (opt.outFormat == 'hex-w') md = md.match(/.{8,16}/g).join(' ');

'Debug.Print "END HERE!"
'550b320103b1f401"
'550b32013b1f401
'b87f88c72702fff1748e58b87e9141a42c0dbedc29a78cb0d4a5cd81a96abded
'b87f88c72702fff1748e58b87e9141a42c0dbedc29a78cb0d4a5cd81a96abded52f214ef4fb788ba

End Function


 
Function keccak_f_1600(StateIn)

nRounds = 24

'2d array
Dim RCs
RCs = Array("0000000000000001", "0000000000008082", "800000000000808a", "8000000080008000", "000000000000808b", "0000000080000001", _
            "8000000080008081", "8000000000008009", "000000000000008a", "0000000000000088", "0000000080008009", "000000008000000a", _
            "000000008000808b", "800000000000008b", "8000000000008089", "8000000000008003", "8000000000008002", "8000000000000080", _
            "000000000000800a", "800000008000000a", "8000000080008081", "8000000000008080", "0000000080000001", "8000000080008008")
Dim RC(0 To 23, 0 To 1) As Currency

For R = 0 To UBound(RCs)
    RC(R, 0) = HexToDec_C(Right(RCs(R), 8))
    RC(R, 1) = HexToDec_C(Left(RCs(R), 8))
    'Put data back into Long range, as shifts are binary
    If RC(R, 0) >= 2 ^ (32 - 1) Then RC(R, 0) = RC(R, 0) - 2 ^ (32)
    If RC(R, 1) >= 2 ^ (32 - 1) Then RC(R, 1) = RC(R, 1) - 2 ^ (32)
    'Debug.Print "hi " & RC(R, 1) & "  lo " & RC(R, 0)
Next R

'// Keccak-f permutations
For R = 0 To nRounds - 1
    'Debug.Print "r:" & R
    'Debug.Print "Keccak 2.3.2"
    'Debug.Print StateIn(0, 0, 0), StateIn(0, 0, 1)

    Dim C(0 To 4, 0 To 1) As Currency
    For x = 0 To 4
        C(x, 0) = StateIn(x, 0, 0)
        C(x, 1) = StateIn(x, 0, 1)
        For y = 1 To 4
            'Debug.Print "xy chi " & x & y & "  " & C(x, 1)
            'Debug.Print "xy clo " & x & y & "  " & C(x, 0)
            C(x, 1) = Xor_C(C(x, 1), StateIn(x, y, 1))
            C(x, 0) = Xor_C(C(x, 0), StateIn(x, y, 0))
        Next y
    Next x
   
    'Debug.Print "Keccak 2.3.2 bis"
    'Debug.Print StateIn(0, 0, 0), StateIn(0, 0, 1)
   
    For x = 0 To 4
        'Debug.Print "D hi- " & x & "  " & C((x + 4) Mod 5, 1)
        'Debug.Print "D lo- " & x & "  " & C((x + 4) Mod 5, 0)
        Dim Rt(0 To 1) As Currency
        Rt(0) = C((x + 1) Mod 5, 0)
        Rt(1) = C((x + 1) Mod 5, 1)
        Rr = rotl(Rt, 1)
        'Debug.Print "D rot hi- " & x & "  " & Rr(1)
        'Debug.Print "D rot lo- " & x & "  " & Rr(0)
       
        hi = Xor_C(C((x + 4) Mod 5, 1), Rr(1))
        lo = Xor_C(C((x + 4) Mod 5, 0), Rr(0))
        Dim D(0 To 4, 0 To 1) As Currency
        D(x, 1) = hi
        D(x, 0) = lo
        For y = 0 To 4
            StateIn(x, y, 1) = Xor_C(StateIn(x, y, 1), D(x, 1))
            StateIn(x, y, 0) = Xor_C(StateIn(x, y, 0), D(x, 0))
        Next y
    Next x
   
    'Debug.Print "Keccak 2.3.4"
    'Debug.Print StateIn(0, 0, 0), StateIn(0, 0, 1)
   
    xa = 1
    ya = 0
    Dim tmp(0 To 1) As Currency
    Dim cur(0 To 1) As Currency
    'ReDim Rt(0 To 1) As Long
    cur(0) = StateIn(xa, ya, 0)
    cur(1) = StateIn(xa, ya, 1)
    For t = 0 To 23
        xb = ya
        yb = (2 * xa + 3 * ya) Mod 5
        'Debug.Print t, xb, yb
        tmp(0) = StateIn(xb, yb, 0)
        tmp(1) = StateIn(xb, yb, 1)
       
        Rr = rotl(cur, ((t + 1) * (t + 2) / 2) Mod 64)
        StateIn(xb, yb, 0) = Rr(0)
        StateIn(xb, yb, 1) = Rr(1)
       
        cur(0) = tmp(0)
        cur(1) = tmp(1)
       
        xa = xb
        ya = yb
    Next t
   
   
    'Debug.Print "Keccak 2.3.1"
    'Debug.Print StateIn(0, 0, 0), StateIn(0, 0, 1)
   
    For y = 0 To 4
        Erase C
        For x = 0 To 4
            C(x, 0) = StateIn(x, y, 0)
            C(x, 1) = StateIn(x, y, 1)
        Next x
        For x = 0 To 4
            StateIn(x, y, 1) = RightShiftZF(Xor_C(C(x, 1), And_C(Not_C(C((x + 1) Mod 5, 1)), C((x + 2) Mod 5, 1))), 0)
            StateIn(x, y, 0) = RightShiftZF(Xor_C(C(x, 0), And_C(Not_C(C((x + 1) Mod 5, 0)), C((x + 2) Mod 5, 0))), 0)
            'StateIn(x, y, 1) = RightShiftZF(C(x, 1) Xor ((Not C((x + 1) Mod 5, 1) And C((x + 2) Mod 5, 1))), 0)
            'StateIn(x, y, 0) = RightShiftZF(C(x, 0) Xor ((Not C((x + 1) Mod 5, 0) And C((x + 2) Mod 5, 0))), 0)
        Next x
    Next y

    'Debug.Print "Keccak 2.3.5"
    'Debug.Print StateIn(0, 0, 0), StateIn(0, 0, 1)

    'Debug.Print "a00-lo1:", StateIn(0, 0, 0), DecToBin_C(StateIn(0, 0, 0), 32)
    'Debug.Print "RCr-lo1:", RC(R, 0), DecToBin_C(StateIn(0, 0, 0), 32)
   
    StateIn(0, 0, 1) = RightShiftZF(Xor_C(StateIn(0, 0, 1), RC(R, 1)), 0)
    StateIn(0, 0, 0) = RightShiftZF(Xor_C(StateIn(0, 0, 0), RC(R, 0)), 0)

    'Debug.Print "a00-lo2:", StateIn(0, 0, 0), DecToBin_C(StateIn(0, 0, 0), 32)
   
Next R

End Function


Function rotl(ObjIn() As Currency, n As Byte) As Currency()
   
    'Debug.Print "ROTL data: ", ObjIn(0), ObjIn(1), n
   
    Dim m As Byte
    'Rotate left
    Dim R(0 To 1) As Currency
    If n < 32 Then
        m = 32 - n
        lo_1 = LeftShift(ObjIn(0), n, 32)
        lo_2 = RightShiftZF(ObjIn(1), m, 32)
        hi_1 = LeftShift(ObjIn(1), n, 32)
        hi_2 = RightShiftZF(ObjIn(0), m, 32)
       
        lo = lo_1 Or lo_2
        hi = hi_1 Or hi_2
'      const lo = this.lo<<n | this.hi>>>m;
'      const hi = this.hi<<n | this.lo>>>m;
        R(0) = lo
        R(1) = hi
    ElseIf n = 32 Then
        R(0) = ObjIn(0)
        R(1) = ObjIn(1)
    ElseIf n > 32 Then
        n = n - 32
        m = 32 - n
        lo_1 = LeftShift(ObjIn(1), n, 32)
        lo_2 = RightShiftZF(ObjIn(0), m, 32)
        hi_1 = LeftShift(ObjIn(0), n, 32)
        hi_2 = RightShiftZF(ObjIn(1), m, 32)
        lo = lo_1 Or lo_2
        hi = hi_1 Or hi_2
'      const lo = this.hi<<n | this.lo>>>m;
'      const hi = this.lo<<n | this.hi>>>m;
        R(0) = lo
        R(1) = hi
    End If
    rotl = R()
   
End Function

---

Code:

---

'INSPRIRED BY:
'https://developer.mozilla.org/en-US/docs/Web/JavaScript/Reference/Operators/Bitwise_Operators
'https://www.mrexcel.com/forum/excel-questions/578667-use-dec2bin-function-vba-edit-macro.html
'https://vbaf1.com/variables/data-types/
 
Function DecToBin_C(DecimalIn As Variant, OutputLen As Byte, Optional IsSigned As Boolean = True) As String
'need_DecToBin_C
    If IsSigned Then
        'Signed value in, e.g. len = 16 -> -32,768 to 32,767
        MinDecVal = CDec(-2 ^ (OutputLen - 1))
        MaxDecVal = CDec(2 ^ (OutputLen - 1) - 1)
    Else
        'Unsigned value in, e.g. len = 16  -> 0 to 65535
        MinDecVal = CDec(0)
        MaxDecVal = CDec(2 ^ OutputLen - 1)
    End If
   
    DecToBin2 = ""
    DecCalc = CDec(DecimalIn)
    If DecCalc < MinDecVal Or DecCalc > MaxDecVal Then
        'Error (6) 'overflow -> error normally off, giving back an empty string, but can switch it on
        DecToBin_C = DecToBin2
        Exit Function
    End If
   
    Do While DecimalIn <> 0
        DecToBin2 = Trim$(Str$(DecCalc - 2 * Int(DecCalc / 2))) & DecToBin2
        DecCalc = Int(DecCalc / 2)
        'Escape for maximum length (negative numbers):
        If Len(DecToBin2) = OutputLen Then Exit Do
    Loop
    DecToBin_C = Right$(String$(OutputLen, "0") & DecToBin2, OutputLen)
   
End Function
Function BinToDec_C(StringIn As String, Optional IsSigned As Boolean = True) As Variant
    'need_BinToDec_C
    'Input assumed to be a Signed number, otherwise use IsSigned = False
    Dim StrLen As Byte
    StrLen = Len(StringIn)
    BinToDec_C = 0
    If Left(StringIn, 1) = "1" And IsSigned Then
        'negative number, signed
        For i = 1 To Len(StringIn)
            If Mid(StringIn, StrLen + 1 - i, 1) = "0" Then
                BinToDec_C = BinToDec_C + 2 ^ (i - 1)
            End If
        Next i
        BinToDec_C = -BinToDec_C - 1
    Else
        'positive number, can be signed or unsigned
        For i = 1 To Len(StringIn)
            If Mid(StringIn, StrLen + 1 - i, 1) = "1" Then
                BinToDec_C = BinToDec_C + 2 ^ (i - 1)
            End If
        Next i
    End If
   
End Function

Function LeftShift(ValIn As Variant, Shift As Byte, Optional DefaultLen As Byte = 1, Optional IsSigned As Boolean = True) As Variant
    'need LeftShift
    '<<  Zero fill left shift - Shifts left by pushing zeros in from the right and let the leftmost bits fall off
    If DefaultLen = 1 Then
        ' DefaultLen -> will get the most appropriate value of 8 (byte), 16 (integer), 32 (long), 64 (longlong)
        DefaultLen = GetDefaultLen(ValIn, IsSigned)
    End If
   
    Dim TempStr As String
    TempStr = DecToBin_C(ValIn, DefaultLen, IsSigned)
    TempStr = Right$(TempStr & String$(Shift, "0"), DefaultLen)
    LeftShift = BinToDec_C(TempStr, IsSigned)
   
End Function


Function RightShiftZF(ValIn As Variant, Shift As Byte, Optional DefaultLen As Byte = 1, Optional IsSigned As Boolean = True) As Variant
    'need_RightShiftZF
    '>>> Zero fill right shift  Shifts right by pushing zeros in from the left, and let the rightmost bits fall off
    'Also called: Unsigned Right Shift [>>>]
    If DefaultLen = 1 Then
        ' DefaultLen -> will get the most appropriate value of 8 (byte), 16 (integer), 32 (long), 64 (longlong)
        DefaultLen = GetDefaultLen(ValIn, IsSigned)
    End If
   
    Dim TempStr As String
    TempStr = DecToBin_C(ValIn, DefaultLen, IsSigned)
    TempStr = Left$(String$(Shift, "0") & TempStr, DefaultLen)
    RightShiftZF = BinToDec_C(TempStr, IsSigned)
End Function

Function HexToDec_C(hexString As String) As Variant
'need_HexToDec_C
    'https://stackoverflow.com/questions/40213758/convert-hex-string-to-unsigned-int-vba#40217566
    'cut off "&h" if present
    If Left(hexString, 2) = "&h" Or Left(hexString, 2) = "&H" Then hexString = Mid(hexString, 3)

    'cut off leading zeros
    While Left(hexString, 1) = "0"
        hexString = Mid(hexString, 2)
    Wend
   
    If hexString = "" Then hexString = "0"
    HexToDec_C = CDec("&h" & hexString)
    'correct value for 8 digits onle
    'Debug.Print hexString, HexToDec_C
    If HexToDec_C < 0 And Len(hexString) = 8 Then
        HexToDec_C = CDec("&h1" & hexString) - 4294967296#
    'cause overflow for 16 digits
    ElseIf HexToDec_C < 0 Then
        Error (6) 'overflow
    End If

End Function
Function GetDefaultLen(ValIn As Variant, IsSigned As Boolean) As Byte
'need_GetDefaultLen
If IsSigned Then
    'Signed value in, e.g. len = 16 -> -32,768 to 32,767
    If CDec(ValIn) >= -2 ^ (8 - 1) And CDec(ValIn) <= 2 ^ (8 - 1) - 1 Then
        GetDefaultLen = 8 '8 (byte)
    ElseIf CDec(ValIn) >= -2 ^ (16 - 1) And CDec(ValIn) <= 2 ^ (16 - 1) - 1 Then
        GetDefaultLen = 16 '16 (integer)
    ElseIf CDec(ValIn) >= -2 ^ (32 - 1) And CDec(ValIn) <= 2 ^ (32 - 1) - 1 Then
        GetDefaultLen = 32 '32 (long)
    ElseIf CDec(ValIn) >= -2 ^ (64 - 1) And CDec(ValIn) <= 2 ^ (64 - 1) - 1 Then
        GetDefaultLen = 64 '64 (longlong)
    Else
        'Number too big for function, return max value that Currency can represent
        GetDefaultLen = 96
    End If
Else
    'Unsigned value in, e.g. len = 8  -> 0 to 255
    If CDec(ValIn) <= 2 ^ 8 - 1 And CDec(ValIn) >= 0 Then
        GetDefaultLen = 8 '8 (byte)
    ElseIf CDec(ValIn) <= 2 ^ 16 - 1 And CDec(ValIn) >= 0 Then
        GetDefaultLen = 16 '16 (integer)
    ElseIf CDec(ValIn) <= 2 ^ 32 - 1 And CDec(ValIn) >= 0 Then
        GetDefaultLen = 32 '32 (long)
    ElseIf CDec(ValIn) <= 2 ^ 64 - 1 And CDec(ValIn) >= 0 Then
        GetDefaultLen = 64 '64 (longlong)
    Else
        'Number too big for function, return max value that Currency can represent
        GetDefaultLen = 96
    End If
End If

End Function

Function Not_C(ValIn1 As Variant, Optional IsSigned As Boolean = True) As Variant
    'need_Not_C
    Dim s3 As String
    Dim s1len As Byte
    d1 = CDec(ValIn1)
   
    UseDefault = True
    If IsSigned = True Then
        If d1 < -2 ^ (32 - 1) Or d1 > 2 ^ (32 - 1) - 1 Then UseDefault = False
    Else
        UseDefault = False
    End If
   
    If UseDefault Then
        Not_C = Not ValIn1
    Else
        'Check size and sign
        s1len = GetDefaultLen(d1, IsSigned)
        s1 = DecToBin_C(d1, s1len, IsSigned)
        s3 = ""
        For C = 1 To s1len
            If Mid(s1, C, 1) = "1" Then
                s3 = s3 & "0"
            Else
                s3 = s3 & "1"
            End If
        Next C
        Not_C = BinToDec_C(s3, IsSigned)
    End If
   
End Function
Function And_C(ValIn1 As Variant, ValIn2 As Variant, Optional IsSigned As Boolean = True) As Variant
'need_And_C
    And_C = OrAndXor_C("AND", ValIn1, ValIn2, IsSigned)
End Function

Function Xor_C(ValIn1 As Variant, ValIn2 As Variant, Optional IsSigned As Boolean = True) As Variant
'need_Xor_C
    Xor_C = OrAndXor_C("XOR", ValIn1, ValIn2, IsSigned)
End Function
Function OrAndXor_C(Func As String, ValIn1 As Variant, ValIn2 As Variant, Optional IsSigned As Boolean = True) As Variant
'need_OrAndXor_C
    Dim s3 As String
    Dim maxlen As Byte
    d1 = CDec(ValIn1)
    d2 = CDec(ValIn2)
    Func = LCase(Func)
   
    UseDefault = True
    If IsSigned = True Then
        If d1 < -2 ^ (32 - 1) Or d1 > 2 ^ (32 - 1) - 1 Then UseDefault = False
        If d2 < -2 ^ (32 - 1) Or d2 > 2 ^ (32 - 1) - 1 Then UseDefault = False
    Else
        UseDefault = False
    End If
   
    If UseDefault Then
        If Func = "xor" Then
            OrAndXor_C = d1 Xor d2
        ElseIf Func = "or" Then
            OrAndXor_C = d1 Or d2
        ElseIf Func = "and" Then
            OrAndXor_C = d1 And d2
        Else
            OrAndXor_C = False
        End If
    Else
        If IsSigned Then
            'Too big for a 32 bit long, go for 64 bit
            s1 = DecToBin_C(d1, 64)
            s2 = DecToBin_C(d2, 64)
            s3 = ""
            For C = 1 To 64
                If Func = "xor" Then
                    If Mid(s1, C, 1) = Mid(s2, C, 1) Then
                        s3 = s3 & "0"
                    Else
                        s3 = s3 & "1"
                    End If
                ElseIf Func = "or" Then
                    If Mid(s1, C, 1) = 1 Or Mid(s2, C, 1) = 1 Then
                        s3 = s3 & "1"
                    Else
                        s3 = s3 & "0"
                    End If
                ElseIf Func = "and" Then
                    If Mid(s1, C, 1) = 1 And Mid(s2, C, 1) = 1 Then
                        s3 = s3 & "1"
                    Else
                        s3 = s3 & "0"
                    End If
                End If
            Next C
            OrAndXor_C = BinToDec_C(s3)
        Else
            'Treat as unsigned
            s1len = GetDefaultLen(d1, False)
            s2len = GetDefaultLen(d2, False)
           
            If s1len > s2len Then maxlen = s1len Else maxlen = s2len
           
            s1 = DecToBin_C(d1, maxlen, False)
            s2 = DecToBin_C(d2, maxlen, False)
            s3 = ""
           
            For C = 1 To maxlen
                If Func = "xor" Then
                    If Mid(s1, C, 1) = Mid(s2, C, 1) Then
                        s3 = s3 & "0"
                    Else
                        s3 = s3 & "1"
                    End If
                ElseIf Func = "or" Then
                    If Mid(s1, C, 1) = 1 Or Mid(s2, C, 1) = 1 Then
                        s3 = s3 & "1"
                    Else
                        s3 = s3 & "0"
                    End If
                ElseIf Func = "and" Then
                    If Mid(s1, C, 1) = 1 And Mid(s2, C, 1) = 1 Then
                        s3 = s3 & "1"
                    Else
                        s3 = s3 & "0"
                    End If
                End If
            Next C
            OrAndXor_C = BinToDec_C(s3, False)
       
        End If
    End If

End Function
 
Function Or_C(ValIn1 As Variant, ValIn2 As Variant, Optional IsSigned As Boolean = True) As Variant
    '不需要
    Or_C = OrAndXor_C("OR", ValIn1, ValIn2, IsSigned)
End Function
Function RightShift(ValIn As Variant, Shift As Byte, Optional DefaultLen As Byte = 1, Optional IsSigned As Boolean = True) As Variant
    '不需要
    '>>  Signed right shift  Shifts right by pushing copies of the leftmost bit in from the left, and let the rightmost bits fall off
    'Also called: Signed Right Shift [>>]
    If DefaultLen = 1 Then
        ' DefaultLen -> will get the most appropriate value of 8 (byte), 16 (integer), 32 (long), 64 (longlong)
        DefaultLen = GetDefaultLen(ValIn, IsSigned)
    End If
   
    Dim TempStr As String
    Dim FillStr As String
    TempStr = DecToBin_C(ValIn, DefaultLen, IsSigned)
    FillStr = Left(TempStr, 1)
    TempStr = Left$(String$(Shift, FillStr) & TempStr, DefaultLen)
    RightShift = BinToDec_C(TempStr, IsSigned)
   
End Function

---

[VB6] Draw 2D shapes using Signed Distance Function

October 28, 2021, 11:26 am

≫ Next: VB6 Web Site/App Server

≪ Previous: SHA3_224 for vb6,Hash224 for vb6

$

0

0

Draw 2D shapes using 2D Signed distance Function.

Calculate distance from each pixel to each shape and compute its RGB value.

Do not use (DX) GPU HLSL, with which it would be very much faster.

2D SDF functions taken and customized from here:
https://iquilezles.org/www/articles/...unctions2d.htm

__Requires__:
RC6 (for RC6 Render mode) http://vbrichclient.com/#/en/About/

DOWNLOAD:
https://github.com/miorsoft/VB6-2D-SDF



INTERESTING:
Deriving the SDF of a Line Segment
https://www.youtube.com/watch?v=PMltMdi1Wzg
Rounding Corners in SDF
https://www.youtube.com/watch?v=s5NGeUV2EyU

VB6 Web Site/App Server

October 29, 2021, 3:15 pm

≫ Next: Inter Process Communication between Outlook VSTO addin (in VB.NET) and VB6 App

≪ Previous: [VB6] Draw 2D shapes using Signed Distance Function

$

0

0

This project helps you serve web sites/apps with VB6. It is a work in progress. It will eventually become a DLL, but for now it is an EXE project while under development.

It includes a number of nice features to make it easier to deliver websites such as:

• Auto-serves static files (this can be disabled if you want to perform your own file serving).
• Automatically handle If-None-Match headers to return 304 Not Modified when appropriate to save bandwidth.
• Easily handle cookies with the CHttpCookies class.
• Easily handle requests via the CHttpRequest class.
• Easily respond to requests using the CHttpResponse class.
• Include "helper" classes for things like handling dates, encoding HTML entities, "Safe" DB creation, regular expressions, and HTML templates (I call these VBML files, and they have a ".vbml" extension.
• MIME type detection (file extension based).

VBML files are just HTML files with special comments. The app server will detect the comments and raise an event to your app, which can then respond with HTML that will replace the VBML comment. VBML comments are formatted like this:

Code:

---

<!-- vbml: my_vbml_command -->

---

Your app will receive "my_vbml_command" in the ConvertVbmlToHtml event, where it can set the p_Html property to whatever you'd like to replace the comment with. VBML commands can also include parameters:

Code:

---

<!-- vbml: my_vbmlcommand(2, "Param") -->

---

The parameters will be passed in the po_VbmlParameters arraylist in the ConvertVbmlToHtml event, and you can use them however you like. Take a look at the Web/index.vbml file for examples of some VBML comments/commands, then look at the CApp class' mo_VbmlHelper_ConvertVbmlToHtml event sub to see how the VBML commands are processed.


To try it out yourself:

1. Make sure that all the RC6 DLLs are installed on your computer.
   
2. Open VBWebAppServer.vbp and run it.
   
3. In your browser, visit http://127.0.0.1:8080

You should see the following page:



Note that when running in the IDE, the server will be running as a single thread so performance won't be spectacular as each request will have to wait for the previous request to complete. You can however compile the EXE and use the /spawn switch to spawn as many app server listeners as you like. You can then put Nginx in front of the app server and configure it to be a reverse proxy to all your app server listeners.

Here's the code that produces the dynamic portions of the demo page:

Code:

---

Option Explicit

Private WithEvents mo_VbmlHelper As CAppHelperVbml

Public Sub RespondToRequest(po_Req As CHttpRequest, po_Response As CHttpResponse, po_Helpers As CAppHelpers)
  Dim l_VisitCount As Long
 
  With po_Req.Cookies
      l_VisitCount = .CookieValueByKeyOrDefaultValue("visitcount", 0)
      l_VisitCount = l_VisitCount + 1
      .AddOrReplaceCookie "visitcount", l_VisitCount, , , Now + 10000
  End With
 
  With po_Response
      If po_Helpers.Regex.Test(po_Req.Url(urlsection_Path), "^showcase/[0-9]+$", False) Then
        ' Get requested showcase image from database by numeric id
        With New_C.Connection(pathApp & "web.sqlite", DBOpenFromFile)
       
            With .CreateSelectCommand("SELECT image, etag, extension FROM showcase WHERE id=?")
              .SetInt32 1, Split(po_Req.Url(urlsection_Path), "/")(1)  ' Get image ID from request and use it for SELECT query
             
              With .Execute(True)
                  If .RecordCount = 0 Then
                    ' No image found!
                    po_Response.Send404NotFound
                   
                  Else
                    ' Found an image. Check to see if requester has a cached copy
                    If po_Req.Headers.HeaderValue("If-None-Match") = .Fields("etag").Value Then
                        ' Requester has a cached copy, send 304 Not Modified to save bandwidth
                       
                        po_Response.Send304NotModified
                       
                    Else
                        ' Requester does not have a cached copy of the image, so send it (along with the ETag so future cache hits can be tested).
                 
                        po_Response.AddHttpHeader "ETag", .Fields("etag").Value
                        po_Response.SendSimpleByteArrayResponse .Fields("image").Value, , , mimeTypeFromFilePath(.Fields("extension").Value)
                    End If
                  End If
              End With
            End With
        End With
       
      Else
        If Not New_C.FSO.FileExists(po_Req.LocalPath) Then
            ' File Not found!
            .Send404NotFound
       
        Else
            If LCase$(Right$(po_Req.Url(urlsection_Path), 5)) = ".vbml" Then
              ' Request for a dynamic .vbml page
              Set mo_VbmlHelper = po_Helpers.Vbml ' Pass VBML helper to module level variable to receive events.
             
              .SendSimpleHtmlResponse mo_VbmlHelper.ParseVbmlString(New_C.FSO.ReadTextContent(po_Req.LocalPath)), po_Req.Cookies
             
            Else
              ' Since we have auto serve enabled, we should never get here
              ' as the auto-serve feature should have found and served the requested file.
              Debug.Assert False
             
              .Send400BadRequest
            End If
        End If
      End If
  End With
End Sub

Private Sub mo_VbmlHelper_ConvertVbmlToHtml(ByVal p_VbmlCommand As String, ByVal po_VbmlParameters As RC6.cArrayList, p_Html As String, p_ShouldEscapeHtml As e_HtmlEscapeType)
  Dim l_Date As Date
  Dim l_ShowcaseCount As Long
 
  Select Case p_VbmlCommand
  Case "get_rc6_version"
      ' Get the file version of RC6.dll for reporting the most recent version
     
      p_Html = New_C.Version
 
  Case "get_rc6_date"
      ' Get the file creation date of RC6 DLL for reporting the most date of the most recent release
     
      New_C.FSO.GetFileAttributesEx pathSystem & "RC6.dll", , , , l_Date
     
      p_Html = Format$(l_Date, "YYYY-MM-DD")
 
  Case "get_copyright"
      ' Get the copyright text for the page
     
      p_Html = "Copyright " & Year(Now) & " — Olaf Schmidt."
      p_ShouldEscapeHtml = htmlescape_No
     
  Case "get_random_showcase_items"
      ' Get random RC6 showcase items and build the product showcase card.
      ' You can pass a count parameter with this command to determine the number of random showcase items to retrieve
     
      l_ShowcaseCount = 2  ' Default to 2 showcase items
      If po_VbmlParameters.Count > 0 Then l_ShowcaseCount = po_VbmlParameters.Item(0)  ' Get the desired # of showcase items if defined.
     
      With New_C.Connection(pathApp & "web.sqlite", DBOpenFromFile)
        With .OpenRecordset("SELECT rowid, product_name, developer, description_html, website FROM showcase ORDER BY random() LIMIT " & l_ShowcaseCount)
            Do Until .EOF
              p_Html = p_Html & "<div class='card p-4'>" & _
                                "<h2 class='text-center'>" & htmlEscape(.Fields("product_name")) & "<br>by " & htmlEscape(.Fields("developer")) & "</h2>" & _
                                "<img alt='" & htmlEscape(.Fields("product_name")) & " Screenshot' style='max-height: 150px;' class='img-fluid mt-4 mb-4 mx-auto' src='showcase/" & htmlEscape(.Fields("id")) & "' />" & _
                                .Fields("description_html") & _
                                "<p><a href='" & htmlEscape(.Fields("website")) & "'>Learn more about " & htmlEscape(.Fields("product_name")) & "...</a></p>" & _
                                "</div>"
           
              .MoveNext
            Loop
        End With
      End With
     
      p_ShouldEscapeHtml = htmlescape_No
     
  Case Else
      p_Html = "Unhandled VBML Command: " & p_VbmlCommand
      Debug.Print p_Html
      'Debug.Assert False
 
  End Select
End Sub

---

You can see it's pretty standard VB6 code, reasonably readable/understandable and concise (62 lines not including comments).

Command Line Parameters

If you compile the EXE you'll have access to some command line parameters:

/spawn <number>
Start the app server in "spawner" mode which will cause it to launch <number> processes in "listener" mode.

/stop
Stop all listener and spawner processes.

/ip <IPv4 address>
Tells the app server what IP to listen on

/port <Port>
Tells the app server what Port to listen on. When used with /spawn, this will be the first port of the first spawned listener. Additonally spawned listeners will listen on <port+spawncount>. For example, spawning 3 listeners at base port 8080 will result in listeners on ports 8080, 8081, and 8082.

/rootpath <folder path>
Tells the server where the web root folder is (for serving files). This defaults to the "application folder\web" folder. All of your static files should be placed in this folder (or subfolders thereof).

It's recommended to start in spawner mode like this:

Code:

---

VbWebApp.exe /spawn 10 /ip 127.0.0.1 /port 8080

---

The above command would spawn 10 app listeners using ports 8080-8089.

Note that the compiled EXE expects the RC6 DLLs to be in the App.Path & "\System" folder for reg-free use.

Anyway, I hope some of you find this useful, and I'll be happy to answer any questions you might have.

SOURCE CODE HERE: VBWebAppServer.zip

Attached Images

 

Attached Files

• VBWebAppServer.zip (672.3 KB)

---

Inter Process Communication between Outlook VSTO addin (in VB.NET) and VB6 App

November 1, 2021, 4:22 am

≫ Next: Setup at runtime a form as a MDI child, export the MDI form as a normal form

≪ Previous: VB6 Web Site/App Server

$

0

0

I wrote applications in VB6, and an Outlook VSTO addin (in VB.NET) that communicate directly with the VB6 App.
Based on email in Outlook, I wanted to send information to be shown in the VB6 app.
2 ways to do it

1) communication with files (and the VB6 pool for the files), but it is not the best way to do it.

2) Using IPC (Inter Process Communication) where the VSTO send a message to the VB6 App.

So here is the code of the VSTO addin that send a message to the VB6 App

Code:

---

Imports System.Runtime.InteropServices

Friend Module Module_Communication

    Private Const WM_COPYDATA As Integer = &H4A

    <StructLayout(LayoutKind.Sequential)>
    Private Structure COPYDATASTRUCT
        Public dwData As IntPtr
        Public cbData As Integer
        Public lpData As String
    End Structure

    <DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Unicode)>
    Private Function FindWindow(
        ByVal lpClassName As String,
        ByVal lpWindowName As String) As IntPtr
    End Function

    <DllImport("user32.dll", SetLastError:=True, CharSet:=CharSet.Auto)>
    Private Function SendMessage(
        ByVal hWnd As HandleRef,
        ByVal Msg As UInteger,
        ByVal wParam As IntPtr,
        ByRef lParam As COPYDATASTRUCT) As IntPtr
    End Function

    Public Function IPC_MyApp_SendText(sData As String) As Long

        Dim cds As COPYDATASTRUCT
        Dim wParam As IntPtr = frmProgress.Handle

        ' *** Find App Window we want to send text to...
        Dim Rx_Window As IntPtr

        Rx_Window = FindWindow(vbNullString, "MyApp")

        If Rx_Window <> IntPtr.Zero Then ' make sure window was found
            Dim href As New HandleRef(frmProgress, Rx_Window)
            cds.dwData = CType(3, IntPtr) ' NOTE: Using an indentifier of 3 for our MyApp Communication
            cds.lpData = sData
            cds.cbData = cds.lpData.Length + 1
            Call SendMessage(href, WM_COPYDATA, wParam, cds)
            GC.KeepAlive(frmProgress)

            Return 1
        Else
            Return 0
        End If

    End Function

End Module

---

And here is the code in VB6 App that manage the reception of the message
For that, I use Subclassing.
NB : It is not working in IDE, only in compiled app

Add a module for Subclassing and paste the code (coming from wqweto)

Code:

---

'=========================================================================
'
' MST Project (c) 2019 by wqweto@gmail.com
'
' The Modern Subclassing Thunk (MST) for VB6
'
' This project is licensed under the terms of the MIT license
' See the LICENSE file in the project root for more information
'
'=========================================================================
Option Explicit
DefObj A-Z
'Private Const MODULE_NAME As String = "mdModernSubclassing"

#Const ImplNoIdeProtection = (MST_NO_IDE_PROTECTION <> 0)
#Const ImplSelfContained = True

'=========================================================================
' API
'=========================================================================

Private Const SIGN_BIT  As Long = &H80000000
Private Const PTR_SIZE  As Long = 4
'--- for thunks
Private Const MEM_COMMIT As Long = &H1000
Private Const PAGE_EXECUTE_READWRITE As Long = &H40
Private Const CRYPT_STRING_BASE64 As Long = 1

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function VirtualAlloc Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flAllocationType As Long, ByVal flProtect As Long) As Long
Private Declare Function CryptStringToBinary Lib "crypt32" Alias "CryptStringToBinaryA" (ByVal pszString As String, ByVal cchString As Long, ByVal dwFlags As Long, ByVal pbBinary As Long, pcbBinary As Long, Optional ByVal pdwSkip As Long, Optional ByVal pdwFlags As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function GetProcByOrdinal Lib "kernel32" Alias "GetProcAddress" (ByVal hModule As Long, ByVal lpProcOrdinal As Long) As Long
Private Declare Function DefSubclassProc Lib "comctl32" Alias "#413" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
#If Not ImplNoIdeProtection Then
  Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent As Long, ByVal hWndChildAfter As Long, ByVal lpszClass As String, ByVal lpszWindow As String) As Long
  Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
  Public Declare Function GetCurrentProcessId Lib "kernel32" () As Long
#End If
#If ImplSelfContained Then
  Private Declare Function GetEnvironmentVariable Lib "kernel32" Alias "GetEnvironmentVariableA" (ByVal lpName As String, ByVal lpBuffer As String, ByVal nSize As Long) As Long
  Private Declare Function SetEnvironmentVariable Lib "kernel32" Alias "SetEnvironmentVariableA" (ByVal lpName As String, ByVal lpValue As String) As Long
#End If

'=========================================================================
' Functions
'=========================================================================

Public Function InitAddressOfMethod(pObj As Object, ByVal MethodParamCount As Long) As frmMain
  Const STR_THUNK    As String = "6AAAAABag+oFV4v6ge9QEMEAgcekEcEAuP9EJAS5+QcAAPOri8LB4AgFuQAAAKuLwsHoGAUAjYEAq7gIAAArq7hEJASLq7hJCIsEq7iBi1Qkq4tEJAzB4AIFCIkCM6uLRCQMweASBcDCCACriTrHQgQBAAAAi0QkCIsAiUIIi0QkEIlCDIHqUBDBAIvCBTwRwQCri8IFUBHBAKuLwgVgEcEAq4vCBYQRwQCri8IFjBHBAKuLwgWUEcEAq4vCBZwRwQCri8IFpBHBALn5BwAAq4PABOL6i8dfgcJQEMEAi0wkEIkRK8LCEAAPHwCLVCQE/0IEi0QkDIkQM8DCDABmkItUJAT/QgSLQgTCBAAPHwCLVCQE/0oEi0IEg/gAfgPCBABZWotCDGgAgAAAagBSUf/gZpC4AUAAgMIIALgBQACAwhAAuAFAAIDCGAC4AUAAgMIkAA==" ' 25.3.2019 14:01:08
  Const THUNK_SIZE    As Long = 16728
  Dim hThunk          As Long
  Dim lSize            As Long

  hThunk = VirtualAlloc(0, THUNK_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
  If hThunk = 0 Then
      Exit Function
  End If
  Call CryptStringToBinary(STR_THUNK, Len(STR_THUNK), CRYPT_STRING_BASE64, hThunk, THUNK_SIZE)
  lSize = CallWindowProc(hThunk, ObjPtr(pObj), MethodParamCount, GetProcAddress(GetModuleHandle("kernel32"), "VirtualFree"), VarPtr(InitAddressOfMethod))
  Debug.Assert lSize = THUNK_SIZE
End Function

Public Function InitSubclassingThunk(ByVal hWnd As Long, pObj As Object, ByVal pfnCallback As Long) As IUnknown
  Const STR_THUNK    As String = "6AAAAABag+oFgepwEB4BV1aLdCQUg8YIgz4AdC+L+oHHABIeAYvCBQgRHgGri8IFRBEeAauLwgVUER4Bq4vCBXwRHgGruQkAAADzpYHCABIeAVJqGP9SEFqL+IvCq7gBAAAAqzPAq4tEJAyri3QkFKWlg+8YagBX/3IM/3cM/1IYi0QkGIk4Xl+4NBIeAS1wEB4BwhAAZpCLRCQIgzgAdSqDeAQAdSSBeAjAAAAAdRuBeAwAAABGdRKLVCQE/0IEi0QkDIkQM8DCDAC4AkAAgMIMAJCLVCQE/0IEi0IEwgQADx8Ai1QkBP9KBItCBHUYiwpS/3EM/3IM/1Eci1QkBIsKUv9RFDPAwgQAkFWL7ItVGIsKi0EshcB0OFL/0FqJQgiD+AF3VIP4AHUJgX0MAwIAAHRGiwpS/1EwWoXAdTuLClJq8P9xJP9RKFqpAAAACHUoUjPAUFCNRCQEUI1EJARQ/3UU/3UQ/3UM/3UI/3IQ/1IUWVhahcl1EYsK/3UU/3UQ/3UM/3UI/1EgXcIYAA==" ' 1.4.2019 11:41:46
  Const THUNK_SIZE    As Long = 452
  Static hThunk      As Long
  Dim aParams(0 To 10) As Long
  Dim lSize            As Long

  aParams(0) = ObjPtr(pObj)
  aParams(1) = pfnCallback
  #If ImplSelfContained Then
      If hThunk = 0 Then
        hThunk = pvThunkGlobalData("InitSubclassingThunk")
      End If
  #End If
  If hThunk = 0 Then
      hThunk = VirtualAlloc(0, THUNK_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
      If hThunk = 0 Then
        Exit Function
      End If
      Call CryptStringToBinary(STR_THUNK, Len(STR_THUNK), CRYPT_STRING_BASE64, hThunk, THUNK_SIZE)
      aParams(2) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemAlloc")
      aParams(3) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemFree")
      Call DefSubclassProc(0, 0, 0, 0)                                            '--- load comctl32
      aParams(4) = GetProcByOrdinal(GetModuleHandle("comctl32"), 410)            '--- 410 = SetWindowSubclass ordinal
      aParams(5) = GetProcByOrdinal(GetModuleHandle("comctl32"), 412)            '--- 412 = RemoveWindowSubclass ordinal
      aParams(6) = GetProcByOrdinal(GetModuleHandle("comctl32"), 413)            '--- 413 = DefSubclassProc ordinal
      '--- for IDE protection
      Debug.Assert pvGetIdeOwner(aParams(7))
      If aParams(7) <> 0 Then
        aParams(8) = GetProcAddress(GetModuleHandle("user32"), "GetWindowLongA")
        aParams(9) = GetProcAddress(GetModuleHandle("vba6"), "EbMode")
        aParams(10) = GetProcAddress(GetModuleHandle("vba6"), "EbIsResetting")
      End If
      #If ImplSelfContained Then
        pvThunkGlobalData("InitSubclassingThunk") = hThunk
      #End If
  End If
  lSize = CallWindowProc(hThunk, hWnd, 0, VarPtr(aParams(0)), VarPtr(InitSubclassingThunk))
  Debug.Assert lSize = THUNK_SIZE
End Function

Public Function CallNextSubclassProc(pSubclass As IUnknown, ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  #If pSubclass Then '--- touch args
  #End If
  CallNextSubclassProc = DefSubclassProc(hWnd, wMsg, wParam, lParam)
End Function

Public Function InitHookingThunk(ByVal idHook As Long, pObj As Object, ByVal pfnCallback As Long) As IUnknown
  Const STR_THUNK    As String = "6AAAAABag+oFgepwECQAV1aLdCQUg8YIgz4AdCqL+oHHOBIkAIvCBVQRJACri8IFkBEkAKuLwgWgESQAqzPAq7kJAAAA86WBwjgSJABSahj/UhBai/iLwqu4AQAAAKszwKuri3QkFKWlg+8Yi0oM/0IMgWIM/wAAAI0Eyo0EyI1MiDTHAf80JLiJeQTHQQiJRCQEi8ItOBIkAAXEESQAUMHgCAW4AAAAiUEMWMHoGAUA/+CQiUEQ/3QkEGoAUf90JBiLD/9RGIlHDItEJBiJOF5fuGwSJAAtcBAkAAUAFAAAwhAAi0QkCIM4AHUqg3gEAHUkgXgIwAAAAHUbgXgMAAAARnUSi1QkBP9CBItEJAyJEDPAwgwAuAJAAIDCDACQi1QkBP9CBItCBMIEAA8fAItUJAT/SgSLQgR1FIsK/3IM/1Eci1QkBIsKUv9RFDPAwgQAkFWL7ItVCIsKi0EshcB0KlL/0FqJQgiD+AF3Q4sKUv9RMFqFwHU4iwpSavD/cST/UShaqQAAAAh1JVIzwFBQjUQkBFCNRCQEUP91FP91EP91DP9yEP9SFFlYWoXJdRGLCv91FP91EP91DP9yDP9RIF3CEACQ" ' 1.4.2019 11:43:54
  Const THUNK_SIZE    As Long = 5628
  Static hThunk      As Long
  Dim aParams(0 To 10) As Long
  Dim lSize            As Long

  aParams(0) = ObjPtr(pObj)
  aParams(1) = pfnCallback
  #If ImplSelfContained Then
      If hThunk = 0 Then
        hThunk = pvThunkGlobalData("InitHookingThunk")
      End If
  #End If
  If hThunk = 0 Then
      hThunk = VirtualAlloc(0, THUNK_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
      If hThunk = 0 Then
        Exit Function
      End If
      Call CryptStringToBinary(STR_THUNK, Len(STR_THUNK), CRYPT_STRING_BASE64, hThunk, THUNK_SIZE)
      aParams(2) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemAlloc")
      aParams(3) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemFree")
      aParams(4) = GetProcAddress(GetModuleHandle("user32"), "SetWindowsHookExA")
      aParams(5) = GetProcAddress(GetModuleHandle("user32"), "UnhookWindowsHookEx")
      aParams(6) = GetProcAddress(GetModuleHandle("user32"), "CallNextHookEx")
      '--- for IDE protection
      Debug.Assert pvGetIdeOwner(aParams(7))
      If aParams(7) <> 0 Then
        aParams(8) = GetProcAddress(GetModuleHandle("user32"), "GetWindowLongA")
        aParams(9) = GetProcAddress(GetModuleHandle("vba6"), "EbMode")
        aParams(10) = GetProcAddress(GetModuleHandle("vba6"), "EbIsResetting")
      End If
      #If ImplSelfContained Then
        pvThunkGlobalData("InitHookingThunk") = hThunk
      #End If
  End If
  lSize = CallWindowProc(hThunk, idHook, App.ThreadID, VarPtr(aParams(0)), VarPtr(InitHookingThunk))
  Debug.Assert lSize = THUNK_SIZE
End Function

Public Function CallNextHookProc(pHook As IUnknown, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Dim lPtr            As Long

  lPtr = ObjPtr(pHook)
  If lPtr <> 0 Then
      Call CopyMemory(lPtr, ByVal (lPtr Xor SIGN_BIT) + 12 Xor SIGN_BIT, PTR_SIZE)
  End If
  CallNextHookProc = CallNextHookEx(lPtr, nCode, wParam, lParam)
End Function

Public Function InitFireOnceTimerThunk(pObj As Object, ByVal pfnCallback As Long, Optional Delay As Long) As IUnknown
  Const STR_THUNK    As String = "6AAAAABag+oFgeogERkAV1aLdCQUg8YIgz4AdCqL+oHHBBMZAIvCBSgSGQCri8IFZBIZAKuLwgV0EhkAqzPAq7kIAAAA86WBwgQTGQBSahj/UhBai/iLwqu4AQAAAKszwKuri3QkFKWlg+8Yi0IMSCX/AAAAUItKDDsMJHULWIsPV/9RFDP/62P/QgyBYgz/AAAAjQTKjQTIjUyIMIB5EwB101jHAf80JLiJeQTHQQiJRCQEi8ItBBMZAAWgEhkAUMHgCAW4AAAAiUEMWMHoGAUA/+CQiUEQiU8MUf90JBRqAGoAiw//URiJRwiLRCQYiTheX7g0ExkALSARGQAFABQAAMIQAGaQi0QkCIM4AHUqg3gEAHUkgXgIwAAAAHUbgXgMAAAARnUSi1QkBP9CBItEJAyJEDPAwgwAuAJAAIDCDACQi1QkBP9CBItCBMIEAA8fAItUJAT/SgSLQgR1HYtCDMZAEwCLCv9yCGoA/1Eci1QkBIsKUv9RFDPAwgQAi1QkBIsKi0EohcB0J1L/0FqD+AF3SYsKUv9RLFqFwHU+iwpSavD/cSD/USRaqQAAAAh1K4sKUv9yCGoA/1EcWv9CBDPAUFT/chD/UhSLVCQIx0IIAAAAAFLodv///1jCFABmkA==" ' 27.3.2019 9:14:57
  Const THUNK_SIZE    As Long = 5652
  Static hThunk      As Long
  Dim aParams(0 To 9)  As Long
  Dim lSize            As Long

  aParams(0) = ObjPtr(pObj)
  aParams(1) = pfnCallback
  #If ImplSelfContained Then
      If hThunk = 0 Then
        hThunk = pvThunkGlobalData("InitFireOnceTimerThunk")
      End If
  #End If
  If hThunk = 0 Then
      hThunk = VirtualAlloc(0, THUNK_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
      If hThunk = 0 Then
        Exit Function
      End If
      Call CryptStringToBinary(STR_THUNK, Len(STR_THUNK), CRYPT_STRING_BASE64, hThunk, THUNK_SIZE)
      aParams(2) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemAlloc")
      aParams(3) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemFree")
      aParams(4) = GetProcAddress(GetModuleHandle("user32"), "SetTimer")
      aParams(5) = GetProcAddress(GetModuleHandle("user32"), "KillTimer")
      '--- for IDE protection
      Debug.Assert pvGetIdeOwner(aParams(6))
      If aParams(6) <> 0 Then
        aParams(7) = GetProcAddress(GetModuleHandle("user32"), "GetWindowLongA")
        aParams(8) = GetProcAddress(GetModuleHandle("vba6"), "EbMode")
        aParams(9) = GetProcAddress(GetModuleHandle("vba6"), "EbIsResetting")
      End If
      #If ImplSelfContained Then
        pvThunkGlobalData("InitFireOnceTimerThunk") = hThunk
      #End If
  End If
  lSize = CallWindowProc(hThunk, 0, Delay, VarPtr(aParams(0)), VarPtr(InitFireOnceTimerThunk))
  Debug.Assert lSize = THUNK_SIZE
End Function

Property Get ThunkPrivateData(pThunk As IUnknown, Optional ByVal Index As Long) As Long
  Dim lPtr            As Long

  lPtr = ObjPtr(pThunk)
  If lPtr <> 0 Then
      Call CopyMemory(ThunkPrivateData, ByVal (lPtr Xor SIGN_BIT) + 8 + Index * 4 Xor SIGN_BIT, PTR_SIZE)
  End If
End Property

Property Let ThunkPrivateData(pThunk As IUnknown, Optional ByVal Index As Long, ByVal lValue As Long)
  Dim lPtr            As Long

  lPtr = ObjPtr(pThunk)
  If lPtr <> 0 Then
      Call CopyMemory(ByVal (lPtr Xor SIGN_BIT) + 8 + Index * 4 Xor SIGN_BIT, lValue, PTR_SIZE)
  End If
End Property

Public Function InitCleanupThunk(ByVal hHandle As Long, sModuleName As String, sProcName As String) As IUnknown
  Const STR_THUNK    As String = "6AAAAABag+oFgepQEDwBV1aLdCQUgz4AdCeL+oHHPBE8AYvCBcwQPAGri8IFCBE8AauLwgUYETwBq7kCAAAA86WBwjwRPAFSahD/Ugxai/iLwqu4AQAAAKuLRCQMq4tEJBCrg+8Qi0QkGIk4Xl+4UBE8AS1QEDwBwhAAkItEJAiDOAB1KoN4BAB1JIF4CMAAAAB1G4F4DAAAAEZ1EotUJAT/QgSLRCQMiRAzwMIMALgCQACAwgwAkItUJAT/QgSLQgTCBAAPHwCLVCQE/0oEi0IEdRL/cgj/UgyLVCQEiwpS/1EQM8DCBAAPHwA=" ' 25.3.2019 14:03:56
  Const THUNK_SIZE    As Long = 256
  Static hThunk      As Long
  Dim aParams(0 To 1)  As Long
  Dim pfnCleanup      As Long
  Dim lSize            As Long

  #If ImplSelfContained Then
      If hThunk = 0 Then
        hThunk = pvThunkGlobalData("InitCleanupThunk")
      End If
  #End If
  If hThunk = 0 Then
      hThunk = VirtualAlloc(0, THUNK_SIZE, MEM_COMMIT, PAGE_EXECUTE_READWRITE)
      If hThunk = 0 Then
        Exit Function
      End If
      Call CryptStringToBinary(STR_THUNK, Len(STR_THUNK), CRYPT_STRING_BASE64, hThunk, THUNK_SIZE)
      aParams(0) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemAlloc")
      aParams(1) = GetProcAddress(GetModuleHandle("ole32"), "CoTaskMemFree")
      #If ImplSelfContained Then
        pvThunkGlobalData("InitCleanupThunk") = hThunk
      #End If
  End If
  If Left$(sProcName, 1) = "#" Then
      pfnCleanup = GetProcByOrdinal(GetModuleHandle(sModuleName), Mid$(sProcName, 2))
  Else
      pfnCleanup = GetProcAddress(GetModuleHandle(sModuleName), sProcName)
  End If
  If pfnCleanup <> 0 Then
      lSize = CallWindowProc(hThunk, hHandle, pfnCleanup, VarPtr(aParams(0)), VarPtr(InitCleanupThunk))
      Debug.Assert lSize = THUNK_SIZE
  End If
End Function

Private Function pvGetIdeOwner(hIdeOwner As Long) As Boolean
  #If Not ImplNoIdeProtection Then
      Dim lProcessId      As Long

      Do
        hIdeOwner = FindWindowEx(0, hIdeOwner, "IDEOwner", vbNullString)
        Call GetWindowThreadProcessId(hIdeOwner, lProcessId)
      Loop While hIdeOwner <> 0 And lProcessId <> GetCurrentProcessId()
  #End If
  pvGetIdeOwner = True
End Function

#If ImplSelfContained Then
  Private Property Get pvThunkGlobalData(sKey As String) As Long
      Dim sBuffer          As String

      sBuffer = String$(50, 0)
      Call GetEnvironmentVariable("_MST_GLOBAL" & App.hInstance & "_" & sKey, sBuffer, Len(sBuffer) - 1)
      pvThunkGlobalData = Val(Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1))
  End Property

  Private Property Let pvThunkGlobalData(sKey As String, ByVal lValue As Long)
      Call SetEnvironmentVariable("_MST_GLOBAL" & App.hInstance & "_" & sKey, lValue)
  End Property
#End If

---

In the main Form

add the declaration

Code:

---

Private m_pSubclass    As IUnknown

---

In the Form_load

Code:

---

If Not InDesignMode() Then Set m_pSubclass = InitSubclassingThunk(hWnd, Me, InitAddressOfMethod(Me, 5).MyApp_Subclass(0, 0, 0, 0, 0))

---

Add the procedure

Code:

---

Public Function MyApp_Subclass(ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long, Handled As Boolean) As Long
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 10/02/2019
  ' * Time            : 17:56
  ' * Module Name      : frmMain
  ' * Module Filename  : Main.frm
  ' * Procedure Name  : MyApp_Subclass
  ' * Purpose          :
  ' * Parameters      :
  ' *                    ByVal hWnd As Long
  ' *                    ByVal wMsg As Long
  ' *                    ByVal wParam As Long
  ' *                    ByVal lParam As Long
  ' *                    Handled As Boolean
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  #If hWnd And wParam And Handled Then '--- touch args
  #End If

  Select Case wMsg
      Case WM_COPYDATA
        Call Communication_Received(lParam)
        Handled = True
  End Select

End Function

---

Create a new module that will contains the code for managing IPC messages

Code:

---

Option Explicit

Private Type COPYDATASTRUCT
  dwData              As Long
  cbData              As Long
  lpData              As Long
End Type

Public Const WM_COPYDATA = &H4A

'' *** Copies a block of memory from one location to another.
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Public Function StringItem(sDelimString As String, sDelim As String, ByVal lItemIndex As Long, Optional sDefault As String = vbNullString) As String
  ' #VBIDEUtils#***********************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 02/12/2001
  ' * Time            : 15:28
  ' * Module Name      : Lib_Module
  ' * Module Filename  : Lib.bas
  ' * Procedure Name  : StringItem
  ' * Purpose          :
  ' * Parameters      :
  ' *                    sDelimString As String
  ' *                    sDelim As String
  ' *                    ByVal lItemIndex As Long
  ' *                    Optional sDefault As String = vbNullString
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  Dim asItems()        As String
  Dim lUbound          As Long

  asItems = Split(sDelimString, sDelim)
  lUbound = UBound(asItems)
  lItemIndex = lItemIndex - 1
  If lUbound >= lItemIndex Then
      StringItem = asItems(lItemIndex)
  Else
      StringItem = sDefault
  End If

End Function

Sub Communication_Received(lParam As Long)
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 08/28/2019
  ' * Time            : 13:23
  ' * Module Name      : Communication_Module
  ' * Module Filename  : Communication.bas
  ' * Procedure Name  : Communication_Received
  ' * Purpose          :
  ' * Parameters      :
  ' *                    lParam As Long
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  ' #VBIDEUtilsERROR#
  On Error GoTo ERROR_Communication_Received

  Dim cds              As COPYDATASTRUCT
  Dim buf(1 To 255)    As Byte
  Dim sMessage        As String

  Dim sCommand        As String
  dim sData                        as String       

  Call CopyMemory(cds, ByVal lParam, Len(cds))

  Select Case cds.dwData
      Case 1:
        'MsgBox "got a 1"

      Case 2:
        'MsgBox "got a 2"

      Case 3: ' *** VSTO Addin Communication
        Call CopyMemory(buf(1), ByVal cds.lpData, cds.cbData)
        sMessage = StrConv(buf, vbUnicode)
        sMessage = Left$(sMessage, InStr(1, sMessage, Chr$(0)) - 1)

                sCommand = StringItem(sMessage, ":", 1)
                sData = StringItem(sMessage, ":", 2)

        ' *** We Manage the message
        ' *** and we do the needed  work
                Select Case sMessage
              Case "ShowMessage"
                                        Msgbox sData
                                       
              Case "yyyy"

                End Select
  End Select

EXIT_Communication_Received:
  On Error Resume Next

  Exit Sub

  ' #VBIDEUtilsERROR#
ERROR_Communication_Received:
  Resume EXIT_Communication_Received

End Sub

---

Finally a sampleshowing how to send a message from the VSTO addin to the VB6 Application

Code:

---

Call IPC_MyApp_SendText("ShowMessage:This is great")

---

Setup at runtime a form as a MDI child, export the MDI form as a normal form

November 1, 2021, 4:57 am

≫ Next: Generate a EPC QRCode for SEPA mobile Paiement

≪ Previous: Inter Process Communication between Outlook VSTO addin (in VB.NET) and VB6 App

$

0

0

This code shows how to set a MDI child forma as classical form
And vice-versa

Code:

---

' #VBIDEUtils#************************************************************
' * Author          :
' * Web Site        :
' * E-Mail          :
' * Date            : 11/01/2021
' * Time            : 12:45
' * Module Name      : Module1
' * Module Filename  : Module1.bas
' * Purpose          :
' * Purpose          :
' **********************************************************************
' * Comments        :
' *
' *
' * Example          :
' *
' * See Also        :
' *
' * History          :
' *
' *
' **********************************************************************

Option Explicit

Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWndParent&, ByVal hWndChildAfter&, ByVal lpClassName$, ByVal lpWindowName$) As Long

Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function IsWindow Lib "user32.dll" (ByVal hWnd As Long) As Long
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long

Private Const GWL_STYLE = (-16)
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000

Private Sub DisableEnableMinMax(oForm As Form, bDisable As Boolean)
  ' #VBIDEUtils#***********************************************************
  ' * Author          :
  ' * Web Site        : http://www.syndicassist.com
  ' * E-Mail          : info@syndicassist.com
  ' * Date            : 06/26/2008
  ' * Time            : 18:05
  ' * Module Name      : Module1
  ' * Module Filename  : Module1.bas
  ' * Procedure Name  : DisableEnableMinMax
  ' * Purpose          :
  ' * Parameters      :
  ' *                    oForm As Form
  ' *                    bDisable As Boolean
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  ' #VBIDEUtilsERROR#
  On Error GoTo ERROR_DisableEnableMinMax

  Dim nRet            As Long

  ' *** The following code strips out the minimize and maximize buttons from the main MDI Frame.
  ' *** There is no other way to do this that I can find.  Note that if you want to set the form caption dynamically, you must do this first, because
  ' *** the caption sets the window style when set dynamically, and undoes all the work.

  ' *** Get current window style value
  nRet = GetWindowLong(oForm.hWnd, GWL_STYLE)
  If bDisable Then
      ' *** Remove style settings for the buttons
      nRet = nRet Xor WS_MINIMIZEBOX
      nRet = nRet Xor WS_MAXIMIZEBOX
  Else
      nRet = nRet Or WS_MINIMIZEBOX
      nRet = nRet Or WS_MAXIMIZEBOX
  End If
 
  ' *** Put the style back
  nRet = SetWindowLong(oForm.hWnd, GWL_STYLE, nRet)

EXIT_DisableEnableMinMax:
  On Error Resume Next

  Exit Sub

  ' #VBIDEUtilsERROR#
ERROR_DisableEnableMinMax:
  Resume EXIT_DisableEnableMinMax

End Sub

Private Function LoadChildForm(frmChild As VB.Form, hWndParent As Long, Optional bDesktop As Boolean = False) As Long
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 11/01/2021
  ' * Time            : 12:45
  ' * Module Name      : Module1
  ' * Module Filename  : Module1.bas
  ' * Procedure Name  : LoadChildForm
  ' * Purpose          :
  ' * Parameters      :
  ' *                    frmChild As VB.Form
  ' *                    hWndParent As Long
  ' *                    Optional bDesktop As Boolean = False
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  ' #VBIDEUtilsERROR#
  On Error GoTo ERROR_LoadChildForm

  If Not bDesktop And (hWndParent = 0) Then
      Err.Raise vbObjectError + 1, "LoadChildForm", "bDesktop flag must be True if you wish to set " & "this form to be a child of desktop."
      Exit Function
  End If

  If (Not CBool(IsWindow(hWndParent))) And (hWndParent <> 0) Then
      Err.Raise vbObjectError + 1, "LoadChildForm", "Invalid parent window handle."
      Exit Function
  End If

  Load frmChild
  LoadChildForm = SetParent(frmChild.hWnd, hWndParent)

EXIT_LoadChildForm:
  On Error Resume Next

  Exit Function

  ' #VBIDEUtilsERROR#
ERROR_LoadChildForm:
  Resume EXIT_LoadChildForm

End Function

Public Sub MDI_Not_Child(frmChild As Form)
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 10/26/2019
  ' * Time            : 11:06
  ' * Module Name      : Module1
  ' * Module Filename  : Module1.bas
  ' * Procedure Name  : MDI_Not_Child
  ' * Purpose          :
  ' * Parameters      :
  ' *                    frmChild As Form
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  ' #VBIDEUtilsERROR#
  On Error GoTo ERROR_MDI_Not_Child

  Call DisableEnableMinMax(frmChild, False)
  Call LoadChildForm(frmChild, 0, True)

EXIT_MDI_Not_Child:
  On Error Resume Next

  Exit Sub

  ' #VBIDEUtilsERROR#
ERROR_MDI_Not_Child:
  Resume EXIT_MDI_Not_Child

End Sub

Public Sub MDI_To_Child(frmParent As Form, frmChild As Form)
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 10/06/2019
  ' * Time            : 08:49
  ' * Module Name      : Module1
  ' * Module Filename  : Module1.bas
  ' * Procedure Name  : MDI_To_Child
  ' * Purpose          :
  ' * Parameters      :
  ' *                    frmParent As Form
  ' *                    frmChild As Form
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  ' #VBIDEUtilsERROR#
  On Error GoTo ERROR_MDI_To_Child

  Dim hClientArea      As Long
  hClientArea = FindWindowEx(frmParent.hWnd, 0&, "MDIClient", vbNullChar)

  Call DisableEnableMinMax(frmChild, True)
  Call LoadChildForm(frmChild, hClientArea)

  frmChild.Move 0, 0

EXIT_MDI_To_Child:
  On Error Resume Next

  Exit Sub

  ' #VBIDEUtilsERROR#
ERROR_MDI_To_Child:
  Resume EXIT_MDI_To_Child

End Sub

---

Code:

---

Private Sub Command1_Click()

  If Command1.Tag = vbNullString Then
      Call MDI_Not_Child(Me)
      Command1.Tag = "MDI"
  Else
      Call MDI_To_Child(frmMain, Me)
      Command1.Tag = vbNullString
  End If

End Sub

---

Sample project attached

Attached Files

• MDI.zip (3.0 KB)

Generate a EPC QRCode for SEPA mobile Paiement

November 1, 2021, 5:34 am

≫ Next: IBAN Validator

≪ Previous: Setup at runtime a form as a MDI child, export the MDI form as a normal form

$

0

0

This code is used to generate QR code that can be used to initiate SEPA credit transfer.
The QRCode can be saved as BMP or JPG.



The code is using the DLL qrcodelib.dll.

The QrCode generated in the sample allows you to make a gift of 10€ to the Red Cross of Belgium (it is mandatory of cours, and only if you validate it)

The QRCode must read in your mobile app and needs of course a human validation.

Code:

---

  Dim sQRCode      As String

  sQRCode = QRCode_SEPA_Payment("BE72000000001616", "BPOTBEB1", "Croix-Rouge de Belgique", 10, "Gift", False)
 
  Picture1.Picture = LoadPicture(sQRCode)

---

Main routine

Code:

---

Public Function QRCode_SEPA_Payment(sIBAN As String, sBic As String, sNom As String, dMontant As Double, sCommunication As String, Optional bJPG As Boolean = False) As String
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 11/01/2021
  ' * Time            : 13:15
  ' * Module Name      : Module1
  ' * Module Filename  : Main.bas
  ' * Procedure Name  : QRCode_SEPA_Payment
  ' * Purpose          :
  ' * Parameters      :
  ' *                    sIBAN As String
  ' *                    sBic As String
  ' *                    sNom As String
  ' *                    dMontant As Double
  ' *                    sCommunication As String
  ' *                    Optional bJPG As Boolean = False
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  Dim sQRCode          As String

  Dim sReturn          As String

  Dim sBMPFile        As String
  Dim sTmpJPG          As String

  sQRCode = vbNullString
  sQRCode = sQRCode & "BCD" & vbCrLf
  sQRCode = sQRCode & "1" & vbCrLf
  sQRCode = sQRCode & "1" & vbCrLf
  sQRCode = sQRCode & "SCT" & vbCrLf
  sQRCode = sQRCode & sBic & vbCrLf
  sQRCode = sQRCode & sNom & vbCrLf
  sQRCode = sQRCode & Replace(sIBAN, " ", vbNullString) & vbCrLf
  sQRCode = sQRCode & "EUR" & Format$(dMontant, "0.00") & vbCrLf
  sQRCode = sQRCode & "GDDS" & vbCrLf
  sQRCode = sQRCode & sCommunication & vbCrLf
  sQRCode = sQRCode & "" & vbCrLf
  sQRCode = sQRCode & "MyApp" & vbCrLf

  sBMPFile = GetTempFileName(sExtension:="bmp")
  Call FastQRCode(sQRCode, sBMPFile)

  sReturn = sBMPFile

  If FileLen(sBMPFile) > 20 Then
      If bJPG Then
        sTmpJPG = GetTempFileName(sExtension:="jpg")
        Call ResampleImage(sBMPFile, sTmpJPG, 80, 80, 100)
        If FileExist(sTmpJPG) Then
            QRCode_SEPA_Payment = sTmpJPG
        End If
      End If
  End If

  QRCode_SEPA_Payment = sReturn

End Function

---

Full projectQRCodeSEPA.zip

Attached Images

 

Attached Files

• QRCodeSEPA.zip (226.9 KB)

IBAN Validator

November 1, 2021, 5:44 am

≫ Next: Code to validate Eurpean VAT number and retrieve informations on the company

≪ Previous: Generate a EPC QRCode for SEPA mobile Paiement

$

0

0

This code check if an IBan account is valid or not

Code:

---

Debug.Print IBAN_Validator("BE72000000001616")

---

Code:

---

Option Explicit

Private Const IbanCountryLengths As String = "AL28AD24AT20AZ28BH22BE16BA20BR29BG22CR21HR21CY28CZ24DK18DO28EE20FO18" & _
  "FI18FR27GE22DE22GI23GR27GL18GT28HU28IS26IE22IL23IT27KZ20KW30LV21LB28" & _
  "LI21LT20LU20MK19MT31MR27MU30MC27MD24ME22NL18NO15PK24PS29PL28PT25RO24" & _
  "SM27SA24RS22SK24SI19ES24SE24CH21TN24TR26AE23GB22VG24QA29"

Public Function IBAN_Validator(psIBAN As String) As Boolean
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 12/22/2014
  ' * Time            : 14:30
  ' * Module Name      : IBAN_Module
  ' * Module Filename  : IBAN.bas
  ' * Procedure Name  : IBAN_Validator
  ' * Purpose          :
  ' * Parameters      :
  ' *                    psIBAN As String
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************
  Dim sIBAN            As String
  Dim nI                As Integer

  sIBAN = UCase(psIBAN)

  ' *** Remove spaces
  sIBAN = Replace(sIBAN, " ", "")

  ' *** Check if psIBAN contains only uppercase characters and numbers
  For nI = 1 To Len(sIBAN)
      If Not ((Asc(Mid$(sIBAN, nI, 1)) <= Asc("9") And Asc(Mid$(sIBAN, nI, 1)) >= Asc("0")) Or _
        (Asc(Mid$(sIBAN, nI, 1)) <= Asc("Z") And Asc(Mid$(sIBAN, nI, 1)) >= Asc("A"))) Then
        IBAN_Validator = False
        Exit Function
      End If
  Next

  ' *** Check if length of psIBAN equals expected length for country
  If Not IBAN_ValidatorCountryLength(Left$(sIBAN, 2), Len(sIBAN)) Then
      IBAN_Validator = False
      Exit Function
  End If

  ' *** Rearrange
  sIBAN = Right$(sIBAN, Len(sIBAN) - 4) & Left$(sIBAN, 4)

  ' *** Replace characters
  For nI = 0 To 25
      sIBAN = Replace(sIBAN, Chr(nI + Asc("A")), nI + 10)
  Next

  ' *** Check remainder
  IBAN_Validator = Mod97(sIBAN) = 1

End Function

Private Function IBAN_ValidatorCountryLength(sCountryCode As String, nIBANLen As Integer) As Boolean
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 12/22/2014
  ' * Time            : 14:30
  ' * Module Name      : IBAN_Module
  ' * Module Filename  : IBAN.bas
  ' * Procedure Name  : IBAN_ValidatorCountryLength
  ' * Purpose          :
  ' * Parameters      :
  ' *                    sCountryCode As String
  ' *                    nIBANLen As Integer
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************
 
  Dim i                As Integer
  For i = 0 To Len(IbanCountryLengths) / 4 - 1
      If Mid$(IbanCountryLengths, i * 4 + 1, 2) = sCountryCode And CInt(Mid$(IbanCountryLengths, i * 4 + 3, 2)) = nIBANLen Then
        IBAN_ValidatorCountryLength = True
        Exit Function
      End If
  Next i
  IBAN_ValidatorCountryLength = False
 
End Function

Private Function Mod97(Num As String) As Integer
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 12/22/2014
  ' * Time            : 14:30
  ' * Module Name      : IBAN_Module
  ' * Module Filename  : IBAN.bas
  ' * Procedure Name  : Mod97
  ' * Purpose          :
  ' * Parameters      :
  ' *                    Num As String
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************
  Dim nTmp            As Long
  Dim sTmp            As String

  Do While Val(Num) >= 97
      If Len(Num) > 5 Then
        sTmp = Left$(Num, 5)
        Num = Right$(Num, Len(Num) - 5)
      Else
        sTmp = Num
        Num = ""
      End If
      nTmp = CLng(sTmp)
      nTmp = nTmp Mod 97
      sTmp = CStr(nTmp)
      Num = sTmp & Num
  Loop
  Mod97 = CInt(Num)
 
End Function

---

Code to validate Eurpean VAT number and retrieve informations on the company

November 1, 2021, 6:14 am

≫ Next: Code to determine if the VB6 App is running under a Terminal Server Session

≪ Previous: IBAN Validator

$

0

0

This code is used to validate an European VAT number using the WebService Vies (provided by the European Commission)

It retrieve also the informations of the company

Sample of use

Code:

---

Private Sub Command1_Click()
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 08/02/2012
  ' * Time            : 14:13
  ' * Module Name      : Form1
  ' * Module Filename  : Form1.frm
  ' * Procedure Name  : Command1_Click
  ' * Purpose          :
  ' * Parameters      :
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  Dim sXMLVAT          As String
  Dim sError          As String
  Dim sMessage        As String

  If LenB(tbVAT.Text) > 4 Then
      If VAT_Validator(tbVAT.Text, sXMLVAT, sError) Then
        sMessage = "VAT is valid" & vbCrLf
        sMessage = sMessage & "Country" & " : " & TVA_GetInfo(sXMLVAT, "countryCode") & vbCrLf
        sMessage = sMessage & "VAT" & " : " & TVA_GetInfo(sXMLVAT, "countryCode") & " " & TVA_GetInfo(sXMLVAT, "vatNumber") & vbCrLf
        sMessage = sMessage & "Name" & " : " & TVA_GetInfo(sXMLVAT, "name") & vbCrLf
        sMessage = sMessage & "Address" & " : " & TVA_GetInfo(sXMLVAT, "address") & vbCrLf
        tbResult.Text = sMessage
      Else
        If LenB(sError) Then
            tbResult.Text = sError
        Else
            tbResult.Text = "Invalid VAT"
        End If
      End If
  End If

End Sub

---

The code

Code:

---

' #VBIDEUtils#************************************************************
' * Author          :
' * Web Site        :
' * E-Mail          :
' * Date            : 11/01/2021
' * Time            : 13:54
' * Module Name      : Module1
' * Module Filename  : Module1.bas
' * Purpose          :
' * Purpose          :
' **********************************************************************
' * Comments        :
' *
' *
' * Example          :
' *
' * See Also        :
' *
' * History          :
' *
' *
' **********************************************************************

Option Explicit

Private Function GetCorrectVAT(sVAT As String) As String
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 06/12/2013
  ' * Time            : 07:47
  ' * Module Name      : Module1
  ' * Module Filename  : Module1.bas
  ' * Procedure Name  : GetCorrectVAT
  ' * Purpose          :
  ' * Parameters      :
  ' *                    sVAT As String
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  ' #VBIDEUtilsERROR#
  On Error GoTo ERROR_GetCorrectVAT

  '  Belgique      BE0999.999.999      10 chiffres
  '  Danemark      DK99 99 99 99        4 blocs de 2 chiffres
  '  Allemagne    DE999999999          1 bloc de 9 chiffres
  '  Grèce        EL999999999          1 bloc de 9 chiffres
  '  Espagne      ESX9999999X (1)      1 bloc de 9 caractères
  '  France        FRXX999999999        1 bloc de 2 caractères et 1 bloc de 9 chiffres
  '  Irlande      IE9S99999L          1 bloc de 8 caractères
  '  Italie        IT99999999999        1 bloc de 11 chiffres
  '  Luxembourg    LU99999999          1 bloc de 8 chiffres
  '  Pays-Bas      NL999999999B99 (2)  1 bloc de 12 caractères
  '  Autriche      ATU99999999 (3)      1 bloc de 9 caractères
  '  Portugal      PT999999999          1 bloc de 9 chiffres
  '  Finlande      FI99999999          1 bloc de 8 chiffres
  '  Suède        SE999999999999      1 bloc de 12 chiffres
  '  Royaume-Uni  GB999 9999 99        1 bloc de 3, 1 bloc de 4 et 1 bloc de 2 chiffres
  '                GB999 9999 99 999 (4) même format que ci avant + 1 bloc de 3 chiffres
  '                GBGD999 (5)          1 bloc de 5 caractères
  '                GBHA999 (6)          1 bloc de 5 caractères
  '  Chypre        CY99999999L          1 bloc de 9 caractères
  '  République tchèque  CZ99999999    1 bloc de 8,9 ou 10 chiffres
  '                        CZ999999999
  '                        CZ9999999999
  '  Estonie      EE999999999          1 bloc de 9 chiffres
  '  Lettonie      LV99999999999        1 bloc de 11 chiffres
  '  Lituanie      LT999999999          1 bloc de 9 ou 12 chiffres
  '                LT999999999999
  '  Hongrie      HU99999999          1 bloc de 8 chiffres
  '  Malte        MT99999999          1 bloc de 8 chiffres
  '  Pologne      PL9999999999        1 bloc de 10 chiffres
  '  Slovénie      SI99999999          1 bloc de 8 chiffres
  '  République slovaque  SK9999999999  1 bloc de 10 chiffres
  '  Bulgarie      BG999999999          1 bloc de 9 ou 10 chiffres
  '                BG9999999999
  '  Roumanie      RO9999999999        1 bloc de minimum 2 chiffres et de maximum 10 chiffres
  '  Croatie      HR99999999999        1 bloc de 11 chiffres
  '
  '  (1) Le premier et le dernier caractère peuvent être de type alphabétique ou numérique mais ils ne peuvent pas être tous les deux numériques.
  '  (2) La 10ème position suivant le préfixe code pays est toujours "B"
  '  (3) La première position suivant le préfixe code pays est toujours "U"
  '  (4) Identifie la branche de l'assujetti
  '  (5) Identifie le gouvernement départemental
  '  (6) Identifie l'autorité de santé
  '  9 : représente un chiffre
  '  S : une lettre, un chiffre, "+" ou " * "  X : un caractère ou un chiffre
  '  L : une lettre

  Dim sTmp            As String
  Dim sCountry        As String
  Dim bForceBE        As Boolean

  sCountry = GetCountryVAT(sVAT)

  ' *** If no country, we enforce to Belgium
  If (LenB(sCountry) = 0) And IsNumeric(sVAT) Then
      sTmp = "BE" & sVAT
      bForceBE = True
  Else
      sTmp = sVAT

      If sCountry = "BE" Then bForceBE = True
  End If

  sTmp = Replace(sTmp, " ", vbNullString)
  sTmp = Replace(sTmp, ".", vbNullString)
  sTmp = Replace(sTmp, "-", vbNullString)

  sTmp = Trim$(Mid$(sTmp & "  ", 3))

  If (Len(sTmp) = 9) And bForceBE Then
      sTmp = "0" & sTmp
  End If

EXIT_GetCorrectVAT:
  On Error Resume Next

  GetCorrectVAT = sTmp

  Exit Function

  ' #VBIDEUtilsERROR#
ERROR_GetCorrectVAT:
  Resume EXIT_GetCorrectVAT

End Function

Private Function GetCountryVAT(sVAT As String) As String
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 06/12/2013
  ' * Time            : 07:47
  ' * Module Name      : Module1
  ' * Module Filename  : Module1.bas
  ' * Procedure Name  : GetCountryVAT
  ' * Purpose          :
  ' * Parameters      :
  ' *                    sVAT As String
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  ' #VBIDEUtilsERROR#
  On Error GoTo ERROR_GetCountryVAT

  Dim sTmp            As String

  sTmp = UCase$(Left$(sVAT & "  ", 2))

  If IsNumeric(sTmp) Then sTmp = vbNullString

EXIT_GetCountryVAT:
  On Error Resume Next

  GetCountryVAT = sTmp

  Exit Function

  ' #VBIDEUtilsERROR#
ERROR_GetCountryVAT:
  Resume EXIT_GetCountryVAT

End Function

Private Function GetStringBetweenTags(ByVal sSearchIn As String, ByVal sFrom As String, ByVal sUntil As String, Optional nPosAfter As Long, Optional ByVal nStartAtPos As Long = 0) As String
  ' #VBIDEUtils#***********************************************************
  ' * Programmer Name  :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 01/15/2001
  ' * Time            : 13:31
  ' * Module Name      : Module1
  ' * Module Filename  : Module1.bas
  ' * Procedure Name  : GetStringBetweenTags
  ' * Parameters      :
  ' *                    ByVal sSearchIn As String
  ' *                    ByVal sFrom As String
  ' *                    ByVal sUntil As String
  ' *                    Optional nPosAfter As Long
  ' *                    Optional ByVal nStartAtPos As Long = 0
  ' **********************************************************************
  ' * Comments        :
  ' * This function gets in a string and two keywords
  ' * and returns the string between the keywords
  ' *
  ' **********************************************************************

  Dim nPos1            As Long
  Dim nPos2            As Long
  Dim nPos            As Long
  Dim nLen            As Long
  Dim sFound          As String
  Dim nLenFrom        As Long

  On Error GoTo ERROR_GetStringBetweenTags

  nLenFrom = Len(sFrom)

  nPos1 = InStr(nStartAtPos + 1, sSearchIn, sFrom, vbTextCompare)
  nPos2 = InStr(nPos1 + nLenFrom, sSearchIn, sUntil, vbTextCompare)

  If (nPos1 = 0) Or (nPos2 = 0) Then
      sFound = vbNullString
  Else
      nPos = nPos1 + nLenFrom
      nLen = nPos2 - nPos
      sFound = Mid$(sSearchIn, nPos, nLen)
  End If

  GetStringBetweenTags = sFound

  If nPos + nLen > 0 Then
      nPosAfter = (nPos + nLen) - 1
  End If

  Exit Function

ERROR_GetStringBetweenTags:
  GetStringBetweenTags = vbNullString

End Function

Private Function PostWebserviceXML(ByVal AsmxUrl As String, ByVal SoapActionUrl As String, ByVal XmlBody As String) As String
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 12/03/2012
  ' * Time            : 14:14
  ' * Module Name      : Module1
  ' * Module Filename  : Module1.bas
  ' * Procedure Name  : PostWebserviceXML
  ' * Purpose          :
  ' * Parameters      :
  ' *                    ByVal AsmxUrl As String
  ' *                    ByVal SoapActionUrl As String
  ' *                    ByVal XmlBody As String
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  ' #VBIDEUtilsERROR#
  On Error GoTo ERROR_PostWebserviceXML

  Dim oDOM            As Object
  Dim oXMLHttp        As Object
  Dim sRet            As String

  ' *** Create objects to DOMDocument and XMLHTTP
  Set oDOM = CreateObject("MSXML2.DOMDocument")
  Set oXMLHttp = CreateObject("MSXML2.XMLHTTP")

  ' *** Load XML
  oDOM.Async = False
  oDOM.LoadXML XmlBody

  ' *** Open the webservice
  oXMLHttp.Open "POST", AsmxUrl, False

  ' *** Create headings
  oXMLHttp.setRequestHeader "Content-Type", "text/xml; charset=utf-8"
  oXMLHttp.setRequestHeader "SOAPAction", SoapActionUrl

  ' *** Send XML command
  oXMLHttp.sEnd oDOM.xml

  ' *** Retrieve response text from webservice
  sRet = oXMLHttp.responseText

  ' *** Close object
  Set oXMLHttp = Nothing

  ' *** Return result
  PostWebserviceXML = sRet

EXIT_PostWebserviceXML:
  On Error Resume Next

  Exit Function

  ' #VBIDEUtilsERROR#
ERROR_PostWebserviceXML:
  PostWebserviceXML = vbNullString
  Resume EXIT_PostWebserviceXML

End Function

Public Function TVA_GetInfo(sXMLTVA As String, sField As String) As String
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 02/08/2015
  ' * Time            : 07:58
  ' * Module Name      : Module1
  ' * Module Filename  : Module1.bas
  ' * Procedure Name  : TVA_GetInfo
  ' * Purpose          :
  ' * Parameters      :
  ' *                    sXMLTVA As String
  ' *                    sField As String
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  TVA_GetInfo = XML_Quick_GetTextNodeText(sXMLTVA, sField)

End Function

Public Function VAT_Validator(sVAT As String, sXMLVAT As String, sError As String) As Boolean
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 12/03/2012
  ' * Time            : 13:15
  ' * Module Name      : Module1
  ' * Module Filename  : Module1.bas
  ' * Procedure Name  : VAT_Validator
  ' * Purpose          :
  ' * Parameters      :
  ' *                    sVAT As String
  ' *                    sXMLVAT As String
  ' *                    sError As String
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  ' #VBIDEUtilsERROR#
  On Error GoTo ERROR_VAT_Validator

  Dim sSoapAction      As String
  Dim sURL            As String
  Dim sXML            As String

  Dim slCountry        As String
  Dim slVAT            As String

  slCountry = GetCountryVAT(sVAT)
  slVAT = GetCorrectVAT(sVAT)

  sURL = "https://ec.europa.eu/taxation_customs/vies/services/checkVatService"
  sSoapAction = "urn:ec.europa.eu:taxud:vies:services:checkVat:types/checkVat"

  sXML = vbNullString
  sXML = sXML & "<?xml version=""1.0"" encoding=""utf-8""?>"
  sXML = sXML & "<SOAP-ENV:Envelope xmlns:SOAP-ENV=""http://schemas.xmlsoap.org/soap/envelope/"">"
  sXML = sXML & "  <SOAP-ENV:Body>"
  sXML = sXML & "    <tns1:checkVat xmlns:tns1=""urn:ec.europa.eu:taxud:vies:services:checkVat:types"">"
  sXML = sXML & "      <tns1:countryCode>" & slCountry & "</tns1:countryCode>"
  sXML = sXML & "      <tns1:vatNumber>" & slVAT & "</tns1:vatNumber>"
  sXML = sXML & "    </tns1:checkVat>"
  sXML = sXML & "  </SOAP-ENV:Body>"
  sXML = sXML & "</SOAP-ENV:Envelope>"

  sXMLVAT = PostWebserviceXML(sURL, sSoapAction, sXML)

  If InStrB(LCase$(sXMLVAT), "<valid>true</valid>") > 0 Then
      VAT_Validator = True
  Else
      VAT_Validator = False
      If InStrB(LCase$(sXMLVAT), "<valid>false</valid>") > 0 Then
        ' *** TVA invalide
      Else
        ' *** Un erreur du service
        sError = XML_Quick_GetTextNodeText(sXMLVAT, "faultstring")

        Select Case sError
            Case "INVALID_INPUT": sError = "The provided CountryCode is invalid or the VAT number is empty"
            Case "SERVICE_UNAVAILABLE": sError = "The service is unavailable, try again later"
            Case "MS_UNAVAILABLE": sError = "The Member State service is unavailable, try again later or with another Member State"
            Case "TIMEOUT": sError = "The Member State service could not be reach in time, try again later or with another Member State"
            Case "SERVER_BUSY": sError = "The service can't process your request. Try again latter"
        End Select
      End If
  End If

EXIT_VAT_Validator:
  On Error Resume Next

  Exit Function

  ' #VBIDEUtilsERROR#
ERROR_VAT_Validator:
  Resume EXIT_VAT_Validator

End Function

Private Function XML_Quick_GetTextNodeText(sXML As String, ByVal sXPath As String) As String
  ' #VBIDEUtils#***********************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 09/05/2003
  ' * Purpose          :
  ' * Project Name    : SyndicAssist
  ' * Module Name      : Module1
  ' * Procedure Name  : XML_Quick_GetTextNodeText
  ' * Parameters      :
  ' *                    sXML As String
  ' *                    ByVal sXPath As String
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * History          :
  ' *
  ' * See Also        :
  ' *
  ' *
  ' **********************************************************************

  Dim sTmp            As String

  sTmp = GetStringBetweenTags(sXML, "<" & sXPath & ">", "</" & sXPath & ">")

  If (InStrB(sTmp, vbLf) > 0) Or (InStrB(sTmp, vbCr) > 0) Then sTmp = Replace(Replace(sTmp, vbCrLf, vbLf), vbLf, vbCrLf)

  XML_Quick_GetTextNodeText = sTmp

End Function

---

And the test project VATValidator.zip

Attached Files

• VATValidator.zip (4.9 KB)

Code to determine if the VB6 App is running under a Terminal Server Session

November 1, 2021, 6:18 am

≫ Next: VB6 Pick Color from Screen Usercontrol

≪ Previous: Code to validate Eurpean VAT number and retrieve informations on the company

$

0

0

Code to determine if the VB6 App isrunning under a Terminal Server Session

Code:

---

Private Const SM_REMOTESESSION = &H1000
Private Const SM_REMOTECONTROL = &H2001
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Public Function Is_TerminalServer() As Boolean
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 08/19/2011
  ' * Time            : 12:58
  ' * Module Name      : Lib_Module
  ' * Module Filename  : Lib.bas
  ' * Procedure Name  : Is_TerminalServer
  ' * Purpose          :
  ' * Parameters      :
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  ' #VBIDEUtilsERROR#
  On Error GoTo ERROR_Is_TerminalServer

  If GetSystemMetrics(SM_REMOTESESSION) > 0 Then
      Is_TerminalServer = True
  Else
      Is_TerminalServer = False
  End If

EXIT_Is_TerminalServer:
  On Error Resume Next

  Exit Function

  ' #VBIDEUtilsERROR#
ERROR_Is_TerminalServer:
  Resume EXIT_Is_TerminalServer

End Function

---

VB6 Pick Color from Screen Usercontrol

November 2, 2021, 6:52 am

≫ Next: Display a list of connected users to a MS Access DB

≪ Previous: Code to determine if the VB6 App is running under a Terminal Server Session

$

0

0

Just a little usercontrol I made to get a color from the screen . Uses API's so it should work on most OS. Drop it in your project and go. Try it and see if you like it. As always , have fun with it.

Attached Images

 

Attached Files

• UC_ScreenColor.zip (4.9 KB)

---

Display a list of connected users to a MS Access DB

November 3, 2021, 4:59 am

≫ Next: Funny Text Effect (for spalsh screen for instance)

≪ Previous: VB6 Pick Color from Screen Usercontrol

$

0

0

This code reads and display the .LDB file generated by MS Access where informations about connected users are logged.

The use :
Debug.Print Global_ReadAccessLockFile("D:\YourDatabase.ldb")

and will return
MY_LAPTOP;Admin;YES

Computer Name;User Name;Locking user

Code:

---

' #VBIDEUtils#************************************************************
' * Author          :
' * Web Site        :
' * E-Mail          :
' * Date            : 10/11/2008
' * Module Name      : Module1
' * Module Filename  : LDB.bas
' * Purpose          :
' * Purpose          :
' **********************************************************************
' * Comments        :
' *
' *
' * Example          :
' *
' * See Also        :
' *
' * History          :
' *
' *
' **********************************************************************

Option Explicit

Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As Any, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function LockFile Lib "kernel32" (ByVal hFile As Long, ByVal dwFileOffsetLow As Long, ByVal dwFileOffsetHigh As Long, ByVal nNumberOfBytesToLockLow As Long, ByVal nNumberOfBytesToLockHigh As Long) As Long
Private Declare Function UnlockFile Lib "kernel32" (ByVal hFile As Long, ByVal dwFileOffsetLow As Long, ByVal dwFileOffsetHigh As Long, ByVal nNumberOfBytesToUnlockLow As Long, ByVal nNumberOfBytesToUnlockHigh As Long) As Long

Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const OPEN_EXISTING = 3
Private Const START_LOCK = &H10000001      ' *** Start of locks

Public Function Global_ReadAccessLockFile(Optional sFile As String = vbNullString) As String
  ' #VBIDEUtils#***********************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 10/11/2008
  ' * Module Name      : LDB_Module
  ' * Module Filename  : ldb.bas
  ' * Procedure Name  : Global_ReadAccessLockFile
  ' * Purpose          :
  ' * Parameters      :
  ' *                    Optional sFile As String = vbNullString
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  ' #VBIDEUtilsERROR#
  On Error GoTo ERROR_Handler

  Dim hFile            As Long
  Dim nReturn          As Long
  Dim nBytesRead      As Long
  Dim sComputer        As String
  Dim sUser            As String
  Dim nUsers          As Long

  Dim sUsersLock      As String

  sUsersLock = vbNullString

  If LenB(sFile) = 0 Then GoTo Exit_Handler

  ' *** Open file in protected mode
  hFile = CreateFile(ByVal sFile, ByVal GENERIC_READ Or GENERIC_WRITE, ByVal FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, ByVal OPEN_EXISTING, ByVal 0&, ByVal 0&)

  If hFile <> -1 Then
      Do
        nUsers = nUsers + 1

        ' *** Retrieve the computer name
        sComputer = Space(32)
        nReturn = ReadFile(hFile, ByVal sComputer, 32, nBytesRead, ByVal 0&)
        sComputer = Left$(sComputer, InStr(sComputer, Chr(0)) - 1)
        If (nReturn = 0) Or (nBytesRead = 0) Then Exit Do

        ' *** Retrieve the user name
        sUser = Space(32)
        nReturn = ReadFile(hFile, ByVal sUser, 32, nBytesRead, ByVal 0&)
        sUser = Left$(sUser, InStr(sUser, Chr(0)) - 1)
        If nReturn = 0 Or nBytesRead = 0 Then Exit Do

        ' *** Check if the user is still connected by lock the file, and log with computer name, IP adress and User name
        If LockFile(hFile, START_LOCK + nUsers - 1, 0, 1, 0) = 0 Then
            ' *** An error occured, so it is still locked by the user
            sUsersLock = sUsersLock & sComputer & ";" & sUser & ";YES" & vbCrLf
        Else
            ' *** Nothing special, the user isn't locking
            sUsersLock = sUsersLock & sComputer & ";" & sUser & ";NO" & vbCrLf
            Call UnlockFile(hFile, START_LOCK + nUsers - 1, 0, 1, 1)
        End If
      Loop

      CloseHandle hFile
  End If

Exit_Handler:
  On Error Resume Next

  Global_ReadAccessLockFile = sUsersLock

  Exit Function

  ' #VBIDEUtilsERROR#
ERROR_Handler:
  Resume Exit_Handler
  Resume

End Function

---

Funny Text Effect (for spalsh screen for instance)

November 3, 2021, 5:31 am

≫ Next: Transform your form in YingYang with transparency

≪ Previous: Display a list of connected users to a MS Access DB

$

0

0

This code is a very very old code (more than 20 years) I used in my apps to add some annimation during loading, on the splash screen

Justs call (adapting the parameters of course)
TextEffect Me, "This is a funny and easy Text effect", 120, 50, False, 50, 0, vbRed

Code:

---

' #VBIDEUtils#************************************************************
' * Programmer Name  :
' * Web Site        :
' * E-Mail          :
' * Date            : 08/11/1999
' * Time            : 10:56
' * Module Name      : TextEffect_Module
' * Module Filename  : TextEffect.bas
' **********************************************************************
' * Comments        :
' *
' *
' **********************************************************************

Option Explicit

Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function SetTextCharacterExtra Lib "gdi32" (ByVal hdc As Long, ByVal nCharExtra As Long) As Long

Private Type RECT
  Left                As Long
  Top                  As Long
  Right                As Long
  Bottom              As Long
End Type

Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hbrush As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Const COLOR_BTNFACE = 15

Private Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hdc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long

Private Const DT_BOTTOM = &H8
Private Const DT_CALCRECT = &H400
Private Const DT_CENTER = &H1
Private Const DT_CHARSTREAM = 4          '  Character-stream, PLP
Private Const DT_DISPFILE = 6            '  Display-file
Private Const DT_EXPANDTABS = &H40
Private Const DT_EXTERNALLEADING = &H200
Private Const DT_INTERNAL = &H1000
Private Const DT_LEFT = &H0
Private Const DT_METAFILE = 5            '  Metafile, VDM
Private Const DT_NOCLIP = &H100
Private Const DT_NOPREFIX = &H800
Private Const DT_PLOTTER = 0            '  Vector plotter
Private Const DT_RASCAMERA = 3          '  Raster camera
Private Const DT_RASDISPLAY = 1          '  Raster display
Private Const DT_RASPRINTER = 2          '  Raster printer
Private Const DT_RIGHT = &H2
Private Const DT_SINGLELINE = &H20
Private Const DT_TABSTOP = &H80
Private Const DT_TOP = &H0
Private Const DT_VCENTER = &H4
Private Const DT_WORDBREAK = &H10

Private Declare Function OleTranslateColor Lib "OLEPRO32.DLL" (ByVal OLE_COLOR As Long, ByVal HPALETTE As Long, pccolorref As Long) As Long
Private Const CLR_INVALID = -1

Public Sub TextEffect(Obj As Object, ByVal sText As String, ByVal lX As Long, ByVal lY As Long, Optional ByVal bLoop As Boolean = False, Optional ByVal lStartSpacing As Long = 128, Optional ByVal lEndSpacing As Long = -1, Optional ByVal oColor As Long = vbWindowText)
  ' #VBIDEUtils#************************************************************
  ' * Programmer Name  :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 08/11/1999
  ' * Time            : 10:56
  ' * Module Name      : TextEffect_Module
  ' * Module Filename  : TextEffect.bas
  ' * Procedure Name  : TextEffect
  ' * Parameters      :
  ' *                    obj As Object
  ' *                    ByVal sText As String
  ' *                    ByVal lX As Long
  ' *                    ByVal lY As Long
  ' *                    Optional ByVal bLoop As Boolean = False
  ' *                    Optional ByVal lStartSpacing As Long = 128
  ' *                    Optional ByVal lEndSpacing As Long = -1
  ' *                    Optional ByVal oColor As OLE_COLOR = vbWindowText
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' **********************************************************************

  ' *** Kerning describes the spacing between characters when a font is written out.
  ' *** By default, fonts have a preset default kerning, but this very easy to modify
  ' *** under the Win32 API.

  ' *** The following (rather unusally named?) API function is all you need:
  ' *** Private Declare Function SetTextCharacterExtra Lib "gdi32" () (ByVal hdc As Long, ByVal nCharExtra As Long) As Long
  ' *** By setting nCharExtra to a negative value, you bring the characters closer together,
  ' *** and by setting to a positive values the characters space out.
  ' *** It works with VB's print methods too.

  Dim lHDC            As Long
  Dim i                As Long
  Dim x                As Long
  Dim lLen            As Long
  Dim hbrush          As Long
  Static tR            As RECT
  Dim iDir            As Long
  Dim lTime            As Long
  Dim lIter            As Long
  Dim bSlowDown        As Boolean
  Dim lColor          As Long
  Dim bDoIt            As Boolean

  lHDC = Obj.hdc
  iDir = -1
  i = lStartSpacing
  tR.Left = lX
  tR.Top = lY
  tR.Right = lX
  tR.Bottom = lY

  OleTranslateColor oColor, 0, lColor

  hbrush = CreateSolidBrush(GetSysColor(COLOR_BTNFACE))
  lLen = Len(sText)

  SetTextColor lHDC, lColor
  bDoIt = True

  Do While bDoIt
      lTime = timeGetTime
      If (i < -3) And Not (bLoop) And Not (bSlowDown) Then
        bSlowDown = True
        iDir = 1
        lIter = (i + 4)
      End If
      If (i > 128) Then iDir = -1
      If Not (bLoop) And iDir = 1 Then
        If (i = lEndSpacing) Then
            ' Stop
            bDoIt = False
        Else
            lIter = lIter - 1
            If (lIter <= 0) Then
              i = i + iDir
              lIter = (i + 4)
            End If
        End If
      Else
        i = i + iDir
      End If

      FillRect lHDC, tR, hbrush
      x = 32 - (i * lLen)
      SetTextCharacterExtra lHDC, i
      DrawText lHDC, sText, lLen, tR, DT_CALCRECT
      tR.Right = tR.Right + 4
      If (tR.Right > Obj.ScaleWidth \ Screen.TwipsPerPixelX) Then tR.Right = Obj.ScaleWidth \ Screen.TwipsPerPixelX
      DrawText lHDC, sText, lLen, tR, DT_LEFT
      Obj.Refresh

      Do
        If Obj.Visible = False Then Exit Sub
      Loop While (timeGetTime - lTime) < 20
  Loop
  DeleteObject hbrush

End Sub

---

Sample app TextEffect.zip

Attached Files

• TextEffect.zip (2.9 KB)

Transform your form in YingYang with transparency

November 3, 2021, 6:01 am

≫ Next: Resize easily your forms

≪ Previous: Funny Text Effect (for spalsh screen for instance)

$

0

0

This code is also very very old, it changes the layout of the form as a YingYang with transparency



Just add this code
Private Sub Form_Load()

YingYang Me

End Sub

Code:

---

Option Explicit

Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

Private Const RGN_AND = 1
Private Const RGN_OR = 2
Private Const RGN_XOR = 3
Private Const RGN_DIFF = 4
Private Const RGN_COPY = 5

Private YY              As Long

Public Sub YingYang(obj As Form)
  Dim Cercle          As Long
  Dim RECT            As Long
  Dim PCercleH        As Long
  Dim PCercleB        As Long
  Dim HCercle          As Long
  Dim Cadre            As Long
  Dim TrouB            As Long
  Dim TrouH            As Long
  Dim CercleBis        As Long
  Dim HCercleBis      As Long
  Dim CercleBisBis    As Long
  Dim Ying_Yang        As Long
  Dim YYang            As Long

  Dim h                As Long
  Dim l                As Long
  Dim HBord            As Long
  Dim LBord            As Long
  Dim HT              As Long
  Dim lT              As Long

  h = obj.Height / Screen.TwipsPerPixelY
  l = obj.Width / Screen.TwipsPerPixelX

  HBord = Int(h / 100)
  LBord = Int(l / 100)

  HT = Int(h / 10)
  lT = Int(l / 10)

  HCercle = CreateEllipticRgn(((l - (2 * LBord)) / 4) + LBord, ((h - (2 * HBord)) / 2) + HBord, 3 * (((l - (2 * LBord)) / 4) + LBord), (h - HBord))
  Cercle = CreateEllipticRgn(LBord, HBord, l - LBord, h - HBord)
  RECT = CreateRectRgn(l / 2, 0, l, h)
  CombineRgn HCercle, Cercle, RECT, RGN_DIFF

  HCercleBis = CreateEllipticRgn(LBord, HBord, l - LBord, h - HBord)
  PCercleB = CreateEllipticRgn(((l - (2 * LBord)) / 4) + LBord, ((h - (2 * HBord)) / 2) + HBord, 3 * (((l - (2 * LBord)) / 4) + LBord), (h - HBord))
  CombineRgn HCercleBis, HCercle, PCercleB, RGN_DIFF

  CercleBis = CreateEllipticRgn(LBord, HBord, l - LBord, h - HBord)
  PCercleH = CreateEllipticRgn(((l - (2 * LBord)) / 4) + LBord, HBord, 3 * (((l - (2 * LBord)) / 4) + LBord), ((h - (2 * HBord)) / 2) + HBord)
  CombineRgn CercleBis, Cercle, PCercleH, RGN_DIFF

  CercleBisBis = CreateEllipticRgn(LBord, HBord, l - LBord, h - HBord)
  HCercle = CreateEllipticRgn(0, 0, l, h)
  CombineRgn CercleBisBis, CercleBis, HCercleBis, RGN_DIFF

  Ying_Yang = CreateEllipticRgn(0, 0, l, h)
  Cadre = CreateEllipticRgn(0, 0, l, h)
  CombineRgn Ying_Yang, Cadre, CercleBisBis, RGN_DIFF

  YYang = CreateEllipticRgn(0, 0, l, h)
  TrouB = CreateEllipticRgn(((l - (2 * LBord)) / 2) + LBord - (lT / 2), ((3 * (h - (2 * HBord)) / 4)) + HBord - (HT / 2), ((l - (2 * LBord)) / 2) + LBord + (lT / 2), ((3 * (h - (2 * HBord)) / 4)) + HBord + (HT / 2))
  CombineRgn YYang, Ying_Yang, TrouB, RGN_OR

  YY = CreateEllipticRgn(0, 0, l, h)
  TrouH = CreateEllipticRgn(((l - (2 * LBord)) / 2) + LBord - (lT / 2), ((h - (2 * HBord)) / 4) + HBord - (HT / 2), ((l - (2 * LBord)) / 2) + LBord + (lT / 2), ((h - (2 * HBord)) / 4) + HBord + (HT / 2))
  CombineRgn YY, YYang, TrouH, RGN_DIFF

  SetWindowRgn obj.hWnd, YY, True

  DeleteObject Cercle
  DeleteObject RECT
  DeleteObject PCercleH
  DeleteObject PCercleB
  DeleteObject HCercle
  DeleteObject Cadre
  DeleteObject TrouB
  DeleteObject TrouH
  DeleteObject CercleBis
  DeleteObject HCercleBis
  DeleteObject CercleBisBis
  DeleteObject Ying_Yang
  DeleteObject YYang

End Sub

---

Sample app YingYang.zip

Attached Images

 

Attached Files

• YingYang.zip (1.9 KB)

Resize easily your forms

November 3, 2021, 6:24 am

≫ Next: How to create/update an appointment in Outllook

≪ Previous: Transform your form in YingYang with transparency

$

0

0

This is the code I use for resizing forms easilly with all controls etc...



Just add in your form

Code:

---

Option Explicit

Private mclsResize      As New class_Elastic

Private Sub Form_Load()

  mclsResize.Init Me

End Sub

Private Sub Form_Resize()

  On Error Resume Next
  mclsResize.FormResize Me

End Sub

Private Sub Form_Unload(Cancel As Integer)

  Set mclsResize = Nothing
 
End Sub

---

And this is the class_Resize code

Code:

---

'****************************************************************
' Name: class_Elastic
' Description:This class can change size and location of controls on your form
'  1. Resize form
'  2. Change screen resolution
'
' By: Mikhail Shmukler
'
' Inputs:None
' Returns:None
' Assumes:
'  1. Add Elastic.cls
'  2. Add declaration 'Private El as New class_Elastic'
'  3. Insert string like 'El.init Me' (formload event)
'  4. Insert string like 'El.FormResize Me' (Resize event)
'  5. Press 'F5' and resize form ....
' Side Effects:None
'
'****************************************************************

Option Explicit
Private nFormHeight    As Long
Private nFormWidth      As Long
Private nNumOfControls  As Long
Private nTop()          As Long
Private nLeft()        As Long
Private nHeight()      As Long
Private nWidth()        As Long
Private nFontSize()    As Long
'Private nRightMargin()  As Long
Private bFirstTime      As Boolean
Private bFirstTimeMaximized As Boolean

Public sNameTopIgnore  As String

Private Const nCaptionSize As Long = 400

Public Sub Init(oForm As Form, Optional pbFirstime As Boolean = False)
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 07/25/2010
  ' * Time            : 07:52
  ' * Module Name      : class_Elastic
  ' * Module Filename  : Elastic.cls
  ' * Procedure Name  : Init
  ' * Purpose          :
  ' * Parameters      :
  ' *                    oForm As Form
  ' *                    Optional nWindState As Variant
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  On Error Resume Next

  Dim i                As Long

  With oForm
      nFormHeight = .Height
      nFormWidth = .Width
      nNumOfControls = .Controls.Count - 1
      bFirstTime = True
      If Not IsMissing(pbFirstime) Then
        bFirstTime = pbFirstime
        bFirstTimeMaximized = pbFirstime
      Else
        bFirstTimeMaximized = True
      End If

      ReDim nTop(nNumOfControls)
      ReDim nLeft(nNumOfControls)
      ReDim nHeight(nNumOfControls)
      ReDim nWidth(nNumOfControls)
      ReDim nFontSize(nNumOfControls)

      For i = 0 To nNumOfControls
        nTop(i) = .Controls(i).Top
        nLeft(i) = .Controls(i).Left
        nHeight(i) = .Controls(i).Height
        nWidth(i) = .Controls(i).Width
        nFontSize(i) = .FontSize
      Next
  End With

EXIT_Init:
  On Error Resume Next

  Exit Sub

End Sub

Public Sub InitControl(oControls As Object, pnHeight As Long, pnWidth As Long, pnFontSize As Double, Optional pbFirstime As Boolean = False)
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 07/25/2010
  ' * Time            : 07:52
  ' * Module Name      : class_Elastic
  ' * Module Filename  : Elastic.cls
  ' * Procedure Name  : InitControl
  ' * Purpose          :
  ' * Parameters      :
  ' *                    oControls As Object
  ' *                    pnHeight As Long
  ' *                    pnWidth As Long
  ' *                    pnFontSize As Double
  ' *                    Optional pbFirstime As Boolean = False
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  On Error Resume Next

  Dim i                As Long

  nFormHeight = pnHeight
  nFormWidth = pnWidth
  nNumOfControls = oControls.Count - 1
  bFirstTime = True
  If Not IsMissing(pbFirstime) Then
      bFirstTime = pbFirstime
      bFirstTimeMaximized = pbFirstime
  Else
      bFirstTimeMaximized = True
  End If

  ReDim nTop(nNumOfControls)
  ReDim nLeft(nNumOfControls)
  ReDim nHeight(nNumOfControls)
  ReDim nWidth(nNumOfControls)
  ReDim nFontSize(nNumOfControls)

  For i = 0 To nNumOfControls
      nTop(i) = oControls(i).Top
      nLeft(i) = oControls(i).Left
      nHeight(i) = oControls(i).Height
      nWidth(i) = oControls(i).Width
      nFontSize(i) = pnFontSize
  Next

EXIT_InitControl:
  On Error Resume Next

  Exit Sub

End Sub

Public Sub InitTop(frm As Form, Optional pbFirstime As Boolean = False)
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 07/25/2010
  ' * Time            : 07:52
  ' * Module Name      : class_Elastic
  ' * Module Filename  : Elastic.cls
  ' * Procedure Name  : InitTop
  ' * Purpose          :
  ' * Parameters      :
  ' *                    frm As Form
  ' *                    Optional nWindState As Variant
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  On Error Resume Next

  Dim i                As Long

  For i = 0 To nNumOfControls
      If TypeOf frm.Controls(i) Is Line Then
        nTop(i) = frm.Controls(i).Y1
        nHeight(i) = frm.Controls(i).Y2
      Else
        nTop(i) = frm.Controls(i).Top
        nHeight(i) = frm.Controls(i).Height
      End If
  Next

End Sub

Public Sub FormResize(oForm As Form, Optional bForceTop As Boolean = False)
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 11/03/2014
  ' * Time            : 09:00
  ' * Module Name      : class_Elastic
  ' * Module Filename  : Elastic.cls
  ' * Procedure Name  : FormResize
  ' * Purpose          :
  ' * Parameters      :
  ' *                    oForm As Form
  ' *                    Optional bForceTop As Boolean = False
  ' *                    Optional bRedraw As Boolean = True
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  On Error Resume Next

  Dim i                As Long
  Dim dRatioX          As Double
  Dim dRatioY          As Double
  Dim nSaveRedraw      As Long

  With oForm
      nSaveRedraw = .AutoRedraw

      .AutoRedraw = True

      If bFirstTime Then
        If (.Visible) And (.WindowState = 2) And (bFirstTimeMaximized) Then
            bFirstTimeMaximized = False
            bFirstTime = False
            .WindowState = 0
            Call Init(oForm, False)
            .WindowState = 2
        End If

        bFirstTime = False
        Exit Sub
      End If

      If .Height < nFormHeight Then .Height = nFormHeight
      If .Width < nFormWidth Then .Width = nFormWidth

      dRatioY = 1# * (nFormHeight - nCaptionSize) / (.Height - nCaptionSize)
      dRatioX = 1# * nFormWidth / .Width

      For i = 0 To nNumOfControls
        'If TypeOf .Controls(I) Is Label Then
        '  .Controls(I).Move Int(nLeft(I) / dRatioX), Int(nTop(I) / dRatioY), Int(nWidth(I) / dRatioX)
        '
        If TypeOf .Controls(i) Is ComboBox Then
            .Controls(i).Move Int(nLeft(i) / dRatioX), Int(nTop(i) / dRatioY), Int(nWidth(i) / dRatioX)

        ElseIf TypeOf .Controls(i) Is Line Then
            .Controls(i).Y1 = Int(nTop(i) / dRatioY)
            .Controls(i).X1 = Int(nLeft(i) / dRatioX)
            .Controls(i).Y2 = Int(nHeight(i) / dRatioY)
            .Controls(i).X2 = Int(nWidth(i) / dRatioX)
        Else
            .Controls(i).Move Int(nLeft(i) / dRatioX), Int(nTop(i) / dRatioY), Int(nWidth(i) / dRatioX), Int(nHeight(i) / dRatioY)
        End If
      Next

      .AutoRedraw = nSaveRedraw
  End With

End Sub

Public Sub FormResizeNoRedraw(oForm As Form, nTopBlock As Long, Optional bForceTop As Boolean = False)
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 11/03/2014
  ' * Time            : 09:00
  ' * Module Name      : class_Elastic
  ' * Module Filename  : Elastic.cls
  ' * Procedure Name  : FormResizeNoRedraw
  ' * Purpose          :
  ' * Parameters      :
  ' *                    oForm As Form
  ' *                    Optional bForceTop As Boolean = False
  ' *                    Optional bRedraw As Boolean = True
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  On Error Resume Next

  Dim i                As Long
  Dim dRatioX          As Double
  Dim dRatioY          As Double

  With oForm
      .AutoRedraw = True
      If bFirstTime Then
        If (.Visible) And (.WindowState = 2) And (bFirstTimeMaximized) Then
            bFirstTimeMaximized = False
            bFirstTime = False
            .WindowState = 0
            Call Init(oForm, False)
            .WindowState = 2
        End If

        bFirstTime = False
        Exit Sub
      End If

      If .Height < nFormHeight Then .Height = nFormHeight
      If .Width < nFormWidth Then .Width = nFormWidth

      dRatioY = 1# * (nFormHeight - nCaptionSize) / (.Height - nCaptionSize)
      dRatioX = 1# * nFormWidth / .Width

      For i = 0 To nNumOfControls
        If TypeOf .Controls(i) Is ComboBox Then
            .Controls(i).Move Int(nLeft(i) / dRatioX), Int(nTop(i) / dRatioY), Int(nWidth(i) / dRatioX)
        Else
            .Controls(i).Move Int(nLeft(i) / dRatioX), Int(nTop(i) / dRatioY), Int(nWidth(i) / dRatioX), Int(nHeight(i) / dRatioY)
        End If
      Next
  End With

End Sub

Public Sub UserControlResize(oControls As Object, pnHeight As Long, pnWidth As Long, pnFontSize As Double)
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 11/03/2014
  ' * Time            : 09:00
  ' * Module Name      : class_Elastic
  ' * Module Filename  : Elastic.cls
  ' * Procedure Name  : UserControlResize
  ' * Purpose          :
  ' * Parameters      :
  ' *                    oControls As Object
  ' *                    pnHeight As Long
  ' *                    pnWidth As Long
  ' *                    pnFontSize As Double
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  On Error Resume Next

  Dim i                As Long
  Dim dRatioX          As Double
  Dim dRatioY          As Double

  If pnHeight < nFormHeight Then pnHeight = nFormHeight
  If pnWidth < nFormWidth Then pnWidth = nFormWidth

  dRatioY = 1# * (nFormHeight - nCaptionSize) / (pnHeight - nCaptionSize)
  dRatioX = 1# * nFormWidth / pnWidth

  For i = 0 To nNumOfControls
      If TypeOf oControls(i) Is ComboBox Then
        oControls(i).Move Int(nLeft(i) / dRatioX), Int(nTop(i) / dRatioY), Int(nWidth(i) / dRatioX)
      Else
        oControls(i).Move Int(nLeft(i) / dRatioX), Int(nTop(i) / dRatioY), Int(nWidth(i) / dRatioX), Int(nHeight(i) / dRatioY)
      End If
  Next

End Sub

Public Sub FormResizeForceTop(oForm As Form)
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 11/03/2014
  ' * Time            : 09:00
  ' * Module Name      : class_Elastic
  ' * Module Filename  : Elastic.cls
  ' * Procedure Name  : FormResize
  ' * Purpose          :
  ' * Parameters      :
  ' *                    oForm As Form
  ' *                    Optional bForceTop As Boolean = False
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  Dim i                As Long
  Dim dRatioX          As Double
  Dim dRatioY          As Double
  Dim nSaveRedraw      As Long

  On Error Resume Next

  With oForm
      nSaveRedraw = .AutoRedraw

      .AutoRedraw = True

      If bFirstTime Then
        If (.Visible) And (.WindowState = 2) And (bFirstTimeMaximized) Then
            bFirstTimeMaximized = False
            bFirstTime = False
            .WindowState = 0
            Call Init(oForm, False)
            .WindowState = 2
        End If

        bFirstTime = False
        Exit Sub
      End If

      If .Height < nFormHeight Then .Height = nFormHeight
      If .Width < nFormWidth Then .Width = nFormWidth

      dRatioY = 1# * (nFormHeight - nCaptionSize) / (.Height - nCaptionSize)
      dRatioX = 1# * nFormWidth / .Width

      For i = 0 To nNumOfControls
        If TypeOf .Controls(i) Is Line Then
            .Controls(i).Y1 = Int(nTop(i) / dRatioY)
            .Controls(i).X1 = Int(nLeft(i) / dRatioX)
            .Controls(i).Y2 = Int(nHeight(i) / dRatioY)
            .Controls(i).X2 = Int(nWidth(i) / dRatioX)
        Else
            If sNameTopIgnore = .Controls(i).Name Then
              .Controls(i).Move Int(nLeft(i) / dRatioX), nTop(i), Int(nWidth(i) / dRatioX), Int(nHeight(i) / dRatioY)
            Else
              .Controls(i).Move Int(nLeft(i) / dRatioX), Int(nTop(i) / dRatioY), Int(nWidth(i) / dRatioX), Int(nHeight(i) / dRatioY)
            End If
        End If
      Next

      .AutoRedraw = nSaveRedraw
  End With

End Sub

---

Sample app Elastic.zip

Attached Images

  

Attached Files

• Elastic.zip (3.3 KB)

How to create/update an appointment in Outllook

November 3, 2021, 6:51 am

≫ Next: Retrieve all Maibox configured in Outlook

≪ Previous: Resize easily your forms

$

0

0

This code creates an appointment, and could also update an existing appointment

Sample of use :
Call Outlook_AddUpdate_Appointment("Test-Now", Date, "Test Appointment", "This is the Body", Now, Now, sLabel:="The label", sLocation:="At Home")

If you want to update it, just use the same ID
Call Outlook_AddUpdate_Appointment("Test-Now", Date, "Updated Appointment", "This is the Body", Now, Now, sLabel:="The label", sLocation:="At Home")




Just add this module

Code:

---

Option Explicit

Public oOpenOutlook        As Object 'Outlook.APPLICATION        ' Object '
Public oOpenCalendarFolder As Object 'Outlook.Folder            ' Object '

Public Const olFolderInbox = 6
Public Const olFolderCalendar = 9
Public Const olFolderContacts = 10
Public Const olDistributionListItem = 7

Private Const olAppointmentItem = 1
Private Const olContactItem = 2

Private Const olText = 1

Public Const IMPORTANCE_LOW = 0
Public Const IMPORTANCE_NORMAL = 1
Public Const IMPORTANCE_HIGH = 2

Public Sub Outlook_AddUpdate_Appointment(sID As String, sDate As String, sSubject As String, sBody As String, _
  Optional sStartTime As String = vbNullString, Optional sEndTime As String = vbNullString, _
  Optional bAllDayEvent As Boolean = False, Optional bBusyStatus As Boolean = False, _
  Optional sLabel As String = vbNullString, Optional sLocation As String = vbNullString, _
  Optional bMeetingFlag As Boolean = False, Optional bPrivateFlag As Boolean = False, Optional sCustomProperties As String = vbNullString)
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 11/16/2005
  ' * Time            : 19:33
  ' * Module Name      : Outlook_Module
  ' * Module Filename  : Outlook.bas
  ' * Procedure Name  : Outlook_AddUpdate_Appointment
  ' * Purpose          :
  ' * Parameters      :
  ' *                    sID As String
  ' *                    sDate As String
  ' *                    sSubject As String
  ' *                    sBody As String
  ' *                    Optional sStartTime As String = vbNullString
  ' *                    Optional sEndTime As String = vbNullString
  ' *                    Optional bAllDayEvent As Boolean = False
  ' *                    Optional bBusyStatus As Boolean = False
  ' *                    Optional sLabel As String = vbNullString
  ' *                    Optional sLocation As String = vbNullString
  ' *                    Optional bMeetingFlag As Boolean = False
  ' *                    Optional bPrivateFlag As Boolean = False
  ' *                    Optional sCustomProperties As String = vbNullString
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  ' #VBIDEUtilsERROR#
  On Error GoTo ERROR_Outlook_AddUpdate_Appointment

  Dim oCalendarItems  As Object 'Outlook.Items              '
  Dim oAppointment    As Object 'Outlook.AppointmentItem    '

  If oOpenOutlook Is Nothing Then Set oOpenOutlook = CreateObject("Outlook.Application")
  If oOpenCalendarFolder Is Nothing Then Set oOpenCalendarFolder = oOpenOutlook.GetNamespace("MAPI").GetDefaultFolder(olFolderCalendar)

  ' *** Using BillingInformation to save a personnal identifier in order to allow future update/delete
  Set oCalendarItems = oOpenCalendarFolder.Items.Restrict("[BillingInformation] " & "= 'MyApp:" & sID & "'")

  If oCalendarItems.Count = 0 Then
      Set oAppointment = oOpenOutlook.CreateItem(olAppointmentItem)
  Else
      Set oAppointment = oCalendarItems.Item(1)
  End If

  With oAppointment
      .Start = sStartTime
      .End = IIf(LenB(sEndTime) = 0, sStartTime, sEndTime)
      .Subject = sSubject

      If LenB(sCustomProperties) > 0 Then
        .body = sBody & vbCrLf & sCustomProperties
      Else
        .body = sBody
      End If
      .AllDayEvent = bAllDayEvent
      .BusyStatus = IIf(bBusyStatus, 2, 0)
      .Location = sLocation
      If .UserProperties.Count = 0 Then
        .UserProperties.Add "CustomProperties", olText
        .UserProperties.Item(1).Value = sCustomProperties
      Else
        .UserProperties.Item("CustomProperties").Value = sCustomProperties
      End If

      .ReminderSet = False

      If LenB(.BillingInformation) = 0 Then .BillingInformation = "MyApp:" & sID

      .Save
  End With

EXIT_Outlook_AddUpdate_Appointment:
  Set oCalendarItems = Nothing
  Set oAppointment = Nothing

  Exit Sub

  ' #VBIDEUtilsERROR#
ERROR_Outlook_AddUpdate_Appointment:
  Resume EXIT_Outlook_AddUpdate_Appointment
  Resume
 
End Sub

---