Quantcast
Channel: VBForums - CodeBank - Visual Basic 6 and earlier
Viewing all 1484 articles
Browse latest View live

Retrieve all Maibox configured in Outlook

$
0
0
Long time ago, I had to retrieve the mailboxes configured in Outlook, allowing to select the right one.
It was not so easy to find the answer, so here it is
Code:

Public Sub Outlook_DisplayAllMailbox()
  ' #VBIDEUtils#***********************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 01/24/2007
  ' * Time            : 13:42
  ' * Module Name      : Outlook_Module
  ' * Module Filename  : Outlook.bas
  ' * Procedure Name  : Outlook_DisplayAllMailbox
  ' * Purpose          :
  ' * Parameters      :
  ' *                    oSelect As Control
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  ' #VBIDEUtilsERROR#
  On Error GoTo ERROR_Outlook_DisplayAllMailbox

  Dim objOutlook      As Object

  Dim nI              As Long

  Set objOutlook = CreateObject("Outlook.Application")

  On Error Resume Next
  For nI = 1 To objOutlook.session.Accounts.Count
      Debug.Print objOutlook.session.Accounts.Item(nI)
  Next
  On Error GoTo ERROR_Outlook_DisplayAllMailbox

EXIT_Outlook_DisplayAllMailbox:
  On Error Resume Next

  Set objOutlook = Nothing

  Exit Sub

  ' #VBIDEUtilsERROR#
ERROR_Outlook_DisplayAllMailbox:
  If Err.Number = -2147467259 Then
      MsgBox Error, vbInformation
      Resume Next
  End If

  Resume EXIT_Outlook_DisplayAllMailbox
  Resume

End Sub


Need help with usercontrol that uses MSXML2.ServerXMLHTTP

$
0
0
I have created a usercontrol similar to the VB Asycdownload usercontrol and it works, but i thought i had the cancel
downloads working but i dont. I cannot figure out if i start 6 downloads, i would like to cancel all downloads.
Sometimes the VBAscyncdownload does not work with some pages or downloads so tried to make something that works the same.

Please not that sometimes i create and array of the usercontrol so would need usercontrol(x).Canceldownload

can someone a bit smarter help me please. tks

code below is placed on a usercontrol.

Code:



'status code for getting the page successfully.
Private Const HttpStatusOK200 As Integer = 200

'status code for not getting the page
Private Const HttpFileNotFound404 As Integer = 404

'status code for request timed out.
Private Const HttpTimeOutError12002 As Integer = 12002

Private WithEvents http As WinHttpRequest

Private FF As Integer
Private mContentLength As Long
Private mProgress As Long
Dim strLocalFile As String
Dim Cancel_Download As Boolean
Public Event Progress(percent As Single)
Public Event Zero()
Public Event Finished(LocalFile As String)
Public Event PageDownloadComplete(Data As String)
Public CurrentDownloads As New Collection


Public Sub CancelDownload()

    http.Abort
    Close #FF
    Kill strLocalFile
    RaiseEvent Progress(0)
    CurrentDownloads.Remove 1
    RefreshStatus
End Sub

Public Sub GetWebData(ByVal URL As String)

    On Error GoTo err
    Dim objHTTP As Object

    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    objHTTP.Open "GET", URL, True
    objHTTP.SetRequestHeader "Authorization", "Bearer " & "" ' AuthCode
    objHTTP.SetRequestHeader "Accept-Language", "en"
    objHTTP.sEnd
   
    Do While objHTTP.ReadyState <> 4

        If objHTTP.ReadyState = HttpTimeOutError12002 Then

        ElseIf objHTTP.ReadyState = HttpFileNotFound404 Then

        End If
        DoEvents

    Loop
   
   
    RaiseEvent PageDownloadComplete(objHTTP.ResponseText)

    Set objHTTP = Nothing

    Exit Sub

err:

   
End Sub

Public Sub DownloadBinary(ByVal BinaryURL As String, ByVal LocalFile As String)
    strLocalFile = LocalFile
    ' Create the WinHTTPRequest ActiveX Object.
    Set http = New WinHttpRequest
    ' Open an HTTP connection.
    http.Open "GET", BinaryURL, True  'True means asynch.
    ' Send the HTTP Request.
    http.sEnd
    CurrentDownloads.Add BinaryURL, BinaryURL
    RefreshStatus
End Sub

Private Sub http_OnResponseDataAvailable(Data() As Byte)
    mProgress = mProgress + UBound(Data) + 1
    RaiseEvent Progress(Format((mProgress / mContentLength) * 100, "00"))
    Put #FF, , Data
End Sub

Private Sub http_OnResponseFinished()
    Close #FF
    RaiseEvent Finished(strLocalFile)
    On Error Resume Next
    CurrentDownloads.Remove 1
    RefreshStatus
    On Error GoTo 0

End Sub

Private Sub http_OnResponseStart(ByVal Status As Long, ByVal ContentType As String)
'Text1.Text = http.getAllResponseHeaders()
    mProgress = 0
    mContentLength = CLng(http.GetResponseHeader("Content-Length"))
    FF = FreeFile
    'ProgressBar1.Max = mContentLength
    Open strLocalFile For Binary As #FF

End Sub

Private Sub UserControl_Resize()
    UserControl.Width = 960
    UserControl.Height = 960
End Sub

Private Sub RefreshStatus()
    UserControl.Cls
    UserControl.CurrentX = 0
    UserControl.CurrentY = 0
    UserControl.Print CurrentDownloads.Count

    If CurrentDownloads.Count = 0 Then
        RaiseEvent Zero
    End If

End Sub

A clsObjectExtender new version

$
0
0
From 2005 the clsObjectExtender was a fine class for late binding objects with events. But how we can use if we have our own object which raise events and we want that object to be present on a VBScript script?
The problem with the old clsObjectExtender was the use of Variants VT_VARIANT + VT_REF. So this new version refresh the old code to do the job properly.

Also I test the code for leaks, using a 100000 loop.

The program is in main() in a module. The events comes from an array of clsObjectExtender, in a module (so we can't use WithEvents), and we attach ShinkEvent, a class which have events and some subs as methods. So we place some SinkEvent objects, in a VBScript object, using names like Debug and Sum. At the execution of the VbScript script the code fire events from ShinkEvents objects and through clsObjectExtender (in an array), they call the same sub, in Module1.bas: EventRaised, with for parameters:
oTarget is the object (ShinkEvent) who fires the event
ID is a number which we give to clsObjectExtender for Identificarion in this sub.
strName is the event name
params() is a Variant type array to hold parameters. Although is a Variant type array, if the parameter isn't variant we have to keep the same type. But if the parameter is a variant type then we can change type. From the test the VBScript for numbers use automatic adjustment, so if we have variable j with a value 1 then this have a sub-type Integer. So if we get that by reference there are a chance to alter the type, in our code, and then return the new type. That can be done with this version. Also we can pass by reference Variant Arrays.

Code:

Public Sub EventRaised(oTarget As Object, ByVal ID As Long, ByVal strName As String, params() As Variant)
    On Error Resume Next
    Dim i    As Long
    Dim Resp()
    If ID = 1001 Then
        If strName = "GetData" Then
            Resp() = oTarget.GetData()
here:
            For i = LBound(Resp) To UBound(Resp) - 1
              If pr Then Debug.Print Resp(i),
            Next i
            If i = UBound(Resp) Then
                If pr Then Debug.Print Resp(i)
            End If
        ElseIf strName = "GetString" Then
            params(1) = "1234"
        ElseIf strName = "GetNumber" Then
            params(1) = params(1) * params(1)
        ElseIf strName = "GetArray" Then
            sum = sum + params(1)(2)
            params(1)(0) = sum
            Resp() = params(1)
            GoTo here
        ElseIf strName = "GetCalc" Then
            If params(1) = "multiply" Then
                params(2) = params(3) * params(4)
            End If
        Else
            GoTo error1
        End If
    ElseIf ID = 1002 Then
        If strName = "GetNumber" Then
            params(1) = sum
        Else
            GoTo error1
        End If
    ElseIf ID = 1003 Then
        If strName = "GetVBString" Then
            params(1) = params(1) + "1234"
        ElseIf strName = "GetString" Then
            params(1) = params(1) + "123456"
        ElseIf strName = "GetDecimal" Then
          params(1) = params(1) + CDec("50000000000000000000000000")
        ElseIf strName = "GetData" Then
            Resp() = oTarget.GetData()
            GoTo here
        ElseIf strName = "GetCurrency" Then
        params(1) = params(1) + CCur("9999999999999")
        Else
            GoTo error1
        End If
    Else
        If pr Then Debug.Print "ID Event " & ID & " has no code for Events"
    End If
    Exit Sub
error1:
    If pr Then Debug.Print "Event " + strName + " has no code"
End Sub


In the Module1 there are some TestX subs where X=1 to 5. There are two globals, pr as boolean to switch the debug.print on or off, so for a lengthy run we use pr=false, and sum, a variable which alter between calls to Test sub, through events.

Try the code. Any suggestions or improvements will be appreciated.
Attached Files

Make Seamless tiles

$
0
0
I've made this app to create a seamless tile, but now that I have the composite of pictures I want in picMain, I need to know how to render the image and save as a bitmap. I've tried Bitblt and paintpicture but to no avail. Can anyone show me how to do it?
Attached Images
 
Attached Files

Scrollable viewport

$
0
0
Hi, I am trying to make an app that will load icons that i have gatherd into a display port grid.

I have a scrollable viewport that will load icons to an array of Pictureboxes based on a selected folder.
If i load a folder with 30 icons all is ok.
If i goto the root folder that has many folder and many icons it takes ages for them to load and sometimes crashes. (could run out of memory)

How would i go about loading say a hundred 1st then as i scroll load more.
I dont want to use the list view as i want more control how its displayed etc

I am using at present a Picturebox child to load the icon in, then this sits in picturebox parent array of containers.
then i have a picturebox page that holds all the Parent pictureboxes that i can scroll the parent containers.

I would like to use the instrinsic controls if possible

tks

[VB6] Decompress gzip stream with libarchive on Win10

$
0
0
Recent versions of Win10 ship tar.exe utility which for compressed archives depends on stdcall build of libarchive open-source library which is shipped disguised under the name of archiveint.dll in C:\Windows\SysWOW64 (the 32-bit version we need).

Here is a .bas module with a single public Ungzip function which accepts a compressed byte-array and on successful decompression returns True:

Code:

Option Explicit

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function archive_read_new Lib "archiveint" Alias "_archive_read_new@0" () As Long
Private Declare Function archive_read_free Lib "archiveint" Alias "_archive_read_free@4" (ByVal hArchive As Long) As Long
Private Declare Function archive_read_support_filter_gzip Lib "archiveint" Alias "_archive_read_support_filter_gzip@4" (ByVal hArchive As Long) As Long
Private Declare Function archive_read_support_format_raw Lib "archiveint" Alias "_archive_read_support_format_raw@4" (ByVal hArchive As Long) As Long
Private Declare Function archive_read_open_memory Lib "archiveint" Alias "_archive_read_open_memory@12" (ByVal hArchive As Long, pBuffer As Any, ByVal lSize As Long) As Long
Private Declare Function archive_read_next_header Lib "archiveint" Alias "_archive_read_next_header@8" (ByVal hArchive As Long, pHeader As Long) As Long
Private Declare Function archive_read_data Lib "archiveint" Alias "_archive_read_data@12" (ByVal hArchive As Long, pBuffer As Any, ByVal lSize As Long) As Long

Public Function Ungzip(baInput() As Byte, baOutput() As Byte) As Boolean
    Const BUFF_SIZE    As Long = 65536
    Dim baBuffer(0 To BUFF_SIZE - 1) As Byte
    Dim hArchive        As Long
    Dim lSize          As Long
    Dim lResult        As Long
    Dim lOutSize        As Long
   
    hArchive = archive_read_new()
    If hArchive = 0 Then
        GoTo QH
    End If
    lResult = archive_read_support_filter_gzip(hArchive)
    If lResult <> 0 Then
        GoTo QH
    End If
    lResult = archive_read_support_format_raw(hArchive)
    If lResult <> 0 Then
        GoTo QH
    End If
    lResult = archive_read_open_memory(hArchive, baInput(0), UBound(baInput) + 1)
    If lResult <> 0 Then
        GoTo QH
    End If
    lResult = archive_read_next_header(hArchive, 0)
    If lResult <> 0 Then
        GoTo QH
    End If
    baOutput = vbNullString
    Do
        lSize = archive_read_data(hArchive, baBuffer(0), UBound(baBuffer) + 1)
        If lSize = 0 Then
            Exit Do
        End If
        ReDim Preserve baOutput(0 To lOutSize + lSize - 1) As Byte
        Call CopyMemory(baOutput(lOutSize), baBuffer(0), lSize)
        lOutSize = lOutSize + lSize
    Loop
    '--- success
    Ungzip = True
QH:
    If hArchive <> 0 Then
        Call archive_read_free(hArchive)
    End If
End Function

Thus provided function can be used to decompress gzip response as returned by ServerXMLHTTP or WinHttpRequest object like this:

Code:

Option Explicit

Private Sub Form_Load()
    Dim baUncompressed() As Byte
   
    With New MSXML2.ServerXMLHTTP
        .Open "GET", "https://www.google.com/", False
        '--- note: changing this request header is important because original Mozilla/4.0 User-Agent string
        '---  prevents web servers from compressing response with gzip (or deflate)
        .SetRequestHeader "User-Agent", "Mozilla/5.0"
        .SetRequestHeader "Accept-Encoding", "gzip"
        .Send
        If .GetResponseHeader("Content-Encoding") <> "gzip" Then
            Debug.Print "Response not gzipped"
            Exit Sub
        End If
        If Not Ungzip(.ResponseBody, baUncompressed) Then
            Debug.Print "Ungzip failed"
            Exit Sub
        End If
        '--- note: response might be utf-8 encoded
        Debug.Print StrConv(baUncompressed, vbUnicode)
    End With
End Sub

cheers,
</wqw>

VB6 Simple Rolidex Usercontrol

$
0
0
Rolidex style usercontrol. Maybe someone can use it. Very basic
Attached Images
 
Attached Files

Krool's CommonControls cut out for Onesie-Twosie use

$
0
0
Ok, this is Krool's work, not mine. And this is done "with his permission".

I just downloaded his most recent copy (on November 14, 2021), and I'll probably stick with this copy, as I do feel that his work is quite mature at this point. If you want a more recent version of his code, you're on your own.

What I've done (and will build upon) is to "cut out" the individual controls from his "controls package". I'm also cutting out any/all of his custom property pages, so, if you wish to have Unicode text, captions, etc, you must set them at runtime. I cut out these property pages because leaving them makes this all much more complex, as his property pages also use his controls, which makes everything quite "interwoven". Without these property pages, it's much easier to isolate individual controls.

I'm just going to post small "demo" projects that have the individual "cut out" controls. In all cases, it'll just be a Project1.vbp and a Form1.frm (with Krool's single control on it). There are no sub-folders in the attached zip files. Everything you need is just all together.

In almost all cases, Krool also requires use of his OLEGuids.tlb typelib. And, this must be registered (with RegTLib.exe) on your computer, and then the reference in the Project1.vbp must be updated.

This piece can be a bit tricky:

  • I'd delete any older copies of Krool's OLEGuids.tlb file from your computer, as older versions aren't compatible with his most recent release.
  • I've included a copy of this OLEGuids.tlb in each of the following projects, but it's only needed once. In fact, personally, I keep the most recent version in my C:\Windows\SysWOW64 folder, registered there with RegTLib.exe. ( C:\windows\syswow64> regtlib oleguids.tlb )
  • Note that this OLEGuids.tlb file is no longer needed once your project is compiled to an executable (exe). In other words, it's only needed on your development machine, and other users won't need to worry about it.
  • When refreshing the reference to this OLEGuids.tlb file in any project, you typically must unreference any prior reference, and then browse to and re-reference the copy you've got registered on your computer, using the Project --> References option in your VB6 IDE.

All this should make it easy to add a single (or a couple) of Krool's controls to your own project. Just drag all the necessary files to your project (and also reference the OLEGuids.tlb in your project), and then you can use the control(s) from your toolbox.

Anytime I've made any change to Krool's code, I will make notes on that in these posts. I hope to not make any changes at all.

Also, as a note, if you intend to use two or three of Krool's controls in a single project (getting them from this CodeBank thread), you'll run into module redundancy. For instance, Krool's Common.bas module is used by pretty much all of his controls. However, I've included a copy of it in each of the "cut out" controls in this thread. But, since I haven't made any changes to his source code, just ignore that redundancy, and just include a single copy in your project.

Also, you can individually compile these as OCXs, but you're on your own regarding that one. If you're going to do that, I don't see why you don't just use Krool's complete OCX.

That's about it. I'll start with his TextBoxW control, and add more as I get them done. Only five attachments per post, so see subsequent posts.

p.s. I probably won't do every single one, as I'll focus on the controls in my primary project. However, you should be able to use my work as a template for pulling out any of Krool's controls from his larger project.
Attached Files

How to retrieve OS Language

$
0
0
This code will detect the OS Language of your windows

Just call Debug.Print DetectOSLanguage()

Code:

Private Declare Function GetUserDefaultLangID Lib "kernel32" () As Integer

Public Function DetectOSLanguage() As String
  ' #VBIDEUtils#***********************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 07/26/2005
  ' * Time            : 12:29
  ' * Module Name      : Lib_Module
  ' * Module Filename  : Lib.bas
  ' * Procedure Name  : DetectOSLanguage
  ' * Purpose          :
  ' * Parameters      :
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  Select Case GetUserDefaultLangID()
      Case &H0
        DetectOSLanguage = "Language_Neutral"
      Case &H400
        DetectOSLanguage = "Default Language"
      Case &H401, &H801, &HC01, &H1001, &H1401, &H1801, &H1C01, &H2001, &H2401, &H2801, &H2C01, &H3001, &H3401, &H3801, &H3C01, 16385
        DetectOSLanguage = "Araabic"
      Case &H402
        DetectOSLanguage = "Bulgarian"
      Case &H403
        DetectOSLanguage = "Catalan"
      Case &H404, &H804, &HC04, 4100
        DetectOSLanguage = "Chinese"
      Case &H405
        DetectOSLanguage = "Czech"
      Case &H406
        DetectOSLanguage = "Danish"
      Case &H407, &H807, &HC07, &H1007, 5127
        DetectOSLanguage = "German"
      Case &H408
        DetectOSLanguage = "Greek"
      Case &H409, &H809, &HC09, &H1009, &H1409, &H1809, &H1C09, &H2009, &H2409, &H2809, 11273
        DetectOSLanguage = "English"
      Case &H40A, &H80A, &HC0A, &H100A, &H140A, &H180A, &H1C0A, &H200A, &H240A, &H280A, &H2C0A, &H300A, &H340A, &H380A, &H3C0A, &H400A, &H440A, &H480A, &H4C0A, 2049
        DetectOSLanguage = "Spanish"
      Case &H40B
        DetectOSLanguage = "Finnish"
      Case &H40C, &H80C, &HC0C, &H100C, 5132
        DetectOSLanguage = "French"
      Case &H40D
        DetectOSLanguage = "Hebrew"
      Case &H40E
        DetectOSLanguage = "Hungarian"
      Case &H40F
        DetectOSLanguage = "Icelandic"
      Case &H410, 2064
        DetectOSLanguage = "Italian"
      Case &H411
        DetectOSLanguage = "Japanese"
      Case &H412, 2066
        DetectOSLanguage = "Korean"
      Case &H413, 2067
        DetectOSLanguage = "Dutch"
      Case &H414, 2068
        DetectOSLanguage = "Norwegian"
      Case &H415
        DetectOSLanguage = "Polish"
      Case &H416, 2070
        DetectOSLanguage = "Portuguese"
      Case &H418
        DetectOSLanguage = "Romanian"
      Case &H419
        DetectOSLanguage = "Russian"
      Case &H41A
        DetectOSLanguage = "Croatian"
      Case &H81A, 3098
        DetectOSLanguage = "Serbian"
      Case &H41B
        DetectOSLanguage = "Slovak"
      Case &H41C
        DetectOSLanguage = "Albanian"
      Case &H41D, 2077
        DetectOSLanguage = "Swedish"
      Case &H41E
        DetectOSLanguage = "Thai"
      Case &H41F
        DetectOSLanguage = "Turkish"
      Case &H421
        DetectOSLanguage = "Indonesian"
      Case &H422
        DetectOSLanguage = "Ukrainian"
      Case &H423
        DetectOSLanguage = "Belarusian"
      Case &H424
        DetectOSLanguage = "Slovenian"
      Case &H425
        DetectOSLanguage = "Estonian"
      Case &H426
        DetectOSLanguage = "Latvian"
      Case &H427
        DetectOSLanguage = "Lithuanian"
      Case &H429
        DetectOSLanguage = "Farsi"
      Case &H42A
        DetectOSLanguage = "Vietnamese"
      Case &H42D
        DetectOSLanguage = "Basque"
      Case &H436
        DetectOSLanguage = "Afrikaans"
      Case &H438
        DetectOSLanguage = "Faeroese"
  End Select
End Function

Download file from WEB in a few lines

$
0
0
This very short code can download a file from an URL :
Ex :
Call DownloadFile("https://www.vbforums.com/attachment.php?attachmentid=179280&d=1605528528", "D:\test.zip")

Code:

Public Function DownloadFile(sURL As String, sLocalFilename As String, Optional pUserName As String, Optional pPassWord As String) As Boolean
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 01/02/2006
  ' * Time            : 12:35
  ' * Module Name      : Lib_Module
  ' * Module Filename  : Lib.bas
  ' * Procedure Name  : DownloadFile
  ' * Purpose          :
  ' * Parameters      :
  ' *                    sURL As String
  ' *                    sLocalFilename As String
  ' *                    Optional pUserName As String
  ' *                    Optional pPassWord As String
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  ' #VBIDEUtilsERROR#
  On Error GoTo ERROR_DownloadFile

  Dim oHTTP            As Object ' MSXML2.XMLHTTP
  Dim nFile            As Integer
  Dim oByte()          As Byte

  Set oHTTP = CreateObject("MSXML2.XMLHTTP")
  oHTTP.Open "POST", sURL, False, pUserName, pPassWord
  oHTTP.Send
  If oHTTP.Status = 200 Then
      oByte = oHTTP.responseBody

      If Dir(sLocalFilename) <> vbNullString Then Kill sLocalFilename
      nFile = FreeFile
      Open sLocalFilename For Binary As #nFile
      Put #nFile, , oByte
      Close #nFile
  End If

EXIT_DownloadFile:
  On Error Resume Next

  Exit Function

  ' #VBIDEUtilsERROR#
ERROR_DownloadFile:
  Resume EXIT_DownloadFile

End Function

Generate a Prime number of 8 Digits

$
0
0
Generate a Prime number of 8 Digits (you can adjust if you need more).
I needed 8 digits pour internal security checks
Code:

Public Function EightDigitPrime() As Double
  ' #VBIDEUtils#***********************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 03/17/2003
  ' * Project Name    :
  ' * Module Name      : Lib_Module
  ' * Module Filename  : Lib.bas
  ' * Procedure Name  : EightDigitPrime
  ' * Purpose          :
  ' * Parameters      :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * Screenshot      :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  Dim dPrime          As Double
  Dim dMiddle          As Double
  Dim dCounter        As Double
  Dim dCheck1          As Double
  Dim dCheck2          As Double

  Dim nI              As Long

  Randomize Timer
Restart:
  dPrime = CDbl(10000001) + CDbl(2) * Int(Rnd * 45000000)

  dMiddle = Int(dPrime / 2)
  dCounter = 2
  For nI = CDbl(3) To Sqr(dPrime) Step 2
      dCheck1 = dPrime / dCounter
      dCheck2 = Int(dPrime / dCounter)
      If dCheck1 = dCheck2 Then GoTo Restart
      dCounter = dCounter + 1
  Next
  EightDigitPrime = dPrime

End Function

Retrieve the Dropbox folder

$
0
0
Retrieve the Dropbox folder

? Global_GetDropboxFolder()
Code:

Option Explicit

Public Function Global_GetDropboxFolder() As String
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 10/16/2015
  ' * Time            : 10:09
  ' * Module Name      : Lib_Module
  ' * Module Filename  : Lib.bas
  ' * Procedure Name  : Global_GetDropboxFolder
  ' * Purpose          :
  ' * Parameters      :
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  ' #VBIDEUtilsERROR#
  On Error GoTo ERROR_Global_GetDropboxFolder

  Dim sFile            As String

  Dim sFolder          As String

  sFolder = vbNullString

  sFile = AddBackslash(Environ("userprofile")) & "AppData\Local\DropBox\info.json"
  If FileExist(sFile) Then
      sFile = ReadFile(AddBackslash(Environ("userprofile")) & "AppData\Local\DropBox\info.json")
      sFolder = GetStringBetweenTags(sFile, """path"": """, """")
  End If

EXIT_Global_GetDropboxFolder:
  On Error Resume Next

  Global_GetDropboxFolder = sFolder

  Exit Function

  ' #VBIDEUtilsERROR#
ERROR_Global_GetDropboxFolder:
  Resume EXIT_Global_GetDropboxFolder

End Function

Public Function AddBackslash(ByVal sPath As String, Optional ByVal sChar As String = "\") As String
  ' #VBIDEUtils#***********************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 02/26/2003
  ' * Project Name    :
  ' * Module Name      : Files_Module
  ' * Module Filename  : Files.bas
  ' * Procedure Name  : AddBackslash
  ' * Purpose          : AddBackslash - Append a backslash to a path if needed
  ' * Parameters      :
  ' *                    ByVal sPath As String
  ' *                    Optional ByVal sChar As String = "\"
  ' **********************************************************************
  ' * Comments        :
  ' * Append a backslash (or any character) at the end of a path
  ' * if it isn't there already
  ' *
  ' * Example          :
  ' *
  ' * Screenshot      :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  AddBackslash = sPath

  If LenB(sPath) > 0 Then
      If Right$(sPath, 1) <> sChar Then
        AddBackslash = sPath & sChar
      End If
  End If

End Function

Public Function FileExist(sFile As String) As Boolean
  ' #VBIDEUtils#***********************************************************
  ' * Programmer Name  :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 04/11/1999
  ' * Time            : 16:53
  ' * Module Name      : Files_Module
  ' * Module Filename  : Files.bas
  ' * Procedure Name  : FileExist
  ' * Parameters      :
  ' *                    sFile As String
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' **********************************************************************

  On Error Resume Next

  Dim oFSO            As Object

  Set oFSO = CreateObject("Scripting.FileSystemObject")
  If oFSO.FileExists(sFile) Then
      FileExist = True
  Else
      FileExist = False
  End If
  Set oFSO = Nothing

End Function

Public 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      : Lib_Module
  ' * Module Filename  : Lib.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

Public Function ReadFile(sFileSource As String) As String
  ' #VBIDEUtils#************************************************************
  ' * Author          :
  ' * Web Site        :
  ' * E-Mail          :
  ' * Date            : 01/15/2001
  ' * Time            : 17:15
  ' * Module Name      :
  ' * Module Filename  :
  ' * Procedure Name  : ReadFile
  ' * Purpose          :
  ' * Parameters      :
  ' *                    sFileSource As String
  ' * Purpose          :
  ' **********************************************************************
  ' * Comments        :
  ' *
  ' *
  ' * Example          :
  ' *
  ' * See Also        :
  ' *
  ' * History          :
  ' *
  ' *
  ' **********************************************************************

  Dim oFSO            As Object
  Set oFSO = CreateObject("Scripting.FileSystemObject")

  ReadFile = oFSO.OpenTextFile(sFileSource).ReadAll

End Function

Here's code to get any part of a URL.

$
0
0
Just copy the code from the below code box and paste it into a module, and you can use it to get any part of a URL.
The part numbers are as follows.
0 = protocol
1 = username
2 = password
3 = host
4 = port
5 = path
6 = query
Any other part number results in an empty string being returned from the function.

If the requested part number is 4 (the port), but the URL doesn't contain a port number, then the returned value will be based on the protocol, as follows.
ftp = 21
gopher = 70
http = 80
https = 443
Any other protocol results in the returned port number being 0.

Code:

Public Function GetURLPart(ByVal URL As String, ByVal PartNumber As Long) As String
    Dim n As Long
    Dim n2 As Long
    Dim Protocol As String
    Dim PrePath As String
    Dim PreHost As String
    Dim UsernameAndPassword() As String
    Dim HostAndPort As String
    Dim HostAndPortSplit() As String
    Dim PathAndQuery As String
   
    n = InStr(1, URL, "://")
    If PartNumber = 0 Then
        GetURLPart = LCase$(Left$(URL, n - 1))
        Exit Function
    ElseIf PartNumber = 4 Then
        Protocol = LCase$(Left$(URL, n - 1))
    End If
    URL = Right$(URL, Len(URL) - n - 2)
   
    n = InStr(1, URL, "/")
    If n = 0 Then n = Len(URL) + 1
    PrePath = Left$(URL, n - 1)
   
    n2 = InStr(1, PrePath, "@")
    If n2 = 0 Then
        If PartNumber < 5 Then HostAndPort = PrePath
    Else
        PreHost = Left$(PrePath, n2 - 1)
        UsernameAndPassword() = Split(PreHost, ":")
        If PartNumber = 1 Then
            GetURLPart = UsernameAndPassword(0)
            Exit Function
        ElseIf PartNumber = 2 Then
            If UBound(UsernameAndPassword) > 0 Then GetURLPart = UsernameAndPassword(1)
            Exit Function
        End If
        If PartNumber < 5 Then HostAndPort = Right$(PrePath, Len(PrePath) - n2)
           
    End If
    If PartNumber < 5 Then
        HostAndPortSplit() = Split(HostAndPort, ":")
        If PartNumber = 3 Then
            GetURLPart = HostAndPortSplit(0)
        ElseIf PartNumber = 4 Then
            If UBound(HostAndPortSplit) > 0 Then
                GetURLPart = HostAndPortSplit(1)
            Else
                Select Case Protocol
                    Case "ftp"
                        GetURLPart = "21"
                    Case "gopher"
                        GetURLPart = "70"
                    Case "http"
                        GetURLPart = "80"
                    Case "https"
                        GetURLPart = "443"
                    Case Else
                        GetURLPart = "0"
                End Select
            End If
        End If
        Exit Function
    End If
   
    PathAndQuery = Right$(URL, Len(URL) - n + 1)
    n = InStr(1, PathAndQuery, "?")
    If PartNumber = 5 Then
        If n = 0 Then
            GetURLPart = PathAndQuery
        Else
            GetURLPart = Left$(PathAndQuery, n - 1)
        End If
    ElseIf PartNumber = 6 Then
        If n > 0 Then GetURLPart = Right$(PathAndQuery, Len(PathAndQuery) - n)
    End If
End Function

MS-OXRTFCP Compressed RTF Decompression Methods

$
0
0
I had a need to decompress MS-OXRTFCP Compressed RTF data that is used by Outlook messages. The format is described here in great detail: https://interoperability.blob.core.w...OXRTFCP%5d.pdf

I wasn't enjoying the prospect of turning that spec into code, so I did a quick search to see if it had already been tackled. I found this VB.net code by a user named "ForumAccount" here at vbforums: https://www.vbforums.com/showthread....xchange-Server

After a bit of struggling with the ShiftLeft/Right stuff, I plugged in some work by Jost Schwider that I found over at VBspeed: http://www.xbeat.net/vbspeed/c_Shift...tm#ShiftLeft06 and http://www.xbeat.net/vbspeed/c_Shift...m#ShiftLeftZ08

After a bit of cleanup and formatting to my preferred style, everything was working nicely so I thought I'd share it with you all in case you ever have a need for it.

There are 2 public methods that should be self-explanatory: DecompressRtfFile and DecompressRtfBytes.

Note that I use RC6 for a couple of lines because the cFSO and cArrayList classes are just too darned handy. It should be pretty straight forward to swap the RC6 code out for vanilla VB6 if you are so inclined.


Code:

Option Explicit

' This code has been adapted from a VB.net by a user named "ForumAccount": found here: https://www.vbforums.com/showthread.php?669883-NET-3-5-RtfDecompressor-Decompress-RTF-From-Outlook-And-Exchange-Server
' That code was apparently written based on the spec found here: https://docs.microsoft.com/en-us/openspecs/exchange_server_protocols/ms-oxrtfcp/65dfe2df-1b69-43fc-8ebd-21819a7463fb

Private Const mc_CircularDictionaryMaxLength As Long = &H1000&
Private Const mc_RtfHeaderLength As Long = 16

Private Enum e_CompressedRtfType
  rtf_Compressed = &H75465A4C  ' Magic number for uncompressed RTF. Reportedly very rare in the wild.
  rtf_Uncompressed = &H414C454D ' Magic number for compressed RTF used by Outlook message storage.
End Enum

Private Type RtfControl
  Flags(0 To 7) As Boolean  ' "Bit" flags
  Length As Long
End Type

Private Type CompressedRtfHeader
  CompressedSize As Long
  UncompressedSize As Long
  CompressionType As e_CompressedRtfType
  Crc As Long
End Type

Private mo_Crc As rc6.cArrayList
Private mo_Dictionary As rc6.cArrayList

Public Function DecompressRtfFile(ByVal p_CompressedRtfFilePath As String, Optional ByVal p_CheckCrc As Boolean = True) As String
  DecompressRtfFile = DecompressRtfBytes(New_c.FSO.ReadByteContent(p_CompressedRtfFilePath), p_CheckCrc)
End Function

Public Function DecompressRtfBytes(pa_CompressedRtfBytes() As Byte, Optional ByVal p_CheckCrc As Boolean = True) As String
  Dim l_Word As Long
  Dim l_Upper As Integer
  Dim l_Lower As Integer
  Dim lt_Header As CompressedRtfHeader
  Dim l_InitialLen As Long
  Dim lo_Dictionary As rc6.cArrayList
  Dim l_DictionaryIndex As Long
  Dim la_Dictionary() As Byte
  Dim l_Offset As Long
  Dim lo_UncompressedRtf As rc6.cArrayList
  Dim lt_Control As RtfControl
  Dim l_Flag As Boolean
  Dim l_CorrectedOffset As Long
  Dim ii As Long
  Dim jj As Long
  Dim kk As Long

  InitDictionary
  InitCrc
 
  ' Copy header values into lt_Header
  New_c.MemCopy ByVal VarPtr(lt_Header), ByVal VarPtr(pa_CompressedRtfBytes(0)), 16 ' .CompressedSize), ByVal VarPtr(pa_CompressedRtfBytes(0)), 4
     
  Select Case lt_Header.CompressionType
  Case rtf_Uncompressed
      ' Uncompressed, just return string
      DecompressRtfBytes = StrConv(pa_CompressedRtfBytes, vbUnicode)
 
  Case rtf_Compressed
      ' Compressed RTF - confirm CRC if required and then decompress
     
      If p_CheckCrc Then
        ' Check the data has been corrupt/tampered with by comparing the header CRC to the data CRC
        If CalculateCrc(pa_CompressedRtfBytes, mc_RtfHeaderLength) <> lt_Header.Crc Then
            Err.Raise vbObjectError, , "Stream is Corrupt."
        End If
      End If
     
      Set lo_UncompressedRtf = New_c.ArrayList(vbByte)
     
      l_InitialLen = mo_Dictionary.Count
      l_DictionaryIndex = l_InitialLen
     
      ' Stuff the "initial"/seed dictionary into our working dictionary
      mo_Dictionary.BindToArray la_Dictionary
     
      Set lo_Dictionary = New_c.ArrayList(vbByte, la_Dictionary)
      For ii = l_InitialLen To mc_CircularDictionaryMaxLength - 1
        lo_Dictionary.Add 0
      Next ii

      mo_Dictionary.ReleaseArrayBinding la_Dictionary
      Erase la_Dictionary
     
      ' Decompress the RTF data (if required).
      For ii = mc_RtfHeaderLength To UBound(pa_CompressedRtfBytes)
        lt_Control = GetRtfControl(pa_CompressedRtfBytes(ii))
        l_Offset = 1
       
        For jj = LBound(lt_Control.Flags) To UBound(lt_Control.Flags)
            l_Flag = lt_Control.Flags(jj)
           
            If l_Flag Then
              ' Uncompressed data
             
              lo_UncompressedRtf.Add pa_CompressedRtfBytes(ii + l_Offset)
              lo_Dictionary(l_DictionaryIndex) = pa_CompressedRtfBytes(ii + l_Offset)
             
              l_DictionaryIndex = l_DictionaryIndex + 1
             
              FixDictionaryIndex l_DictionaryIndex
           
            Else
              ' Compressed data
             
              '//reference bit, create word from two bytes
              l_Word = ShiftLeft(pa_CompressedRtfBytes(ii + l_Offset), 8) Or pa_CompressedRtfBytes(ii + (l_Offset + 1))

              '//get the offset into the dictionary
              l_Upper = ShiftRightZ(l_Word And &HFFF0&, 4)

              '//get the length of bytes to copy
              l_Lower = (l_Word And &HF) + 2

              If l_Upper = l_DictionaryIndex Then
                  '//special dictionary reference means that decompression is complete
                  Erase la_Dictionary
                  lo_UncompressedRtf.CopyToArray la_Dictionary
                  DecompressRtfBytes = StrConv(la_Dictionary, vbUnicode)
                 
                  Exit Function
                 
              End If

              '//cannot just copy the bytes over because the dictionary is a
              '//circular array so it must properly wrap to beginning
              For kk = 0 To l_Lower - 1
                  l_CorrectedOffset = l_Upper + kk
                  FixDictionaryIndex l_CorrectedOffset

                  If lo_UncompressedRtf.Count - 1 = lt_Header.UncompressedSize Then
                      '//this is the last token, the rest is just padding
                        Erase la_Dictionary
                        lo_UncompressedRtf.CopyToArray la_Dictionary
                        DecompressRtfBytes = StrConv(la_Dictionary, vbUnicode)
                 
                      Exit Function
                  End If

                  lo_UncompressedRtf.Add lo_Dictionary(l_CorrectedOffset)
                  lo_Dictionary(l_DictionaryIndex) = lo_Dictionary(l_CorrectedOffset)
                  l_DictionaryIndex = l_DictionaryIndex + 1

                  FixDictionaryIndex l_DictionaryIndex
              Next
             
              l_Offset = l_Offset + 1
            End If
           
            l_Offset = l_Offset + 1
        Next jj
       
        ii = ii + lt_Control.Length - 1
      Next ii
       
  Case Else
      Err.Raise 5, , "Unknown compression type: " & lt_Header.CompressionType
  End Select
End Function

Private Function GetRtfControl(ByVal p_Byte As Byte) As RtfControl
  Dim l_FlagsCount As Long
  Dim ii As Long
 
  With GetRtfControl
      For ii = LBound(.Flags) To UBound(.Flags)
        .Flags(ii) = ((p_Byte And ShiftLeft(&H1, ii)) = 0)
        If .Flags(ii) Then l_FlagsCount = l_FlagsCount + 1
      Next ii
      .Length = ((8 - l_FlagsCount) * 2) + l_FlagsCount + 1
  End With
End Function

Private Sub InitDictionary()
  Dim la_Dict() As Byte
 
  Set mo_Dictionary = Nothing
  If mo_Dictionary Is Nothing Then
      Set mo_Dictionary = New_c.ArrayList(vbByte)
      la_Dict = StrConv("{\rtf1\ansi\mac\deff0\deftab720{\fonttbl;}" & _
                        "{\f0\fnil \froman \fswiss \fmodern \fscript " & _
                        "\fdecor MS Sans SerifSymbolArialTimes New RomanCourier{\colortbl\red0\green0\blue0" & _
                        vbNewLine & _
                        "\par \pard\plain\f0\fs20\b\i\u\tab\tx", vbFromUnicode)
      mo_Dictionary.AddElements la_Dict
  End If
End Sub

Private Sub InitCrc()
  ' Found this code building CRC-32 table here:
  ' https://khoiriyyah.blogspot.com/2012/05/class-crc32-sebuah-file-vb6-code.html
 
  Const Limit = &HEDB88320
 
  Dim ii As Long
  Dim jj As Long
  Dim l_Crc As Long
 
  If mo_Crc Is Nothing Then
      Set mo_Crc = New_c.ArrayList(vbLong)
 
      For ii = 0 To 255
        l_Crc = ii
        For jj = 0 To 7
            If l_Crc And 1 Then
              l_Crc = (((l_Crc And &HFFFFFFFE) \ 2) And &H7FFFFFFF) Xor Limit
            Else
              l_Crc = ((l_Crc And &HFFFFFFFE) \ 2) And &H7FFFFFFF
            End If
        Next jj
     
        mo_Crc.Add l_Crc
      Next ii
  End If
End Sub

Private Sub FixDictionaryIndex(ByRef p_Index As Long)
  ' Make sure passed index is within our circular dictionary's range
  Do Until p_Index < mc_CircularDictionaryMaxLength
      p_Index = p_Index - mc_CircularDictionaryMaxLength
  Loop
End Sub

Private Function CalculateCrc(pa_Buffer() As Byte, Optional ByVal p_StartAtOffset As Long = 0) As Long
  ' Apparently CompressedRTF format uses a modified CRC-32 calculation.
  ' Described here: https://www.freeutils.net/source/jtnef/rtfcompressed
 
  Dim ii As Long
 
  For ii = p_StartAtOffset To UBound(pa_Buffer)
      CalculateCrc = (mo_Crc((CalculateCrc Xor pa_Buffer(ii)) And &HFF)) Xor (ShiftRightZ(CalculateCrc, 8))
  Next ii
End Function

Private Function ShiftLeft(ByVal Value As Long, ByVal ShiftCount As Long) As Long
  ' by Jost Schwider, jost@schwider.de, 20011001
  Select Case ShiftCount
  Case 0&
    ShiftLeft = Value
  Case 1&
    If Value And &H40000000 Then
      ShiftLeft = (Value And &H3FFFFFFF) * &H2& Or &H80000000
    Else
      ShiftLeft = (Value And &H3FFFFFFF) * &H2&
    End If
  Case 2&
    If Value And &H20000000 Then
      ShiftLeft = (Value And &H1FFFFFFF) * &H4& Or &H80000000
    Else
      ShiftLeft = (Value And &H1FFFFFFF) * &H4&
    End If
  Case 3&
    If Value And &H10000000 Then
      ShiftLeft = (Value And &HFFFFFFF) * &H8& Or &H80000000
    Else
      ShiftLeft = (Value And &HFFFFFFF) * &H8&
    End If
  Case 4&
    If Value And &H8000000 Then
      ShiftLeft = (Value And &H7FFFFFF) * &H10& Or &H80000000
    Else
      ShiftLeft = (Value And &H7FFFFFF) * &H10&
    End If
  Case 5&
    If Value And &H4000000 Then
      ShiftLeft = (Value And &H3FFFFFF) * &H20& Or &H80000000
    Else
      ShiftLeft = (Value And &H3FFFFFF) * &H20&
    End If
  Case 6&
    If Value And &H2000000 Then
      ShiftLeft = (Value And &H1FFFFFF) * &H40& Or &H80000000
    Else
      ShiftLeft = (Value And &H1FFFFFF) * &H40&
    End If
  Case 7&
    If Value And &H1000000 Then
      ShiftLeft = (Value And &HFFFFFF) * &H80& Or &H80000000
    Else
      ShiftLeft = (Value And &HFFFFFF) * &H80&
    End If
  Case 8&
    If Value And &H800000 Then
      ShiftLeft = (Value And &H7FFFFF) * &H100& Or &H80000000
    Else
      ShiftLeft = (Value And &H7FFFFF) * &H100&
    End If
  Case 9&
    If Value And &H400000 Then
      ShiftLeft = (Value And &H3FFFFF) * &H200& Or &H80000000
    Else
      ShiftLeft = (Value And &H3FFFFF) * &H200&
    End If
  Case 10&
    If Value And &H200000 Then
      ShiftLeft = (Value And &H1FFFFF) * &H400& Or &H80000000
    Else
      ShiftLeft = (Value And &H1FFFFF) * &H400&
    End If
  Case 11&
    If Value And &H100000 Then
      ShiftLeft = (Value And &HFFFFF) * &H800& Or &H80000000
    Else
      ShiftLeft = (Value And &HFFFFF) * &H800&
    End If
  Case 12&
    If Value And &H80000 Then
      ShiftLeft = (Value And &H7FFFF) * &H1000& Or &H80000000
    Else
      ShiftLeft = (Value And &H7FFFF) * &H1000&
    End If
  Case 13&
    If Value And &H40000 Then
      ShiftLeft = (Value And &H3FFFF) * &H2000& Or &H80000000
    Else
      ShiftLeft = (Value And &H3FFFF) * &H2000&
    End If
  Case 14&
    If Value And &H20000 Then
      ShiftLeft = (Value And &H1FFFF) * &H4000& Or &H80000000
    Else
      ShiftLeft = (Value And &H1FFFF) * &H4000&
    End If
  Case 15&
    If Value And &H10000 Then
      ShiftLeft = (Value And &HFFFF&) * &H8000& Or &H80000000
    Else
      ShiftLeft = (Value And &HFFFF&) * &H8000&
    End If
  Case 16&
    If Value And &H8000& Then
      ShiftLeft = (Value And &H7FFF&) * &H10000 Or &H80000000
    Else
      ShiftLeft = (Value And &H7FFF&) * &H10000
    End If
  Case 17&
    If Value And &H4000& Then
      ShiftLeft = (Value And &H3FFF&) * &H20000 Or &H80000000
    Else
      ShiftLeft = (Value And &H3FFF&) * &H20000
    End If
  Case 18&
    If Value And &H2000& Then
      ShiftLeft = (Value And &H1FFF&) * &H40000 Or &H80000000
    Else
      ShiftLeft = (Value And &H1FFF&) * &H40000
    End If
  Case 19&
    If Value And &H1000& Then
      ShiftLeft = (Value And &HFFF&) * &H80000 Or &H80000000
    Else
      ShiftLeft = (Value And &HFFF&) * &H80000
    End If
  Case 20&
    If Value And &H800& Then
      ShiftLeft = (Value And &H7FF&) * &H100000 Or &H80000000
    Else
      ShiftLeft = (Value And &H7FF&) * &H100000
    End If
  Case 21&
    If Value And &H400& Then
      ShiftLeft = (Value And &H3FF&) * &H200000 Or &H80000000
    Else
      ShiftLeft = (Value And &H3FF&) * &H200000
    End If
  Case 22&
    If Value And &H200& Then
      ShiftLeft = (Value And &H1FF&) * &H400000 Or &H80000000
    Else
      ShiftLeft = (Value And &H1FF&) * &H400000
    End If
  Case 23&
    If Value And &H100& Then
      ShiftLeft = (Value And &HFF&) * &H800000 Or &H80000000
    Else
      ShiftLeft = (Value And &HFF&) * &H800000
    End If
  Case 24&
    If Value And &H80& Then
      ShiftLeft = (Value And &H7F&) * &H1000000 Or &H80000000
    Else
      ShiftLeft = (Value And &H7F&) * &H1000000
    End If
  Case 25&
    If Value And &H40& Then
      ShiftLeft = (Value And &H3F&) * &H2000000 Or &H80000000
    Else
      ShiftLeft = (Value And &H3F&) * &H2000000
    End If
  Case 26&
    If Value And &H20& Then
      ShiftLeft = (Value And &H1F&) * &H4000000 Or &H80000000
    Else
      ShiftLeft = (Value And &H1F&) * &H4000000
    End If
  Case 27&
    If Value And &H10& Then
      ShiftLeft = (Value And &HF&) * &H8000000 Or &H80000000
    Else
      ShiftLeft = (Value And &HF&) * &H8000000
    End If
  Case 28&
    If Value And &H8& Then
      ShiftLeft = (Value And &H7&) * &H10000000 Or &H80000000
    Else
      ShiftLeft = (Value And &H7&) * &H10000000
    End If
  Case 29&
    If Value And &H4& Then
      ShiftLeft = (Value And &H3&) * &H20000000 Or &H80000000
    Else
      ShiftLeft = (Value And &H3&) * &H20000000
    End If
  Case 30&
    If Value And &H2& Then
      ShiftLeft = (Value And &H1&) * &H40000000 Or &H80000000
    Else
      ShiftLeft = (Value And &H1&) * &H40000000
    End If
  Case 31&
    If Value And &H1& Then
      ShiftLeft = &H80000000
    Else
      ShiftLeft = &H0&
    End If
  End Select
End Function

Private Function ShiftRightZ(ByVal Value As Long, ByVal ShiftCount As Long) As Long
  ' by Jost Schwider, jost@schwider.de, 20011001
  If Value And &H80000000 Then
    Select Case ShiftCount
    Case 0&:  ShiftRightZ = Value
    Case 1&:  ShiftRightZ = &H40000000 Or (Value And &H7FFFFFFF) \ &H2&
    Case 2&:  ShiftRightZ = &H20000000 Or (Value And &H7FFFFFFF) \ &H4&
    Case 3&:  ShiftRightZ = &H10000000 Or (Value And &H7FFFFFFF) \ &H8&
    Case 4&:  ShiftRightZ = &H8000000 Or (Value And &H7FFFFFFF) \ &H10&
    Case 5&:  ShiftRightZ = &H4000000 Or (Value And &H7FFFFFFF) \ &H20&
    Case 6&:  ShiftRightZ = &H2000000 Or (Value And &H7FFFFFFF) \ &H40&
    Case 7&:  ShiftRightZ = &H1000000 Or (Value And &H7FFFFFFF) \ &H80&
    Case 8&:  ShiftRightZ = &H800000 Or (Value And &H7FFFFFFF) \ &H100&
    Case 9&:  ShiftRightZ = &H400000 Or (Value And &H7FFFFFFF) \ &H200&
    Case 10&: ShiftRightZ = &H200000 Or (Value And &H7FFFFFFF) \ &H400&
    Case 11&: ShiftRightZ = &H100000 Or (Value And &H7FFFFFFF) \ &H800&
    Case 12&: ShiftRightZ = &H80000 Or (Value And &H7FFFFFFF) \ &H1000&
    Case 13&: ShiftRightZ = &H40000 Or (Value And &H7FFFFFFF) \ &H2000&
    Case 14&: ShiftRightZ = &H20000 Or (Value And &H7FFFFFFF) \ &H4000&
    Case 15&: ShiftRightZ = &H10000 Or (Value And &H7FFFFFFF) \ &H8000&
    Case 16&: ShiftRightZ = &H8000& Or (Value And &H7FFFFFFF) \ &H10000
    Case 17&: ShiftRightZ = &H4000& Or (Value And &H7FFFFFFF) \ &H20000
    Case 18&: ShiftRightZ = &H2000& Or (Value And &H7FFFFFFF) \ &H40000
    Case 19&: ShiftRightZ = &H1000& Or (Value And &H7FFFFFFF) \ &H80000
    Case 20&: ShiftRightZ = &H800& Or (Value And &H7FFFFFFF) \ &H100000
    Case 21&: ShiftRightZ = &H400& Or (Value And &H7FFFFFFF) \ &H200000
    Case 22&: ShiftRightZ = &H200& Or (Value And &H7FFFFFFF) \ &H400000
    Case 23&: ShiftRightZ = &H100& Or (Value And &H7FFFFFFF) \ &H800000
    Case 24&: ShiftRightZ = &H80& Or (Value And &H7FFFFFFF) \ &H1000000
    Case 25&: ShiftRightZ = &H40& Or (Value And &H7FFFFFFF) \ &H2000000
    Case 26&: ShiftRightZ = &H20& Or (Value And &H7FFFFFFF) \ &H4000000
    Case 27&: ShiftRightZ = &H10& Or (Value And &H7FFFFFFF) \ &H8000000
    Case 28&: ShiftRightZ = &H8& Or (Value And &H7FFFFFFF) \ &H10000000
    Case 29&: ShiftRightZ = &H4& Or (Value And &H7FFFFFFF) \ &H20000000
    Case 30&: ShiftRightZ = &H2& Or (Value And &H7FFFFFFF) \ &H40000000
    Case 31&: ShiftRightZ = &H1&
    End Select
  Else
    Select Case ShiftCount
    Case 0&:  ShiftRightZ = Value
    Case 1&:  ShiftRightZ = Value \ &H2&
    Case 2&:  ShiftRightZ = Value \ &H4&
    Case 3&:  ShiftRightZ = Value \ &H8&
    Case 4&:  ShiftRightZ = Value \ &H10&
    Case 5&:  ShiftRightZ = Value \ &H20&
    Case 6&:  ShiftRightZ = Value \ &H40&
    Case 7&:  ShiftRightZ = Value \ &H80&
    Case 8&:  ShiftRightZ = Value \ &H100&
    Case 9&:  ShiftRightZ = Value \ &H200&
    Case 10&: ShiftRightZ = Value \ &H400&
    Case 11&: ShiftRightZ = Value \ &H800&
    Case 12&: ShiftRightZ = Value \ &H1000&
    Case 13&: ShiftRightZ = Value \ &H2000&
    Case 14&: ShiftRightZ = Value \ &H4000&
    Case 15&: ShiftRightZ = Value \ &H8000&
    Case 16&: ShiftRightZ = Value \ &H10000
    Case 17&: ShiftRightZ = Value \ &H20000
    Case 18&: ShiftRightZ = Value \ &H40000
    Case 19&: ShiftRightZ = Value \ &H80000
    Case 20&: ShiftRightZ = Value \ &H100000
    Case 21&: ShiftRightZ = Value \ &H200000
    Case 22&: ShiftRightZ = Value \ &H400000
    Case 23&: ShiftRightZ = Value \ &H800000
    Case 24&: ShiftRightZ = Value \ &H1000000
    Case 25&: ShiftRightZ = Value \ &H2000000
    Case 26&: ShiftRightZ = Value \ &H4000000
    Case 27&: ShiftRightZ = Value \ &H8000000
    Case 28&: ShiftRightZ = Value \ &H10000000
    Case 29&: ShiftRightZ = Value \ &H20000000
    Case 30&: ShiftRightZ = Value \ &H40000000
    Case 31&: ShiftRightZ = &H0&
    End Select
  End If
End Function

Password Protection

$
0
0
Protecting passwords is not a simple task. For material that is not highly sensitive, it is enough just to make it difficult for the hacker. That involves using passwords at least 8 characters in length and using a variety of characters (upper, lower, and special characters). The more characters used, the more difficult it is to guess. I have operated a fake mail server for many years, and I still get more than 200 attempts a day to guess the UserId/passwords, even though there are no actual accounts.

Using encryption helps with more sensitive material, but it does nothing to stop password guessing. Even temporarily suspending an account if too many attempts are made does not prevent password guessing. The hacker simply spreads out those guesses over time.

Any time a key or password is stored on a system, it is vulnerable no matter what extremes are used to try and protect it. Forward secrecy helps protect against key theft because the keys are not stored, and passwords should always be stored encrypted or hashed.

Then there is the problem of man-in-the-middle. Even with encryption, it does not take a lot of computer power to figure out the key used to encrypt short passwords. The best defense against that is to use Forward Secrecy, so that even if the hacker is able to figure it out for one session, the key is different for the next session. Even better yet would be to use a different password for every connection, encrypted or not. That is what I have attempted to do in this post.

The principle used in this program is to shuffle the password on each and every connection. To enable authentication of the password, one end must be able to un-shuffle the password, and this is accomplished by using a Seed. In this case, the Seed is calculated from the previous password. This is similar to the way the Visual Basic Rnd function works. Even though it is not truly random, the hacker does not know where in the cycle the client and server are at. Even if the hacker is able to determine the current password and establish a connection, the real client will be alerted on the next connection attempt, and take corrective action. This is the same principle used in Forward Secrecy, except that in this case the user is notified of the intrusion.

To demonstrate this technique, I am using the PicServer program previously posted, along with 2 special Web pages and a JavaScript file. In this case, I have chosen to manually enter the UserID into the database in order to control who can access the files. The user can then add the password. I needed a unique value in the browser, so I added a Time/Date stamp to the browser Local Storage at the same time as the UserID cookie is created. The password that the user enters is then used to calculate the Seed to shuffle the Time/Date stamp, thus forming the originating Password. The originating Password is then sent to the server, and the password cookie in the browser is updated. When the browser attempts a new connection, the UserID and Password cookies are sent to the server in the Get request. The server un-shuffles the Password cookie using the stored Password as the Seed, and compares it to the Password in it's database. If successful, the stored Password as well as the browser Password cookie are updated. The effect is that the stored Password in the server is always one step behind the browser Password cookie.

Using this technique, the user only has to login once. Thereafter, the authorization is automatic on every connection. I am using HTTP 1.1, which allows a connection to be maintained as long as there is traffic. That timeout varies with the browser, and I have yet to establish a timeout for the server. To reset the password, one only has to delete the Password cookie. This feature is currently a security risk. What is to prevent the hacker from learning the UserID and resetting the password? I am open to suggestions.

To prevent the user from directly accessing the JavaScript files, they have been hidden. To further restrict access, those files may have to be moved to a hidden directory.

If you think about it, this technique permits access from a specific browser. If you use a different browser or a different computer, it will require a different UserID.

This program should be considered a work in progress, and eventually will be converted to run as a service. It has only been tested it on 2 different FireFox browsers I have at my disposal. Constructive feedback is welcome.

Currently, access information (including the IP address) is displayed in the text box. and will be re-routed to a log file when it becomes a service. Setup instructions can be found in the Readme file.

J.A. Coutts
Attached Files

(VB6) Get the main or prevalent color tone of a picture

$
0
0
Some applications set a background color (or even other "theme" colors) based on an image that the user selects.

That's the idea, to get the main color tone of an image.

Name:  Get-Image-Main-Tone-scr1.jpg
Views: 88
Size:  21.6 KB

Name:  Get-Image-Main-Tone-scr2.jpg
Views: 90
Size:  58.1 KB

Name:  Get-Image-Main-Tone-scr3.jpg
Views: 91
Size:  53.7 KB


Download from GitHub.
Attached Images
   

Transmit Executables

$
0
0
I discovered a way to get around the problem of web bowsers (eg. Google Chrome) and mail servers (eg. Gmail) blocking executable files without any notification or bypass method. The servers do not identify potential malware based upon the file extension, but rather on the file format itself. So the logical solution is to change the format.

This program has the added advantage of encrypting the file using the outdated RC4 encryption technique. Speed and ease of use are among RC4's major benefits. But RC4 can be hacked, especially if you use the same key repeatedly. Also, RC4 isn't ideal if you have small bits of data to send.

To combat these issues, the key is different with each file and is shuffled. To identify and separate the original and encrypted files, the encrypted file has an extra ".edf" (Encrypted Data File) extension added to the file name.

The RC4 code that I found was for VBA and included an extra loop routine to advance the byte table. I really don't know if that makes the results more secure or not, but for now I have commented it out.

J.A. Coutts
Code:

Option Explicit

Dim AllBytes(255) As Byte
Private ByteBuffer() As Byte
Private eBuffer() As Byte

Private Declare Function WideCharToMultiByte Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, ByVal lpMultiByteStr As Long, ByVal cbMultiByte As Long, ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long
Private Declare Function MultiByteToWideChar Lib "kernel32" (ByVal CodePage As Long, ByVal dwFlags As Long, ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long

Private Sub cmdDecrypt_Click()
    Dim FileName As String
    With Dialog1
        .DialogTitle = "Select a File"
        .InitDir = App.Path '"C:\"
        .Filter = "All Files|*.*"
        .ShowOpen
        FileName = .FileName
    End With
    Me.Caption = FileName
    If Len(FileName) = 0 Then
        MsgBox "Nothing Selected!", vbExclamation
        Exit Sub
    End If
    GetFile (FileName)
    'DebugPrintByte FileName, ByteBuffer
    If Right$(FileName, 4) = ".edf" Then
        FileName = Left$(FileName, Len(FileName) - 4)
    Else
        MsgBox "Improper file name!", vbExclamation
        Exit Sub
    End If
    eBuffer = RunRC4(ByteBuffer, FileName)
    'DebugPrintByte "RC4 Decrypted", eBuffer
    Erase ByteBuffer
    PutFile (FileName)
End Sub

Private Sub cmdEncrypt_Click()
    Dim FileName As String
    With Dialog1
        .DialogTitle = "Select a File"
        .InitDir = App.Path '"C:\"
        .Filter = "All Files|*.*"
        .ShowOpen
        FileName = .FileName
    End With
    Me.Caption = FileName
    If Len(FileName) = 0 Then
        MsgBox "Nothing Selected!", vbExclamation
        Exit Sub
    End If
    GetFile (FileName)
    'DebugPrintByte FileName, ByteBuffer
    eBuffer = RunRC4(ByteBuffer, FileName)
    'DebugPrintByte "RC4 Encrypted", eBuffer
    Erase ByteBuffer
    FileName = FileName & ".edf"
    PutFile (FileName)
End Sub

Private Sub Form_Load()
    Dim lPtr As Long
    For lPtr = 0 To 255
        AllBytes(lPtr) = lPtr
    Next
End Sub

Private Function RunRC4(bText() As Byte, sKey As String) As Byte()
    Dim S()        As Byte
    Dim NewKey      As String
    Dim bKey()      As Byte
    Dim kLen        As Long
    Dim bTmp        As Byte
    Dim I          As Long
    Dim J          As Long
    Dim lPtr        As Long
    Dim sLen As Long
    Dim bResult()  As Byte
    S = AllBytes
    NewKey = Mid$(sKey, InStrRev(sKey, "\") + 1)
    bKey = StrToUtf8(Shuffle(NewKey, False))
    kLen = GetbSize(bKey)
    For I = 0 To 255
        J = (J + S(I) + bKey(I Mod kLen)) Mod 256
        bTmp = S(I)
        S(I) = S(J)
        S(J) = bTmp
    Next I
    I = 0
    J = 0
    'DebugPrintByte "Initial", S
    'For lPtr = 0 To 3071
    '    I = (I + 1) Mod 256
    '    J = (J + S(I)) Mod 256
    '    bTmp = S(I)
    '    S(I) = S(J)
    '    S(J) = bTmp
    'Next lPtr
    'DebugPrintByte "Cycled", S
    sLen = GetbSize(bText)
    ReDim bResult(sLen - 1)
    For lPtr = 0 To sLen - 1
        I = (I + 1) Mod 256
        J = (J + S(I)) Mod 256
        bTmp = S(I)
        S(I) = S(J)
        S(J) = bTmp
        bResult(lPtr) = S((CLng(S(I)) + S(J)) Mod 256) Xor bText(lPtr)
    Next lPtr
    RunRC4 = bResult
End Function

Private Function StrToUtf8(strInput As String) As Byte()
    Const CP_UTF8 = 65001
    Dim nBytes As Long
    Dim abBuffer() As Byte
    If Len(strInput) < 1 Then Exit Function
    ' Get length in bytes *including* terminating null
    nBytes = WideCharToMultiByte(CP_UTF8, 0&, ByVal StrPtr(strInput), -1, 0&, 0&, 0&, 0&)
    ' We don't want the terminating null in our byte array, so ask for `nBytes-1` bytes
    ReDim abBuffer(nBytes - 2)  ' NB ReDim with one less byte than you need
    nBytes = WideCharToMultiByte(CP_UTF8, 0&, ByVal StrPtr(strInput), -1, ByVal VarPtr(abBuffer(0)), nBytes - 1, 0&, 0&)
    StrToUtf8 = abBuffer
End Function

Public Function Shuffle(sInput As String, flgRev As Boolean, Optional bHex As Byte) As String
    Dim bTmp As Byte
    Dim bInput() As Byte
    Dim iLen As Integer
    Dim bKey As Byte
    Dim I%, N%
    Dim iStart As Integer
    Dim iEnd As Integer
    Dim iStep As Integer
    bInput = StrToUtf8(sInput)
    If bHex Then
        bKey = bHex
    Else
        For N% = 0 To UBound(bInput) Step 1
            bKey = bKey Xor bInput(N%) + CByte(N%)
        Next N%
        If bKey = 0 Then bKey = 255
    End If
    iLen = GetbSize(bInput)
    If flgRev Then
        iStart = iLen - 1
        iEnd = 0
        iStep = -1
    Else
        iStart = 0
        iEnd = iLen - 1
        iStep = 1
    End If
    For I% = iStart To iEnd Step iStep
        N% = ((bKey Mod (I% + 1)) + I%) Mod iLen
        bTmp = bInput(I%)
        bInput(I%) = bInput(N%)
        bInput(N%) = bTmp
    Next I%
    Shuffle = Utf8ToStr(bInput)
End Function

Private Function Utf8ToStr(abUtf8Array() As Byte) As String
    Const CP_UTF8 = 65001
    Dim nBytes As Long
    Dim nChars As Long
    Dim strOut As String
    ' Catch uninitialized input array
    nBytes = GetbSize(abUtf8Array)
    If nBytes <= 0 Then Exit Function
    ' Get number of characters in output string
    nChars = MultiByteToWideChar(CP_UTF8, 0&, VarPtr(abUtf8Array(0)), nBytes, 0&, 0&)
    ' Dimension output buffer to receive string
    strOut = String(nChars, 0)
    nChars = MultiByteToWideChar(CP_UTF8, 0&, VarPtr(abUtf8Array(0)), nBytes, StrPtr(strOut), nChars)
    Utf8ToStr = Replace(strOut, Chr$(0), "") 'Remove Null terminating characters
End Function

Private Sub DebugPrintByte(sDescr As String, bArray() As Byte)
    Dim lPtr As Long
    On Error GoTo Done
    Debug.Print sDescr & ":"
    For lPtr = 0 To UBound(bArray)
        Debug.Print Right$("0" & Hex$(bArray(lPtr)), 2) & " ";
        If (lPtr + 1) Mod 16 = 0 Then Debug.Print
    Next lPtr
Done:
    Debug.Print
End Sub

Private Sub GetFile(FileName As String)
    Dim iFile As Integer
    iFile = FreeFile()
    Open FileName For Binary Shared As iFile
    ReDim ByteBuffer(LOF(iFile) - 1)
    Get #iFile, , ByteBuffer
    Close #iFile
End Sub

Private Sub PutFile(NewFile As String)
    Dim iFile As Integer
    On Error GoTo PutErr
    iFile = FreeFile()
    Open NewFile For Binary Shared As iFile
    Put #iFile, , eBuffer
    Close #iFile
    Exit Sub
PutErr:
    MsgBox "Error: " & CStr(Err)
End Sub

Private Function GetbSize(bArray() As Byte) As Long
    On Error GoTo GetSizeErr
    GetbSize = UBound(bArray) + 1
    Exit Function
GetSizeErr:
    GetbSize = 0
End Function

Printer Text BackColor

$
0
0
Trying to print a Sudoku X puzzle in VB6. It prints the diagonal boxes in colour but where there is a number in the coloured box the number has a white background. Printer.BackColor doesn't exist. Any ideas?

Modal mode to show forms that allows non-modal forms

$
0
0
This is a simple function that can be used as a replacement to show forms "modally" but still allow to show non-modal forms:

In a module:

Code:

Private Declare Sub Sleep Lib "Kernel32" (ByVal dwMilliseconds As Long)

Public Sub ShowModal(nForm As Form, Optional OwnerForm)
    Dim ColF As Collection
    Dim ColE As Collection
    Dim f As Form
    Dim c As Long
   
    Set ColF = New Collection
    Set ColE = New Collection
    For Each f In Forms
        If Not f Is nForm Then
            ColF.Add f
            ColE.Add f.Enabled
            f.Enabled = False
        End If
    Next
    nForm.Show , IIf(IsMissing(OwnerForm), Screen.ActiveForm, OwnerForm)
    Do While IsFormLoaded(nForm)
        DoEvents
        Sleep 1
    Loop
    For c = 1 To ColF.Count
        ColF(c).Enabled = ColE(c)
    Next
End Sub

Private Function IsFormLoaded(nForm As Form) As Boolean
    Dim f As Form
   
    For Each f In Forms
        If f Is nForm Then
            IsFormLoaded = True
            Exit Function
        End If
    Next
End Function

Usage:

Code:

ShowModal Form2

[VB6] WinXP compatible PBKDF2

$
0
0
This one uses legacy CryptoAPI and requires XP for HMAC support and XP SP3 minimum for the SHA-2 support for the hash function (i.e. SHA256, SHA384 and SHA512) while MD5 and SHA1 are always supported.

Code:

'--- mdPbkdf2.bas
Option Explicit
DefObj A-Z

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

'--- for CryptAcquireContext
Private Const PROV_RSA_AES                  As Long = 24
Private Const CRYPT_VERIFYCONTEXT          As Long = &HF0000000
'--- for CryptCreateHash
Private Const CALG_RC2                      As Long = &H6602&
Private Const CALG_MD5                      As Long = &H8003&
Private Const CALG_HMAC                    As Long = &H8009&
Private Const CALG_SHA1                    As Long = &H8004&
Private Const CALG_SHA_256                  As Long = &H800C&
Private Const CALG_SHA_384                  As Long = &H800D&
Private Const CALG_SHA_512                  As Long = &H800E&
'--- for CryptGet/SetHashParam
Private Const HP_HASHVAL                    As Long = 2
Private Const HP_HMAC_INFO                  As Long = 5
'--- for CryptImportKey
Private Const PLAINTEXTKEYBLOB              As Long = 8
Private Const CUR_BLOB_VERSION              As Long = 2
Private Const CRYPT_IPSEC_HMAC_KEY          As Long = &H100
Private Const LNG_FACILITY_WIN32            As Long = &H80070000

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function htonl Lib "ws2_32" (ByVal hostlong As Long) As Long
'--- advapi32
Private Declare Function CryptAcquireContext Lib "advapi32" Alias "CryptAcquireContextW" (phProv As Long, ByVal pszContainer As Long, ByVal pszProvider As Long, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptReleaseContext Lib "advapi32" (ByVal hProv As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptImportKey Lib "advapi32" (ByVal hProv As Long, pbData As Any, ByVal dwDataLen As Long, ByVal hPubKey As Long, ByVal dwFlags As Long, phKey As Long) As Long
Private Declare Function CryptDestroyKey Lib "advapi32" (ByVal hKey As Long) As Long
Private Declare Function CryptGetHashParam Lib "advapi32" (ByVal hHash As Long, ByVal dwParam As Long, pbData As Any, pdwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptSetHashParam Lib "advapi32" (ByVal hHash As Long, ByVal dwParam As Long, pbData As Any, ByVal dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32" (ByVal hProv As Long, ByVal AlgId As Long, ByVal hKey As Long, ByVal dwFlags As Long, phHash As Long) As Long
Private Declare Function CryptHashData Lib "advapi32" (ByVal hHash As Long, pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32" (ByVal hHash As Long) As Long

Private Type BLOBHEADER
    bType              As Byte
    bVersion            As Byte
    reserved            As Integer
    aiKeyAlg            As Long
    cbKeySize          As Long
    Buffer(0 To 255)    As Byte
End Type
Private Const sizeof_BLOBHEADER As Long = 12

Private Type HMAC_INFO
    HashAlgid          As Long
    pbInnerString      As Long
    cbInnerString      As Long
    pbOuterString      As Long
    cbOuterString      As Long
End Type

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

Public Function DeriveKeyPBKDF2(sAlgId As String, baPass() As Byte, baSalt() As Byte, ByVal lNumIter As Long, baRetVal() As Byte) As Boolean
    Dim lSize          As Long
    Dim lHashAlgId      As Long
    Dim lHashSize      As Long
    Dim hProv          As Long
    Dim uBlob          As BLOBHEADER
    Dim hKey            As Long
    Dim baHmac()        As Byte
    Dim lIdx            As Long
    Dim lRemaining      As Long
    Dim hResult        As Long
    Dim sApiSource      As String
   
    lSize = UBound(baRetVal) + 1
    Select Case UCase$(sAlgId)
    Case "SHA256"
        lHashAlgId = CALG_SHA_256
        lHashSize = 32
    Case "SHA384"
        lHashAlgId = CALG_SHA_384
        lHashSize = 48
    Case "SHA512"
        lHashAlgId = CALG_SHA_512
        lHashSize = 64
    Case "MD5"
        lHashAlgId = CALG_MD5
        lHashSize = 16
    Case Else
        lHashAlgId = CALG_SHA1
        lHashSize = 20
    End Select
    If CryptAcquireContext(hProv, 0, 0, PROV_RSA_AES, CRYPT_VERIFYCONTEXT) = 0 Then
        hResult = Err.LastDllError
        sApiSource = "CryptAcquireContext"
        GoTo QH
    End If
    uBlob.bType = PLAINTEXTKEYBLOB
    uBlob.bVersion = CUR_BLOB_VERSION
    uBlob.aiKeyAlg = CALG_RC2
    Debug.Assert UBound(uBlob.Buffer) >= UBound(baPass)
    uBlob.cbKeySize = UBound(baPass) + 1
    Call CopyMemory(uBlob.Buffer(0), baPass(0), uBlob.cbKeySize)
    If CryptImportKey(hProv, uBlob, sizeof_BLOBHEADER + uBlob.cbKeySize, 0, CRYPT_IPSEC_HMAC_KEY, hKey) = 0 Then
        hResult = Err.LastDllError
        sApiSource = "CryptImportKey"
        GoTo QH
    End If
    ReDim baHmac(0 To lHashSize - 1) As Byte
    For lIdx = 0 To (lSize + lHashSize - 1) \ lHashSize - 1
        If Not pvCryptoDeriveKeyHmacPrf(hProv, hKey, lHashAlgId, baSalt, htonl(lIdx + 1), lNumIter, baHmac) Then
            GoTo QH
        End If
        lRemaining = lSize - lIdx * lHashSize
        If lRemaining > lHashSize Then
            lRemaining = lHashSize
        End If
        Call CopyMemory(baRetVal(lIdx * lHashSize), baHmac(0), lRemaining)
    Next
    '--- success
    DeriveKeyPBKDF2 = True
QH:
    If hKey <> 0 Then
        Call CryptDestroyKey(hKey)
    End If
    If hProv <> 0 Then
        Call CryptReleaseContext(hProv, 0)
    End If
    If LenB(sApiSource) <> 0 Then
        Err.Raise IIf(hResult < 0, hResult, hResult Or LNG_FACILITY_WIN32), sApiSource
    End If
End Function

Private Function pvCryptoDeriveKeyHmacPrf(ByVal hProv As Long, ByVal hKey As Long, ByVal lHashAlgId As Long, _
            baSalt() As Byte, ByVal lCounter As Long, ByVal lNumIter As Long, baRetVal() As Byte) As Boolean
    Dim hHash          As Long
    Dim uInfo          As HMAC_INFO
    Dim baTemp()        As Byte
    Dim lIdx            As Long
    Dim lJdx            As Long
    Dim hResult        As Long
    Dim sApiSource      As String
   
    uInfo.HashAlgid = lHashAlgId
    baTemp = baRetVal
    For lIdx = 0 To lNumIter - 1
        If CryptCreateHash(hProv, CALG_HMAC, hKey, 0, hHash) = 0 Then
            hResult = Err.LastDllError
            sApiSource = "CryptCreateHash(CALG_HMAC)"
            GoTo QH
        End If
        If CryptSetHashParam(hHash, HP_HMAC_INFO, uInfo, 0) = 0 Then
            hResult = Err.LastDllError
            sApiSource = "CryptSetHashParam(HP_HMAC_INFO)"
            GoTo QH
        End If
        If lIdx = 0 Then
            If UBound(baSalt) >= 0 Then
                If CryptHashData(hHash, baSalt(0), UBound(baSalt) + 1, 0) = 0 Then
                    hResult = Err.LastDllError
                    sApiSource = "CryptHashData(baSalt)"
                    GoTo QH
                End If
            End If
            If CryptHashData(hHash, lCounter, 4, 0) = 0 Then
                hResult = Err.LastDllError
                sApiSource = "CryptHashData(lCounter)"
                GoTo QH
            End If
        Else
            If CryptHashData(hHash, baTemp(0), UBound(baTemp) + 1, 0) = 0 Then
                hResult = Err.LastDllError
                sApiSource = "CryptHashData(baTemp)"
                GoTo QH
            End If
        End If
        If CryptGetHashParam(hHash, HP_HASHVAL, baTemp(0), UBound(baTemp) + 1, 0) = 0 Then
            hResult = Err.LastDllError
            sApiSource = "CryptGetHashParam(HP_HASHVAL)"
            GoTo QH
        End If
        If hHash <> 0 Then
            Call CryptDestroyHash(hHash)
            hHash = 0
        End If
        If lIdx = 0 Then
            baRetVal = baTemp
        Else
            For lJdx = 0 To UBound(baTemp)
                baRetVal(lJdx) = baRetVal(lJdx) Xor baTemp(lJdx)
            Next
        End If
    Next
    '--- success
    pvCryptoDeriveKeyHmacPrf = True
QH:
    If hHash <> 0 Then
        Call CryptDestroyHash(hHash)
    End If
    If LenB(sApiSource) <> 0 Then
        Err.Raise IIf(hResult < 0, hResult, hResult Or LNG_FACILITY_WIN32), sApiSource
    End If
End Function

Sample usage:

Code:

Private Sub Form_Load()
    Dim baPass()        As Byte
    Dim baSalt(0 To 7)  As Byte
    Dim baDerivedKey()  As Byte
   
    baPass = StrConv("password123", vbFromUnicode)
    pvGenRandom VarPtr(baSalt(0)), UBound(baSalt) + 1
   
    ReDim baDerivedKey(0 To 63) As Byte
    If DeriveKeyPBKDF2("SHA512", baPass, baSalt, 10000, baDerivedKey) Then
        Text1.SelLength = &H7FFF&
        Text1.SelText = DesignDumpArray(baDerivedKey) & vbCrLf
    End If
End Sub

cheers,
</wqw>
Viewing all 1484 articles
Browse latest View live


<script src="https://jsc.adskeeper.com/r/s/rssing.com.1596347.js" async> </script>