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

VB6 Rendering of Nodes in a Graph (with Hover over Connections)

0
0
This cairo-(vbRichClient5)-dependent Demo will show (as the Title says) - how to efficiently
implement a scenario, where you have to manage "connectable, draggable Boxes"
(as in the Graph in the following screenshot):



There's a green highlighted Connection (with an appropriate ToolTip), which can - (especially
when the Path is complex) - often cause headaches with regards to: "how-to-implement".

With cairo we have two nice calls available, which can help a great deal, when solving
such more challenging "HitTest-problems":

- cCairoContext.InFill(x, y)
- cCairoContext.InStroke(x, y) <-- this one was used in the Demo

So, what one basically has to do to accomplish a complex HitTest is, to simply apply the Path
in question onto a CairoContext with the appropriate coordinates "as when truly rendered".

Even better, such a cairo-context doesn't have to be derived from "something physically"
(as e.g. a larger ImageSurface), a "virtual one" is already sufficient for that task.

For that purpose (when working with the WidgetEngine, as in this Demo) - each cWidgetBase
already offers such a context over W.MeasureContext.

A slight problem I found was, that whilst CC.InFill always worked reliably, CC.InStroke was only
delivering reliable Hits in 80-90% on the length of a complex Path (as e.g. the Beziers I used here,
due to rounding-errors in the cairo-C-Source).

Though I found a patch for that in the cairo-repo and backported that to the version (vb_cairo_sqlite.dll)
which comes with the RichClient - in consequence CC.InStroke will now work equally reliable as CC.InFill.

So the version of the RichClient (including the latest compile of vb_cairo_sqlite.dll) which will work
well with the zipped Demo-Archive below, needs to be at least 5.0.24
- please visit the Download-
page at vbRichClient.com and update your package appropriately before running it.

Here's the Demo-Zip:
WidgetGraphConnections.zip

Have fun...

Olaf
Attached Files

[VB6] List files by level from a folder, in natural sorted order using INamespaceWalk

0
0
cNamespaceWalk


I initially brought this interface to VB6 to spite the people asking how to list files in sorted order, without actually having to sort them as they're added (the spite is that the complexity of using a shell interface from a tlb is higher than simply using Dir() and inserting already sorted). Then I almost didn't release this because while the interface is very simple, there's a large amount of support code. But here it is, using INamespaceWalk in VB6.

The interface is available on XP, but it's in oleexp so it may or may not break the whole TLB.

Project Update
In the original project, the walk could only be cancelled via the progress dialog. The only way besides this to cancel is by returning ERROR_CANCELLED in the EnterFolder event, which VB doesn't allow by default. I've attached another version of the sample project that uses SwapVTable to replace the normal EnterFolder with one that supports returning values. So every time a new folder is entered, you can continue (S_OK), skip that folder (S_FALSE), or stop all together (ERROR_CANCELLED).

What is INamespaceWalk?

INamespaceWalk provides an alternative way to list the files in a given directory. Unlike other methods, unless a no sort flag is specified, results are returned already in the natural sort order that they would appear in Explorer. There's also options for what to do with links. It's faster than FSO, but I'm not sure how it compares to a full API FindFirstFile/FindNextFile search. While it's not in the sample project, turning this into a search is as simple as checking the filename returned in the FoundItem event.

The most unique feature is that it provides a modern styled progress dialog just by specifying a flag.

The attached sample project contains a class module that wraps all the details up, making usage very simple:
Code:

With cNSW
    .Flags = NSWF_DONT_RESOLVE_LINKS Or NSWF_DONT_TRAVERSE_LINKS Or NSWF_SHOW_PROGRESS
    .Levels = CLng(Text2.Text)
    .ReturnInfo = True
    .Root = Text1.Text
    .Walk
End With

Requirements
Requires my Modern Shell Interfaces Type Library, v1.6 or higher.
Attached Files

VB6 - Simple DirectSound interface class to play little sound effects

0
0
Here's yet another class to play little sound effects on VB6 apps.
Note that I'm not a programmer, never studied anything, so it's not very professional, but it's simple and very easy to use.

The code allows to load several little wav files from disk or directly from the resources inside the compiled exe or dll, and play them with a single line of code like this:

Code:

Sounds.PlaySound "Explosion1"
Initialize DirectSound with:
Code:

Sounds.IniciarDS(hWnd)
Credits to CVMichael and his awesome tutorial: http://www.vbforums.com/showthread.p...Sound-Tutorial

Download: Attachment 126011

Look for my TicTacToe post to see it working.

Code:

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsDS"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit

Private Sonidos As New Collection          ' Almacena todos los sonidos
Private DX As New DirectX8              ' Un directx
Private DSEnum As DirectSoundEnum8      ' Lista con los dispositivos de sonido, por eso el tipo DirectSoundEnum8
Private DIS As DirectSound8            ' Una vez que enumero, agarro uno.
Private BuffDesc As DSBUFFERDESC        ' Almacena la descripción para el búfer
Dim DSSecBuffer As DirectSoundSecondaryBuffer8  ' Buffer que almacena los datos de audio

Private Sub Class_Initialize()
    'nada por aquí
End Sub

Private Sub Class_Terminate()
    Set Sonidos = Nothing
    Set DIS = Nothing
    Set DSEnum = Nothing
End Sub

Public Function IniciarDS(hWnd As Long) As Integer

    ' get enumeration object
    Set DSEnum = DX.GetDSEnum
   
    ' select the first sound device, and create the Direct Sound object
    Set DIS = DX.DirectSoundCreate(DSEnum.GetGuid(1))
   
    ' Set the Cooperative Level to normal
    DIS.SetCooperativeLevel hWnd, DSSCL_NORMAL
   
    ' allow frequency changes and volume changes
    BuffDesc.lFlags = DSBCAPS_CTRLVOLUME 'Or DSBCAPS_CTRLFREQUENCY

End Function

Public Sub LoadSoundFromFile(file As String, Optional sSndKey As String)

    Set DSSecBuffer = DIS.CreateSoundBufferFromFile(file, BuffDesc)
   
    If Len(sSndKey) = 0 Then
        Sonidos.Add DSSecBuffer
    Else
        Sonidos.Add DSSecBuffer, sSndKey
    End If

    Set DSSecBuffer = Nothing
   
End Sub
   
Public Sub LoadSoundFromResource(resName As String, Optional sSndKey As String)
    ' Los recursos deben ser del tipo "WAV"
    ' Si no se especifica sSndKey se usa el nombre del recurso como clave
   
    Set DSSecBuffer = DIS.CreateSoundBufferFromResource(vbNullString, resName, BuffDesc)
   
    If Len(sSndKey) = 0 Then
        Sonidos.Add DSSecBuffer, resName
    Else
        Sonidos.Add DSSecBuffer, sSndKey
    End If

    Set DSSecBuffer = Nothing
   
End Sub

Public Sub SetVolume(sSndKey As Variant, vol As Byte)
    ' volume is from 0 to -10,000 (where 0 is the lowdest, and -10,000 is silence)
    ' Pero yo lo uso con un número entre 0 y 255 para que sea más fácil
   
    If vol < 0 Then vol = 0
    If vol > 255 Then vol = 255
    Set DSSecBuffer = Sonidos(sSndKey)
    DSSecBuffer.SetVolume 10000 * (vol / 255 - 1)
    Set DSSecBuffer = Nothing
End Sub

Public Sub PlaySound(sSndKey As Variant)
    Set DSSecBuffer = Sonidos(sSndKey)
    DSSecBuffer.Play DSBPLAY_DEFAULT
    Set DSSecBuffer = Nothing
End Sub

Help me: vbRichClient5->vbWidgets-TreeTest--Tree loading speed

0
0
Name:  TREE.jpg
Views: 66
Size:  27.7 KB

1.Slow loading
2.3000 data takes 5 seconds
3.Hope I can help to optimize the code, improve the speed of data loading
4.Whether JSON can be used to load the data string tree control
5.If there is a need to make the data in the table with the JSON string is loaded into the tree control, how to realize the
''cModel.cls - > This code is running slow

Private Function LoadTreeNode(ParentNode As cCollection, Optional lngParentNodeID As Long = 0, Optional eumTreeDataLoadMode As eumTreeDataLoadMode = LoadOne) 'As cCollection
Dim i As Long
Dim lngChildNodeCount As Long '子节点数量
Dim ChildNode As cCollection '定义子节点
Dim strSQL As String 'SQL语句
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim rst As New ADODB.Recordset ' cRecordset
Dim sRstTemp As New ADODB.Recordset
Dim P As Long

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
If DV.Exists(CStr(lngParentNodeID)) Then Exit Function '如果父节点已经存在,就退出函数
DV.Add CStr(lngParentNodeID), CStr(lngParentNodeID) '否则就新增到容器,以便检查是否重复
strSQL = "SELECT * FROM " & m_strTableName & " WHERE ParentNodeID=" & lngParentNodeID '组织SQL语句
' Set rst = sCnn.OpenRecordset(strSQL, False) '根据父节点ID打开对应的记录集
rst.Open strSQL, cn, 0, 1
If rst.EOF Then Exit Function ''如果打开记录集为空,就退出函数


For i = 1 To rst.RecordCount '遍历所有记录集
If colChildNode.Exists(CStr(rst(0))) Then
lngChildNodeCount = 1 '如果存在子节点(子节点数>0)
'当作节点添加
Set ChildNode = DataSource.TreeNodeAdd(ParentNode, rst("ResTreeID") & "|" & rst("ImageKey") & "|" & rst("Caption") & "|" & lngChildNodeCount & "|" & rst("FontBold") & "|" & rst("ForeColor") & "|" & rst("Enabled") & "|" & rst("Expanded") & "|", New_c.Collection(False, TextCompare, False), True)
If eumTreeDataLoadMode = LoadOne Then '如果加载1层,就啥也不用再干了

ElseIf eumTreeDataLoadMode = LoadTwo Then '如果加载2层
LoadTreeNode ChildNode, rst(0), LoadOne '就再加载1层
ElseIf eumTreeDataLoadMode = LoadAll Then '如果加载全部
LoadTreeNode ChildNode, rst(0), eumTreeDataLoadMode '使用递归加载全部节点
End If
Else '如果不存在子节点(子节点数<=0)
'否则就当作末级节点添加
lngChildNodeCount = 0
ParentNode.Add Empty, rst("ResTreeID") & "|" & rst("ImageKey") & "|" & rst("Caption") & "|" & lngChildNodeCount & "|" & rst("FontBold") & "|" & rst("ForeColor") & "|" & rst("Enabled") & "|" & rst("Expanded") & "|"
End If
lngLoadProgress = lngLoadProgress + 1 '进度计数器+1
If lngLoadProgress Mod 30 = 0 Then Tree.Caption = "正在加载 第 " & lngLoadProgress & " 条"
DoEvents '释放控制权,防止假死
' Debug.Print i & " - " & Time
rst.MoveNext '指针移动到下一条记录
Next
End Function


vbWidgets-TreeTest.zip
Attached Images
 
Attached Files

[VB6] - Class MP3 player from memory.

0
0
Hello everyone.
I've developed a class for asynchronous playback of MP3 files in memory. For example, this can be useful for playing background music from resources, or play from the network avoiding writing in the file. You can play multiple files at once, but some playback settings (volume, pan) for all players will be shared. This class is designed so that correctly handles the situation stop environment by buttons "Stop", "Pause" and exit on the End-statement. There is one restriction on the order of termination of objects. Because all objects use the same shared resource of a window and of a heap, then the destruction of objects must be in the order in which they were created, otherwise inevitable crashes. For one object no restriction. By tags: processed correctly only ID3v1 and ID3v2 tags, other tags are not recognized and the file is not likely to be played.

Methods:
  • Initialize - initialize the player, the first parameter is a pointer to an MP3 file. The second parameter specifies the size of the data. The third parameter specifies whether you want to copy the file into an internal buffer inside the object and play the file from there;
  • Play - starts playing, the parameter "looped" when first playing determines whether the file is played circularly;
  • Pause - pauses playback, playback will start following the current position;
  • StopPlaying - stops playback;
  • SetPositionMs - sets the current playback position (ms);
  • GetPositionMs - returns the current playback position (ms);
  • GetDurationMs - returns the length of the file in milliseconds;
  • GetBitrate - returns the bitrate at the time of playback (kbps);
  • IsPlaying - determines whether a file is played;

Properties:
  • Volume - sets / returns the current playback volume (0 ... 1);
  • Pan - sets / returns the current panorama playback ((left channel) -1 ... 1 (right channel)).
Attached Files

VB6 Databinding with the DataGrid (used as a Read-Only RowPicker)

0
0
Not much to comment, other than what the Title says.

More common in such scenarios are perhaps MS-HFlexGrids,
but those don't support real DataBinding and are slower, because the
Recordset-Data has to be taken over "as a copy" when a HFlex is used.

The VB6-DataGrid on the other hand, is the only "List-Control" we
have in VB6, which is a true "virtual one" (the Data is kept outside the
Control - in an ADO-Recordset - and then only the visible Rows are rendered).

There's a small "Details-Form" which is shown as a ToolWindow (non-modally),
which then follows the currently clicked Record of the DataGrid in the other Form,
"automagically" due to Binding to the same Recordset (over the Text-Detail-Fields
in the other Form).

Thanks to dilettante for his HFlex-based Demo, where I've stolen the Form-Layout for the ToolForm. :)

The one thing one has to keep in mind, when using a VB6-DataGrid in such a "bound mode" is,
that it behaves with much less "quirks", when it's used in "Batch-Mode" - meaning:
- the ADO-Rs has to use a clientside cursor
- and it should be opened with the Flags: adOpenStatic, adLockBatchOptimistic

With that in place, there's not much it complains about.

The other thing not well-known about the DataGrid is perhaps, how to switch it into
true "Read-Only-Mode" (showing full Row-Selections - and never entering its Edit-Cell-Mode):
- set the Grids "AllowUpdates"-Property to False
- lock the Default-SplitView (at Form_Load-Time) with: DataGrid.Splits(0).Locked = True

Then it will look like in the following ScreenShot:



Here's the Demo-Source: DataGridPicker.zip

Have fun.

Olaf
Attached Files

[VB6] Enhanced Tray Message w/ custom ToolTip icon and feedback, w/o ShellNotifyIcon

0
0
IUserNotification2 Interface

IUserNotification provided a very simple way to show a notification in the tray area, but it was very limited in terms of interaction. Vista introduced IUserNotification2 with a progress sink that allows feedback when the balloon is clicked, when the icon is clicked, and when it's right clicked so a context menu can be displayed.

(note that this is for a notification only, this is not suitable for a permanent presence in the tray)

Once the support code is there, usage is very simple, with no subclassing required:

Code:

Dim lFlags As IUN_Flags

Dim pNotice As UserNotification2
Dim pQC As cQueryContinue
Dim pNoticeCB As cUserNotificationCallback

Set pNotice = New UserNotification2
Set pQC = New cQueryContinue
Set pNoticeCB = New cUserNotificationCallback

'some code omitted here, just setting options, see sample project for full code

With pNotice
    .SetBalloonInfo Text1.Text, Text2.Text, lFlags
    .SetIconInfo hIconS, Text4.Text
    If Text3.Text <> "" Then
        .PlaySound Text3.Text
    End If
    .SetBalloonRetry CLng(Text5.Text), CLng(Text6.Text), CLng(Text7.Text)
   
    .Show pQC, 500, pNoticeCB
End With

The sample project also shows how to display a menu when you right click the icon:

Code:

Public Function OnContextMenuVB(ByVal This As IUserNotificationCallback, pt As olelib.POINT) As Long
Form1.List1.AddItem "Context menu"
Dim hMenu As Long
Dim idCmd As Long
hMenu = CreatePopupMenu()
Call AppendMenu(hMenu, 0, 100, "Hide icon")
Call AppendMenu(hMenu, 0, 101, "Leave icon alone")
idCmd = TrackPopupMenu(hMenu, TPM_LEFTBUTTON Or TPM_RIGHTBUTTON Or TPM_LEFTALIGN Or TPM_TOPALIGN Or TPM_HORIZONTAL Or TPM_RETURNCMD, pt.X, pt.Y, 0, Form1.hWnd, 0)

If idCmd = 100 Then OnContextMenuVB = 1

End Function

The only bit of complexity is that if you want to make use of the callback events, in order to set whether the icon stays or not requires swapping v-table entries. This would also be required to use IQueryContinue, but that's not shown since it's redundant.
Theoretically, you could choose to not use either of these options by modifying the typelib to expect a pointer and passing 0, if you want a custom version of oleexp that does that let me know.

IUserNotification2 does NOT inherit from IUserNotification, therefore both can be used simultaneously.

Known Issues
-Sound doesn't seem to work. MSDN says those aliases should be in win.ini and they're not in mine, but I didn't think a Vista+ interface would require something like that to be added.
-You'll need an error handler... if you let it run through all retries, when it times out it throws a 'cancelled by user' automation error that will show unless you don't break on handled errors (and add the handler). This is not due to any code on this end, it's the system implementation that throws the error.

Requirements:
Vista or higher.
oleexp 1.7 or higher (my Modern Interfaces Library expansion of olelib)
Attached Files

[VB6] ProcCounters & ProcMonitor - instrument your application

0
0
An issue many of us deal with is trying different approaches in an application in order to improve performance. Often enough these are big changes, for example ADO Client vs. Server cursor location or using a file vs. keeping everything in memory.

So you don't need a code profiler right off the bat to micro-optimize, instead you need more "global" performance numbers: accumulating counters for the process. There are some API calls to retrieve a number of statistics. Some of the more useful ones measure CPU use, I/O use, and memory use.

ProcCounters is a VB6 class wrapping several of these calls.

ProcMonitor is a VB6 UserControl that displays summary information you can watch while running your program. It samples statistics via ProcCounters and shows them in abbreviated format.


The test program in the attachment just does a bunch of grinding away while it logs ProcCounters results and has a ProcMonitor (blue here) running as well.


Name:  sshot.jpg
Views: 40
Size:  59.4 KB

These require Windows 2000 or later.

Note that ProcMonitor uses SHLWAPI calls to format byte-count values in "base 2" scales, i.e. 1KB = 1024 bytes, etc.
Attached Images
 
Attached Files

[VB6] - Editing AVI-files without recompression.

0
0
Hello everyone.
This is example of work with AVI-files (cut section and save it to a file). Everything is commented:
Code:

Option Explicit
. . .
ДЕКЛАРАЦИИ
. . .
Dim currentFile As String          ' Текущее имя файла
Dim hAvi        As Long            ' Текущий файл
Dim frameCount  As Long            ' Общее количество кадров в файле
Dim frameStart  As Long            ' Первый кадр
Dim vidStream  As Long            ' Видеопоток
Dim IGetFrame  As Long            ' Объект для рендеринга
Dim vidInfo    As AVI_STREAM_INFO  ' Информация о видеопотоке
 
' // Обновить фрейм
Private Sub Update()
    Dim lpDIB  As Long
    Dim bi      As BITMAPINFOHEADER
    Dim x      As Long
    Dim y      As Long
    Dim dx      As Long
    Dim dy      As Long
    Dim aspect  As Single
   
    If IGetFrame = 0 Then Exit Sub
    ' Получаем фрейм
    lpDIB = AVIStreamGetFrame(IGetFrame, sldFrame.Value)
    ' Получаем информацию о растре
    memcpy bi, ByVal lpDIB, Len(bi)
    ' Центруем
    aspect = bi.biHeight / bi.biWidth
   
    If aspect < 1 Then
        x = 0
        dx = picOut.ScaleWidth
        dy = picOut.ScaleWidth * aspect
        y = (picOut.ScaleHeight - dy) / 2
    Else
        y = 0
        dy = picOut.ScaleHeight
        dx = picOut.ScaleHeight / aspect
        x = (picOut.ScaleWidth - dx) / 2
    End If
    ' Выводим
    StretchDIBits picOut.hdc, x, y, dx, dy, 0, 0, bi.biWidth, bi.biHeight, ByVal lpDIB + bi.biSize, ByVal lpDIB, 0, vbSrcCopy
 
    ' Обновляем время
    Dim tim As Date
   
    tim = TimeSerial(0, 0, (sldFrame.Value - frameStart) / (vidInfo.dwRate / vidInfo.dwScale))
   
    lblTime.Caption = tim
   
End Sub
 
' // Функция загружает AVI файл
Private Sub LoadAVI(fileName As String)
    Dim ret    As Long
    ' Очистка
    Clear
    ' Открываем файл
    ret = AVIFileOpen(hAvi, StrPtr(fileName), OF_READWRITE, ByVal 0&)
    If ret Then GoTo ErrHandler
    ' Открываем поток
    ret = AVIFileGetStream(hAvi, vidStream, streamtypeVIDEO, 0)
    If ret Then GoTo ErrHandler
    ' Получаем информацию о потоке
    AVIStreamInfo vidStream, vidInfo, Len(vidInfo)
    ' Узнаем кадры
    frameStart = AVIStreamStart(vidStream)
    frameCount = AVIStreamLength(vidStream)
    If frameStart = -1 Or frameCount = -1 Then ret = 1: GoTo ErrHandler
    ' Получаем IGetFrame объект
    IGetFrame = AVIStreamGetFrameOpen(vidStream, ByVal AVIGETFRAMEF_BESTDISPLAYFMT)
    If IGetFrame = 0 Then GoTo ErrHandler
   
    currentFile = fileName
   
    sldFrame.Min = frameStart
    sldFrame.Max = frameStart + frameCount - 1
    sldFrame.SelStart = sldFrame.Min
    sldFrame.SelLength = frameCount - 1
   
    picOut.Cls
   
    Update
   
    Exit Sub
   
ErrHandler:
    Clear
    currentFile = vbNullString
   
    MsgBox "Error"
   
End Sub
 
' // Очистка
Private Sub Clear()
    If IGetFrame Then AVIStreamGetFrameClose IGetFrame: IGetFrame = 0
    If vidStream Then AVIStreamRelease vidStream: vidStream = 0
    If hAvi Then AVIFileRelease hAvi: hAvi = 0
End Sub
 
' // Сохранить изменения
Private Sub cmdSave_Click()
    Dim hNewFile    As Long
    Dim hNewStream  As Long
    Dim newFileName As String
    Dim ret        As Long
    Dim info        As AVI_STREAM_INFO
    Dim firstFrame  As Long
    Dim lastFrame  As Long
    Dim curFrame    As Long
    Dim nextKeyFr  As Long
    Dim index      As Long
    Dim sampleCount As Long
    Dim dataSize    As Long
    Dim isKeyFrame  As Boolean
    Dim buffer()    As Byte
 
    If hAvi = 0 Then Exit Sub
    ' Мы не можем просто так скопировать стрим с любого места, т.к. данные в стриме
    ' могут быть зависимы и мы можем копировать стрим только если есть опорный кадр
    ' Ищем ближайший опорный кадр
    firstFrame = AVIStreamFindSample(vidStream, sldFrame.SelStart, FIND_KEY Or FIND_NEXT)
    lastFrame = AVIStreamFindSample(vidStream, sldFrame.SelStart + sldFrame.SelLength, FIND_KEY Or FIND_PREV)
    ' Корректируем
    If firstFrame < 0 Then firstFrame = 0
    If lastFrame < 0 Then lastFrame = 0
    ' Получаем параметры текущего видео стрима
    AVIStreamInfo vidStream, info, Len(info)
    ' Корректируем количество кадров исходя из новой длины
    info.dwLength = lastFrame - firstFrame + 1
    ' Имя результирующего файла
    newFileName = left$(currentFile, Len(currentFile) - 4) & "_Edited.avi"
    ' Создаем новый файл
    ret = AVIFileOpen(hNewFile, StrPtr(newFileName), OF_CREATE Or OF_READWRITE, ByVal 0&)
    If ret Then GoTo ErrHandler
    ' Создаем новый видео стрим
    ret = AVIFileCreateStream(hNewFile, hNewStream, info)
    If ret Then GoTo ErrHandler
    ' Копируем формат
    ret = AVIStreamReadFormat(vidStream, 0, ByVal 0, dataSize)
    If ret Then GoTo ErrHandler
    ReDim buffer(dataSize - 1)
    ret = AVIStreamReadFormat(vidStream, 0, buffer(0), dataSize)
    If ret Then GoTo ErrHandler
    ret = AVIStreamSetFormat(hNewStream, 0, buffer(0), dataSize)
    If ret Then GoTo ErrHandler
    ' Проход по кадрам и их копирование в новый файл
    curFrame = firstFrame
    nextKeyFr = curFrame
   
    prgProgress.Visible = True
   
    Do While index < info.dwLength
        ' Читаем данные
        ret = AVIStreamRead(vidStream, index + firstFrame, AVISTREAMREAD_CONVENIENT, ByVal 0&, 0, dataSize, sampleCount)
        If ret Then GoTo ErrHandler
        ReDim Preserve buffer(dataSize - 1)
        ret = AVIStreamRead(vidStream, index + firstFrame, AVISTREAMREAD_CONVENIENT, buffer(0), dataSize, dataSize, sampleCount)
        If ret Then GoTo ErrHandler
        ' Если это опорный кадр, то
        If curFrame = nextKeyFr Then
            isKeyFrame = True
            ' Ищем следующий опорный кадр
            nextKeyFr = AVIStreamFindSample(vidStream, nextKeyFr + 1, FIND_KEY Or FIND_NEXT)
        End If
 
        If dataSize Then
            ' Если текущий - опорный
            If isKeyFrame Then
                ' Записываем опорный
                ret = AVIStreamWrite(hNewStream, index, sampleCount, buffer(0), dataSize, AVIIF_KEYFRAME, sampleCount, dataSize)
                isKeyFrame = False
            Else
                ' Неопорный
                ret = AVIStreamWrite(hNewStream, index, sampleCount, buffer(0), dataSize, 0, sampleCount, dataSize)
            End If
            If ret Then GoTo ErrHandler
           
        End If
        ' Следующий кадр
        curFrame = curFrame + sampleCount
        index = index + sampleCount
        ' Обновляем прогрессбар
        prgProgress.Value = (index / info.dwLength) * 50
    Loop
    ' Освобождаем стрим
    AVIStreamRelease hNewStream:    hNewStream = 0
   
    Dim audStream  As Long
    Dim firstSample As Long
    Dim lastSample  As Long
    Dim timeStart  As Single
    Dim timeEnd    As Single
    Dim curSample  As Long
    Dim nextKeySmp  As Long
    ' Получаем аудио стрим из файла
    ret = AVIFileGetStream(hAvi, audStream, streamtypeAUDIO, 0)
    If ret Then
        ' Аудио стрима нет
        ret = 0
        GoTo ErrHandler
    End If
    ' Узнаем время кадров
    timeStart = firstFrame / (info.dwRate / info.dwScale)
    timeEnd = lastFrame / (info.dwRate / info.dwScale)
    ' Получаем параметры текущего аудио стрима
    AVIStreamInfo audStream, info, Len(info)
    ' Определяем семплы
    firstSample = AVIStreamFindSample(audStream, (info.dwRate / info.dwScale) * timeStart, FIND_KEY Or FIND_NEXT)
    lastSample = AVIStreamFindSample(audStream, (info.dwRate / info.dwScale) * timeEnd, FIND_KEY Or FIND_PREV)
    ' Создаем новый аудио стрим
    ret = AVIFileCreateStream(hNewFile, hNewStream, info)
    If ret Then GoTo ErrHandler
    info.dwLength = lastSample - firstSample
    ' Копируем формат
    ret = AVIStreamReadFormat(audStream, 0, ByVal 0, dataSize)
    If ret Then GoTo ErrHandler
    ReDim buffer(dataSize - 1)
    ret = AVIStreamReadFormat(audStream, 0, buffer(0), dataSize)
    If ret Then GoTo ErrHandler
    ret = AVIStreamSetFormat(hNewStream, 0, buffer(0), dataSize)
    If ret Then GoTo ErrHandler
    ' Проход по семплам и их копирование в новый файл
    curSample = firstSample
    nextKeySmp = curSample
    index = 0
   
    Do While index < info.dwLength
        ' Читаем данные
        ret = AVIStreamRead(audStream, index + firstSample, AVISTREAMREAD_CONVENIENT, ByVal 0&, 0, dataSize, sampleCount)
        If ret Then GoTo ErrHandler
        ReDim Preserve buffer(dataSize - 1)
        ret = AVIStreamRead(audStream, index + firstSample, AVISTREAMREAD_CONVENIENT, buffer(0), dataSize, dataSize, sampleCount)
        If ret Then GoTo ErrHandler
        ' Если это опорный семпл, то
        If curSample = nextKeySmp Then
            isKeyFrame = True
            ' Ищем следующий опорный кадр
            nextKeySmp = AVIStreamFindSample(audStream, nextKeySmp + sampleCount, FIND_KEY Or FIND_NEXT)
        End If
 
        If dataSize Then
            ' Если текущий - опорный
            If isKeyFrame Then
                ' Записываем опорный
                ret = AVIStreamWrite(hNewStream, index, sampleCount, buffer(0), dataSize, AVIIF_KEYFRAME, sampleCount, dataSize)
                isKeyFrame = False
            Else
                ' Неопорный
                ret = AVIStreamWrite(hNewStream, index, sampleCount, buffer(0), dataSize, 0, sampleCount, dataSize)
            End If
            If ret Then GoTo ErrHandler
 
        End If
        ' Следующий семпл (группа семплов)
        curSample = curSample + sampleCount
        index = index + sampleCount
        ' Обновляем прогрессбар
        prgProgress.Value = (index / info.dwLength) * 50 + 50
    Loop
   
    prgProgress.Visible = False
   
ErrHandler:
    ' Освобождаем ресурсы
    If audStream Then AVIStreamRelease audStream
    If hNewStream Then AVIStreamRelease hNewStream
    If hNewFile Then AVIFileRelease hNewFile
   
    If ret Then MsgBox "Error saving"
   
End Sub
 
' // Установить последний кадр
Private Sub cmdSetEnd_Click()
    If sldFrame.Value < sldFrame.SelStart Then Exit Sub
    sldFrame.SelLength = sldFrame.Value - sldFrame.SelStart
End Sub
 
' // Установить начальный кадр
Private Sub cmdSetStart_Click()
    sldFrame.SelStart = sldFrame.Value
End Sub
 
Private Sub Form_Load()
    AVIFileInit
    SetStretchBltMode picOut.hdc, HALFTONE
End Sub
 
Private Sub Form_Unload(Cancel As Integer)
    Clear
    AVIFileExit
End Sub
 
' // Событие бросания файла на бокс
Private Sub picOut_OLEDragDrop(Data As DataObject, _
                              Effect As Long, _
                              Button As Integer, _
                              Shift As Integer, _
                              x As Single, _
                              y As Single)
   
    If IsAviFile(Data) Then
        LoadAVI Data.Files(1)
    End If
   
End Sub
 
' // Проверяем AVI ли файл?
Private Sub picOut_OLEDragOver(Data As DataObject, _
                              Effect As Long, _
                              Button As Integer, _
                              Shift As Integer, _
                              x As Single, _
                              y As Single, _
                              State As Integer)
   
    If IsAviFile(Data) Then Effect = ccOLEDropEffectMove Else Effect = ccOLEDropEffectNone
   
End Sub
 
' // Является ли AVI файлом
Private Function IsAviFile(Data As DataObject) As Boolean
   
    If Data.Files.Count = 1 Then
        Dim fileName As String
       
        fileName = Data.Files(1)
       
        IsAviFile = LCase(right(fileName, 4)) = ".avi"
       
    End If
       
End Function
 
Private Sub picOut_Paint()
    Update
End Sub
 
Private Sub sldFrame_Change()
    Update
End Sub
 
Private Sub sldFrame_Scroll()
    Update
End Sub

The files must drop on window from the explorer, the Start and End button make the selection.
Attached Files

[VB6] - 3D sound using DirectSound.

0
0
Hello everyone.
The example shows an implementation of 3D sound, every object in three-dimensional space "assigned" the sound. To work need a library dx8vb.dll. Shift / Ctrl - deceleration of 10 times, the left button to rotate the camera, right tilt left / right. Spheres - sound sources, each can be turned on / off. Commented only work with sound:
Code:

Option Explicit

Dim dx      As DirectX8                    ' Объект DirectX8
Dim dxs    As DirectSound8                ' Объект DirectSound
Dim dl      As DirectSound3DListener8      ' Слушатель
Dim dp      As DirectSoundPrimaryBuffer8    ' Первичный буфер
Dim ds()    As DirectSoundSecondaryBuffer8  ' Вторичные буфера
Dim db()    As DirectSound3DBuffer8        ' 3D буфера
Dim dev    As Direct3DDevice8              ' Для визуализации ...
Dim d3d    As Direct3D8                    ' ...
Dim d3msh  As D3DXMesh                    ' ...
Dim d3pln  As D3DXMesh                    ' ...

Private Const CountSources = 3      ' Количество источников звука

' // Отключение/включение звука
Private Sub chkSound_Click(Index As Integer)
    ' Если стоит галочка, то
    If chkSound(Index).Value = vbChecked Then
        ' Проигрываем звук с зацикливанием по кругу
        ds(Index).Play DSBPLAY_LOOPING
    Else
        ' Иначе останавливаем
        ds(Index).Stop
    End If
   
End Sub

' // Процедура обрабтки нажатий клавиш
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Dim curPos  As D3DVECTOR    ' Текущая позиция слушателя
    Dim curOrt  As D3DVECTOR    ' Текущий вектор ориентации
    Dim curTop  As D3DVECTOR    ' Текущий вектор "макушки" слушателя
    Dim curLft  As D3DVECTOR    ' Вектор влево относительно ориентации слушателя
   
    ' Получаем позицию слушателя
    dl.GetPosition curPos
    ' Получаем ориентацию и направление вверх
    dl.GetOrientation curOrt, curTop
    ' С помощью векторного произведения находим препендикуляр к этим двум векторам, т.е. вектор влево
    D3DXVec3Cross curLft, curOrt, curTop
   
    ' Если нажата Shift/Ctrl
    If Shift Then
        ' Уменьшаем размер в 10 раз
        D3DXVec3Scale curOrt, curOrt, 0.1  ' вектора ориентации
        D3DXVec3Scale curLft, curLft, 0.1  ' вектора влево
       
    End If
   
    ' Получение кода нажатой клавиши
    Select Case KeyCode
    Case vbKeyW, vbKeyUp
        ' Вперед. Прибавляем к текущим координатам вектор ориентации
        D3DXVec3Add curPos, curPos, curOrt
    Case vbKeyA, vbKeyLeft
        ' Влево. Прибавляем к текущим координатам вектор влево
        D3DXVec3Add curPos, curPos, curLft
    Case vbKeyD, vbKeyRight
        ' Вправо. Вычитаем из текущих координат вектор влево
        D3DXVec3Subtract curPos, curPos, curLft
    Case vbKeyS, vbKeyDown
        ' Назад. Вычитаем из текущих координат ориентацию
        D3DXVec3Subtract curPos, curPos, curOrt
    End Select
   
    ' Устанавливаем измененную позицию
    dl.SetPosition curPos.X, curPos.Y, curPos.z, DS3D_IMMEDIATE
    ' Визуализация
    Render
   
End Sub

' // Процедура загрузки формы
Private Sub Form_Load()
    ' Создаем объект DirectX8
    Set dx = New DirectX8
    ' Создаем объект DirectSound
    Set dxs = dx.DirectSoundCreate(vbNullString)
    ' Настраиваем совместный доступ
    dxs.SetCooperativeLevel Me.hWnd, DSSCL_NORMAL
    ' Описатель буфера
    Dim bd  As DSBUFFERDESC
    ' Это первичный буфер и возможность контролировать положение и ориентацию в пространстве
    bd.lFlags = DSBCAPS_PRIMARYBUFFER Or DSBCAPS_CTRL3D
    ' Создаем первичный буфер
    Set dp = dxs.CreatePrimarySoundBuffer(bd)
    ' Получаем объект слушателя
    Set dl = dp.GetDirectSound3DListener()
    ' Для других буферов возможность контролировать положение и ориентацию в пространстве
    bd.lFlags = DSBCAPS_CTRL3D
    ' Задаем ориентацию вперед
    dl.SetOrientation 0, 0, 1, 0, 1, 0, DS3D_DEFERRED
   
    Dim i  As Long    ' Временная переменная
    Dim fil As Boolean  ' В IDE - загрузка из файла, в EXE из ресурсов
   
    ReDim ds(CountSources - 1)  ' Массив вторичных буферов (источников)
    ReDim db(CountSources - 1)  ' Массив 3D буферов
   
    Randomize
   
    For i = 0 To CountSources - 1
       
        Debug.Assert InIDE(fil)
       
        ' Загружаем из файла или из ресурса в зависимости от режима работы
        If fil Then
            Set ds(i) = dxs.CreateSoundBufferFromFile(Choose(i + 1, "Sound.wav", "Moto.wav", "Police.wav"), bd)
        Else
            Set ds(i) = dxs.CreateSoundBufferFromResource(App.EXEName & ".exe", Choose(i + 1, "#101", "#102", "#103"), bd)
        End If
        ' Получаем объект 3D буфера
        Set db(i) = ds(i).GetDirectSound3DBuffer()
        ' Задаем рандомную позицию
        db(i).SetPosition Rnd * 50 - 25, Rnd * 50, Rnd * 50 - 25, DS3D_DEFERRED
        ' Включаем воспроизведение
        ds(i).Play DSBPLAY_LOOPING
       
    Next
    ' Запуск просчета изменений
    dl.CommitDeferredSettings
   
    ' Для визуализации (не комментирую)
    ' //----//----//----//----//----//
    Dim pp  As D3DPRESENT_PARAMETERS
    Dim dm  As D3DDISPLAYMODE
   
    Set d3d = dx.Direct3DCreate()
   
    d3d.GetAdapterDisplayMode D3DADAPTER_DEFAULT, dm
   
    pp.BackBufferFormat = dm.Format
    pp.Windowed = 1
    pp.SwapEffect = D3DSWAPEFFECT_DISCARD
    pp.EnableAutoDepthStencil = 1
    pp.AutoDepthStencilFormat = D3DFMT_D16
   
    Set dev = d3d.CreateDevice(D3DADAPTER_DEFAULT, D3DDEVTYPE_HAL, pic.hWnd, D3DCREATE_HARDWARE_VERTEXPROCESSING, pp)
   
    Dim mtx As D3DMATRIX
   
    D3DXMatrixPerspectiveFovLH mtx, 3.14 / 180 * 80, pic.ScaleHeight / pic.ScaleWidth, 0.1, 200
    dev.SetTransform D3DTS_PROJECTION, mtx
   
    dev.SetRenderState D3DRS_ZENABLE, D3DZB_TRUE
    dev.SetRenderState D3DRS_LIGHTING, 1
   
    Dim d3      As D3DX8
    Dim dat()  As Byte
   
    Set d3 = New D3DX8
    Set d3msh = d3.CreateSphere(dev, 1, 16, 8, Nothing)
    Set d3pln = d3.CreatePolygon(dev, 100, 4, Nothing)
   
    Dim lth As D3DLIGHT8
    Dim mat As D3DMATERIAL8
   
    lth.Type = D3DLIGHT_POINT
    lth.diffuse = col(1, 1, 1)
    lth.Position = vec3(0, 100, -100)
    lth.Attenuation1 = 0.01
    lth.Range = 400
   
    dev.SetLight 0, lth
    dev.LightEnable 0, 1
   
    mat.diffuse = col(1, 1, 1)
    dev.SetMaterial mat
    ' //----//----//----//----//----//
   
End Sub

' // Визуализация
Private Sub Render()
    Dim idx As Long
    Dim v1  As D3DVECTOR
    Dim v2  As D3DVECTOR
    Dim v3  As D3DVECTOR
    Dim mtx As D3DMATRIX
   
    dev.Clear 0, ByVal 0, D3DCLEAR_ZBUFFER Or D3DCLEAR_TARGET, &HAFFFFF, 1, 0

    dev.BeginScene

    dev.SetVertexShader d3msh.GetFVF
   
    dl.GetPosition v1:      dl.GetOrientation v2, v3
    D3DXVec3Add v2, v1, v2
    D3DXMatrixLookAtLH mtx, v1, v2, v3
    dev.SetTransform D3DTS_VIEW, mtx
   
    D3DXMatrixTranslation mtx, 0, -3, 0
    dev.SetTransform D3DTS_WORLD, mtx
    D3DXMatrixRotationX mtx, -3.14 / 2
    dev.MultiplyTransform D3DTS_WORLD, mtx
   
    d3pln.DrawSubset 0
   
    For idx = 0 To CountSources - 1
       
        db(idx).GetPosition v1
        D3DXMatrixTranslation mtx, v1.X, v1.Y, v1.z
        dev.SetTransform D3DTS_WORLD, mtx
        d3msh.DrawSubset 0
       
    Next
   
    dev.EndScene
   
    dev.Present ByVal 0, ByVal 0, 0, ByVal 0
   
End Sub

' // Функция сздания векторов
Private Function vec3(ByVal X As Single, ByVal Y As Single, ByVal z As Single) As D3DVECTOR
    vec3.X = X: vec3.Y = Y: vec3.z = z
End Function

' // Функция создания цветов
Private Function col(r As Single, g As Single, b As Single) As D3DCOLORVALUE
    col.r = r
    col.g = g
    col.b = b
    col.a = 1
End Function

' // Процедура выгрузки формы
Private Sub Form_Unload(Cancel As Integer)
    Dim i  As Long
    ' Проход по всем буферам
    For i = 0 To CountSources - 1
        ' Остановка
        ds(i).Stop
        ' Удаление и очистка
        Set ds(i) = Nothing
        Set db(i) = Nothing
       
    Next
   
    Set dl = Nothing
    Set dp = Nothing
   
    Set dxs = Nothing
    Set dx = Nothing
   
End Sub

' // Процедура обработки мыши
Private Sub pic_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Static ox  As Single, oy As Single
    Dim mtx As D3DMATRIX
    Dim qt1 As D3DQUATERNION
    Dim qt2 As D3DQUATERNION
    Dim v1  As D3DVECTOR
    Dim v2  As D3DVECTOR
    Dim v3  As D3DVECTOR

    ' При движении с зажатой левой кнопкой изменяем ориентацию
    If Button = vbLeftButton Then
           
        dl.GetOrientation v1, v2
        D3DXVec3Cross v3, v1, v2
       
        D3DXQuaternionRotationAxis qt1, v2, (X - ox) / 50
        D3DXQuaternionRotationAxis qt2, v3, -(Y - oy) / 50
        D3DXQuaternionMultiply qt1, qt1, qt2
        D3DXMatrixRotationQuaternion mtx, qt1
       
        D3DXVec3TransformCoord v1, v1, mtx
        D3DXVec3TransformCoord v2, v2, mtx
        dl.SetOrientation v1.X, v1.Y, v1.z, v2.X, v2.Y, v2.z, DS3D_IMMEDIATE
       
        Render
    ' При правой кнопке - наклон (направление вверх)
    ElseIf Button = vbRightButton Then
   
        dl.GetOrientation v1, v2
       
        D3DXQuaternionRotationAxis qt1, v1, (X - ox) / 50
        D3DXMatrixRotationQuaternion mtx, qt1
       
        D3DXVec3TransformCoord v1, v1, mtx
        D3DXVec3TransformCoord v2, v2, mtx
        dl.SetOrientation v1.X, v1.Y, v1.z, v2.X, v2.Y, v2.z, DS3D_IMMEDIATE
       
        Render
       
    End If
   
    ox = X: oy = Y
   
End Sub

Private Sub pic_Paint()
    Render
End Sub

Private Function InIDE(z As Boolean) As Boolean
    z = True: InIDE = z
End Function

Download source code.

VB6 - Add to Hash using CNG

0
0
There are times when one needs to add to an existing hash, such as when calculating the HMAC hashes for TLS. With CAPI, the hash function could be easily split into separate functions; create the hash, add to the hash, and finish the hash. All you had to do was save the Hash Handle. Using CNG, it is a little more involved.

CNG uses objects extensively, and although the Hash Handle is the only element required for the BCryptFinishHash function, it is useless without the Hash Object. In the attached test program, the Hash Handle, the Hash Length, and the Hash Object are saved by the calling function. In reality, the Hash Object is the only thing that needs to be preserved, because the other two values are both contained within:
Code:

Hash Object:
14 00 00 00 53 55 55 55 F0 D7 20 00 24 9D 52 04
00 00 00 00 70 00 00 00 48 48 53 4D 02 00 02 00
14 00 00 00 00 00 00 00 54 65 73 74 20 73 74 72
69 6E 67 20 74 6F 20 48 61 73 68 2E 00 00 00 00
00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
00 00 00 00 00 00 00 00 01 23 45 67 89 AB CD EF
FE DC BA 98 76 54 32 10 F0 E1 D2 C3 00 00 00 00
14 00 00 00 00 00 00 00 00 00

The Hash Length is in byte(0), and the Hash Handle starts at byte(12).

J.A. Coutts
Attached Files

[VB6] - Fireworks.

0
0

Code:

Option Explicit

Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundW" (ByVal lpszName As Long, ByVal hModule As Long, ByVal dwFlags As Long) As Long

Private Const SND_ASYNC = &H1
Private Const pi = 3.14

Private Function Draw(v As Long, cc As Long) As Boolean
    Dim dh As Single, c As Single, d As Single, x As Single, y As Single, w As Long, i As Long, dx As Single, dy As Single, _
        gr As Single, r As Single, g As Single, b As Single, n As String
    Rnd v: cc = cc + 2
    If cc <= 0 Then
        Exit Function
    ElseIf cc <= 100 Then
        If cc = 2 Then n = App.Path & "\1.wav": PlaySound StrPtr(n), 0, SND_ASYNC
        dh = 100 / cc: x = Rnd * 0.75 + 0.125 + (cc * ((v And 2) - 1)) / 1000: y = Sin((cc - 2) / 200 * pi) * 0.75
        w = 21 - cc * 0.2: d = 255 / w: c = 0
        Do: c = 255 / w: DrawWidth = w: PSet (x, y), RGB(c, c, 0): w = w - 1: Loop While w
    ElseIf cc < 300 Then
        If cc = 102 Then n = App.Path & "\0.wav": PlaySound StrPtr(n), 0, SND_ASYNC
        dh = (cc - 100) / 200: gr = (1 - Cos(dh * pi * 0.25)) * dh: dx = Rnd * 0.75 + 0.125 + ((v And 2) - 1) / 10
        dy = 0.75 - gr: i = Rnd * 100 + 200: gr = 1 - 0.2 ^ (dh * 5): dh = 1 - dh
        r = Rnd * 0.8 + 0.2: g = Rnd * 0.8 + 0.2: b = Rnd * 0.8 + 0.2
        If cc < 150 Then
            b = (1 - (cc - 100) / 50) * 3
            For w = (cc - 100) * 2 To 1 Step -1
                DrawWidth = w * 5: c = cc / w * b: PSet (dx, dy), RGB(c * r, c * g, c * b)
            Next
        End If
        Do While i
            c = Rnd * pi * 2: d = gr * (Rnd * 0.8 + 0.2) * 0.5: x = Cos(c) * d + dx: y = Sin(c) * d + dy
            w = (dh * 6) * Abs(Sin((cc + i) / 10 * pi)) + 1: c = 0
            Do: c = 512 / w * dh: DrawWidth = w: PSet (x, y), RGB(c * r, c * g, c * b): w = w - 1: Loop While w
            i = i - 1
        Loop
    Else: Draw = True: cc = 0: v = v - Rnd * 100
    End If
End Function
Private Sub Form_Click()
    Unload Me
End Sub
Private Sub Form_Load()
    Randomize
End Sub
Private Sub Form_Resize()
    Scale (0, 1)-(1, 0)
End Sub
Private Sub tmrTimer_Timer()
    Static a1 As Long, a2 As Long, c1 As Long, c2 As Long
    If a1 = 0 Then a1 = -(Rnd * 100) - 1: a2 = a1 - 2: c2 = -150
    Call Cls: Draw a1, c1: Draw a2, c2
End Sub

Download source code and resources.

[VB6] - Work with the pointers.

0
0
Often there are situations when you need to get data having only the address (for example, in WndProc, HookProc). Usually, simply copy the data via CopyMemory the structure after changing data and copy it back. If the structure is large, it will be a waste of resources to copy into structure and back. In languages such as C ++ is all done easily with the help of pointers, written something like newpos = (WINDOWPOS *) lparam. Nominally VB6 does not work with pointers, but there are a few workarounds.
For a start I will give the necessary declarations:
Code:

Public Declare Function GetMem4 Lib "msvbvm60" (src As Any, Dst As Any) As Long
Public Declare Function ArrPtr Lib "msvbvm60" Alias "VarPtr" (src() As Any) As Long

For example can access the the address of the variable in the stack are passed by reference. For example like this:
Code:

Private Type Vector
    X As Single
    Y As Single
End Type
Private Type TestRec
    Name As String
    Value As Long
    Position As Vector
    Money As Double
End Type
 
Private Sub Form_Load()
    Dim tr As TestRec
    Test tr
End Sub
 
Private Function Test(Pointer As TestRec, Optional ByVal nu As Long)
    Dim q As TestRec, z As TestRec
   
    q.Name = "The trick"
    q.Position.X = 5: q.Position.Y = 15
    q.Value = 12345: q.Money = 3.14
   
    z.Name = "Visual Basic 6.0"
    z.Position.X = 99: z.Position.Y = 105
    z.Value = 7643: z.Money = 36.6
   
    GetMem4 VarPtr(q), ByVal VarPtr(nu) - 4    ' Set pointer to q (Pointer = &q)
   
    PrintRec Pointer
   
    GetMem4 VarPtr(z), ByVal VarPtr(nu) - 4    ' Set pointer to z (Pointer = &z)
   
    PrintRec Pointer
   
End Function
 
Private Sub PrintRec(Pt As TestRec)
    Debug.Print "----------------"
    Debug.Print "Name = " & Pt.Name
    Debug.Print "Value = " & Pt.Value
    Debug.Print "Money = " & Pt.Money
    Debug.Print "Position.X = " & Pt.Position.X
    Debug.Print "Position.Y = " & Pt.Position.Y
End Sub

You can also create a pointer by using arrays. The idea is to create 2 arrays one element each, which will store the address of a variable, and the other will refer to the data. The first will always be Long, a second type of data desired. This is useful for example if you want to pass on lists, etc. It's no secret that the array in VB is simply an SafeArray. In the data structure of this array contains a lot of useful information, and a pointer to the data. What we do, we create two arrays:
  • 1st (with address) refers to a pointer to the second data array. As a result, changing the values in the first array, 2nd automatically refer to the desired data.*
  • 2nd is directly the data pointed to by the first.*

Also, after all the manipulations necessary to return all the pointers back to VB properly clear the memory.* For all manipulations I created auxiliary functions and structure for data recovery.* Address SafeArray is available through Not Not Arr, but IDE after such manipulations are glitches with floating point:
Code:

Public Type PtDat
    Prv1 As Long
    Prv2 As Long
End Type

' Create the pointer. 1st param is pointer, 2nd address.
Public Function PtGet(Pointer() As Long, ByVal VarAddr As Long) As PtDat
    Dim i As Long
    i = GetSA(ArrPtr(Pointer)) + &HC
    GetMem4 ByVal i, PtGet.Prv1
    GetMem4 VarAddr + &HC, ByVal i
    PtGet.Prv2 = Pointer(0)
End Function
' Release pointer
Public Sub PtRelease(Pointer() As Long, prev As PtDat)
    Pointer(0) = prev.Prv2
    GetMem4 prev.Prv1, ByVal GetSA(ArrPtr(Pointer)) + &HC
End Sub
' Obtaint address of SafeArray (same Not Not)
Public Function GetSA(ByVal addr As Long) As Long
    GetMem4 ByVal addr, GetSA
End Function

Example of use:
Code:

Private Sub Form_Load()
    Dim pt() As Long, var() As TestRec, prev As PtDat      ' Pointer, references data, release data.
    Dim q As TestRec, z As TestRec                          ' The structures, which we refer
   
    ReDim pt(0): ReDim var(0)
 
    q.Name = "The trick"
    q.Position.X = 5: q.Position.Y = 15
    q.Value = 12345: q.Money = 3.14
   
    z.Name = "Visual Basic 6.0"
    z.Position.X = 99: z.Position.Y = 105
    z.Value = 7643: z.Money = 36.6
   
    prev = PtGet(pt, GetSA(ArrPtr(var)))                    ' Create "pointer"
 
    pt(0) = VarPtr(q)                                      ' Refer to q (pt = &q)
    PrintRec var(0)
    pt(0) = VarPtr(z)                                      ' Refer to z (pt = &z)
    PrintRec var(0)
 
    PtRelease pt, prev                                      ' Release
 
End Sub

[VB6] - Get information about memory usage.

0
0
Code:

Option Explicit
 
Private Const MAX_PATH = 260
 
Private Type PROCESS_MEMORY_COUNTERS
    cb                          As Long
    PageFaultCount              As Long
    PeakWorkingSetSize          As Long
    WorkingSetSize              As Long
    QuotaPeakPagedPoolUsage    As Long
    QuotaPagedPoolUsage        As Long
    QuotaPeakNonPagedPoolUsage  As Long
    QuotaNonPagedPoolUsage      As Long
    PagefileUsage              As Long
    PeakPagefileUsage          As Long
End Type
Private Type PROCESSENTRY32
    dwSize                      As Long
    cntUsage                    As Long
    th32ProcessID              As Long
    th32DefaultHeapID          As Long
    th32ModuleID                As Long
    cntThreads                  As Long
    th32ParentProcessID        As Long
    pcPriClassBase              As Long
    dwFlags                    As Long
    szExeFile                  As String * MAX_PATH
End Type
Private Type OSVERSIONINFO
    dwOSVersionInfoSize        As Long
    dwMajorVersion              As Long
    dwMinorVersion              As Long
    dwBuildNumber              As Long
    dwPlatformId                As Long
    szCSDVersion                As String * 128
End Type
 
Private Declare Function GetVersionEx Lib "kernel32" _
                        Alias "GetVersionExA" ( _
                        ByRef lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function Process32First Lib "kernel32" ( _
                        ByVal hSnapshot As Long, _
                        ByRef lppe As PROCESSENTRY32) As Long
Private Declare Function Process32Next Lib "kernel32" ( _
                        ByVal hSnapshot As Long, _
                        ByRef lppe As PROCESSENTRY32) As Long
Private Declare Function OpenProcess Lib "kernel32" ( _
                        ByVal dwDesiredAccess As Long, _
                        ByVal bInheritHandle As Long, _
                        ByVal dwProcessId As Long) As Long
Private Declare Function CreateToolhelp32Snapshot Lib "kernel32" ( _
                        ByVal dwFlags As Long, _
                        ByVal th32ProcessID As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" ( _
                        ByVal hObject As Long) As Long
Private Declare Function GetProcessMemoryInfo Lib "psapi.dll" ( _
                        ByVal lHandle As Long, _
                        ByRef lpStructure As PROCESS_MEMORY_COUNTERS, _
                        ByVal lSize As Long) As Long
 
Private Const TH32CS_SNAPPROCESS                  As Long = 2
Private Const PROCESS_QUERY_LIMITED_INFORMATION  As Long = &H1000
Private Const PROCESS_QUERY_INFORMATION          As Long = &H400
Private Const INVALID_HANDLE_VALUE                As Long = -1
 
Dim IsVistaAndLater As Boolean
 
Private Sub Form_Load()
    Dim ver As OSVERSIONINFO
   
    ver.dwOSVersionInfoSize = Len(ver)
    GetVersionEx ver
    IsVistaAndLater = ver.dwMajorVersion >= 6
   
    Call tmrTimer_Timer
   
End Sub

Private Sub Form_Resize()
    If Me.ScaleWidth > 200 And Me.ScaleHeight > 200 Then lvwInfo.Move 100, 100, Me.ScaleWidth - 200, Me.ScaleHeight - 200
End Sub

Private Sub tmrTimer_Timer()
    Dim hSnap  As Long:                    Dim pe      As PROCESSENTRY32
    Dim hProc  As Long:                    Dim mi      As PROCESS_MEMORY_COUNTERS
    Dim i      As Long:                    Dim li      As ListItem
   
    hSnap = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0)
    If hSnap = INVALID_HANDLE_VALUE Then Exit Sub
   
    pe.dwSize = Len(pe)
   
    If Process32First(hSnap, pe) Then
   
        Do
            hProc = OpenProcess(IIf(IsVistaAndLater, PROCESS_QUERY_LIMITED_INFORMATION, PROCESS_QUERY_INFORMATION), _
                                False, pe.th32ProcessID)
            If hProc Then
                mi.cb = Len(mi)
                GetProcessMemoryInfo hProc, mi, Len(mi)
                If i >= lvwInfo.ListItems.Count Then
                    Set li = lvwInfo.ListItems.Add(, , Left$(pe.szExeFile, InStr(1, pe.szExeFile, vbNullChar)))
                Else: Set li = lvwInfo.ListItems(i + 1)
                End If
                li.SubItems(1) = pe.th32ProcessID
                li.SubItems(2) = LTrim(Format(mi.WorkingSetSize / 1024, "### ### ##0"))
                li.SubItems(3) = LTrim(Format(mi.PagefileUsage / 1024, "### ### ##0"))
                li.SubItems(4) = mi.PageFaultCount
                li.SubItems(5) = LTrim(Format(mi.PeakPagefileUsage / 1024, "### ### ##0"))
                li.SubItems(6) = LTrim(Format(mi.PeakWorkingSetSize / 1024, "### ### ##0"))
                li.SubItems(7) = LTrim(Format(Int(mi.QuotaNonPagedPoolUsage / 1024), "### ### ##0"))
                li.SubItems(8) = LTrim(Format(Int(mi.QuotaPagedPoolUsage / 1024), "### ### ##0"))
                li.SubItems(9) = LTrim(Format(mi.QuotaPeakNonPagedPoolUsage / 1024, "### ### ##0"))
                li.SubItems(10) = LTrim(Format(mi.QuotaPeakPagedPoolUsage / 1024, "### ### ##0"))
                CloseHandle hProc
                i = i + 1
            End If
           
        Loop While Process32Next(hSnap, pe)
       
    End If
   
    CloseHandle hSnap
   
    If i < lvwInfo.ListItems.Count Then
        Do Until lvwInfo.ListItems.Count = i
            lvwInfo.ListItems.Remove (lvwInfo.ListItems.Count)
        Loop
    End If
   
End Sub

Attached Files

[VB6] Simple, basic subclassing tutorial using the easier SetWindowSubclass method

0
0
So there's quite a few posts about specific questions where code like this is shown, but I really thought it would be better to have a subclassing tutorial type codebank entry for it to make it more easily searchable, and a better answer for when somebody hasn't used subclassing before.

Since Windows XP, there's been some great subclassing setups posted showing how to use SetWindowSubclass as a newer, better subclassing method than previous SetWindowLong-based methods. Karl E. Peterson's HookXP and LaVolpe's Subclassing With Common Controls Library being two top notch examples, and this method was first shown to me by Bonnie West over in my ITaskBarList3 demo. But before delving into using interfaces etc, (and even still for subclassing things other than forms and the like), it's helpful to show how to do the very simplest of subclassing: When you have any object, and just want to have a code to handle a message without much fuss.

The subclassing example I picked for this is validating whether text typed into a textbox is a valid filename, and blocking the input altogether if the keystroke or paste operation contains an illegal character or is too long. (You could do this without subclassing in most scenarios, but I thought it was a nice and simple way to get the idea across.)

All it requires on the form is a single textbox.

Once you have that, you'll need to create the function that handles its messages in a module. All such functions, usually referred to as the WndProc, have the same arguments. Also, they all must unsubclass when the window is being destroyed (or before) otherwise the program will crash. So before adding any code for handling messages, the basic prototype looks like this:

Code:

Public Function EditWndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long

Select Case uMsg

    '[other messages will go here later]

  Case WM_DESTROY
    Call UnSubclass(hWnd, PtrEditWndProc)

End Select
 
EditWndProc = DefSubclassProc(hWnd, uMsg, wParam, lParam)

End Function
Private Function PtrEditWndProc() As Long
PtrEditWndProc = FARPROC(AddressOf EditWndProc)
End Function

The DefSubclassProc call passes everything back to the default handler if you're not completely handling it. The PtrEditWndProc is there because you can't use the AddressOf operator to get the address of the function it's in.

Now that you have a function to handle the messages, you can add the code to start the subclass back in the form:

Code:

Private Sub Form_Load()
Call Subclass(Text1.hWnd, AddressOf EditWndProc)
End Sub

And now you have a basic subclass all set up and ready to go. You don't need an Unsubclass in Form_Unload.
Here's the message handlers used to validate input for a textbox looking for a valid file name (and appears right after Select Case uMsg:

Code:

  Case WM_CHAR
    Dim lLen As Long
    lLen = SendMessageW(hWnd, WM_GETTEXTLENGTH, 0, ByVal 0&) + 1
    If lLen > 260 Then
            Beep
            wParam = 0
            Call ShowBalloonTipEx(hWnd, "", "Maximum number of characters has been reached. The total length of the file name cannot exceed 260 characters.", TTI_NONE) ' TTI_ERROR)
            Exit Function
    End If
    Select Case wParam
        Case 47, 92, 60, 62, 58, 42, 124, 63, 34 'Illegal chars /\<>:*|?"
            Beep
            Call ShowBalloonTipEx(hWnd, "", "File names may not contain any of the following characters:" & vbCrLf & " / \ < > : ? * | " & Chr$(34), TTI_NONE) ' TTI_ERROR)
            wParam = 0
    End Select
   
    Case WM_PASTE
        Dim iCheck As Integer
        iCheck = IsClipboardValidFileName()
        If iCheck = 0 Then
            Beep
            Call ShowBalloonTipEx(hWnd, "", "File names may not contain any of the following characters:" & vbCrLf & " / \ < > : ? * | " & Chr$(34), TTI_NONE) ' TTI_ERROR)
            Exit Function
        ElseIf iCheck = -1 Then
            Beep
            Call ShowBalloonTipEx(hWnd, "", "The file name you have entered is too long. The total length of the file name cannot exceed 260 characters.", TTI_NONE) ' TTI_ERROR)
            Exit Function

        End If

Here's what the full project looks like with all the supporting codes and declares added in:

Form1
Code:

Option Explicit

Private Sub Form_Load()
Call Subclass(Text1.hWnd, AddressOf EditWndProc)
End Sub

mSubclass
Code:

Option Explicit

Private Declare Function DefSubclassProc Lib "comctl32.dll" Alias "#413" (ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetWindowSubclass Lib "comctl32.dll" Alias "#410" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long, Optional ByVal dwRefData As Long) As Long
Private Declare Function RemoveWindowSubclass Lib "comctl32.dll" Alias "#412" (ByVal hWnd As Long, ByVal pfnSubclass As Long, ByVal uIdSubclass As Long) As Long
Private Declare Function SendMessageW Lib "user32" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Type EDITBALLOONTIP
    cbStruct As Long
    pszTitle As Long
    pszText As Long
    ttiIcon As BalloonTipIconConstants ' ; // From TTI_*
End Type
Private Enum BalloonTipIconConstants
  TTI_NONE = 0
  TTI_INFO = 1
  TTI_WARNING = 2
  TTI_ERROR = 3
End Enum

Private Const WM_CHAR = &H102
Private Const WM_PASTE = &H302
Private Const WM_DESTROY = &H2
Private Const WM_GETTEXTLENGTH = &HE

Private Const ECM_FIRST As Long = &H1500
Private Const EM_SHOWBALLOONTIP As Long = (ECM_FIRST + 3)

Public Function Subclass(hWnd As Long, lpfn As Long) As Long
Subclass = SetWindowSubclass(hWnd, lpfn, 0)
End Function
Public Function UnSubclass(hWnd As Long, lpfn As Long) As Long
'Only needed if you want to stop the subclassing code and keep the program running.
'Otherwise, the WndProc function should call this on WM_DESTROY
UnSubclass = RemoveWindowSubclass(hWnd, lpfn, 0)
End Function

Public Function EditWndProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal uIdSubclass As Long, ByVal dwRefData As Long) As Long
Select Case uMsg

  Case WM_CHAR
    Dim lLen As Long
    lLen = SendMessageW(hWnd, WM_GETTEXTLENGTH, 0, ByVal 0&) + 1
    If lLen > 260 Then
            Beep
            wParam = 0
            Call ShowBalloonTipEx(hWnd, "", "Maximum number of characters has been reached. The total length of the file name cannot exceed 260 characters.", TTI_NONE) ' TTI_ERROR)
            Exit Function
    End If
    Select Case wParam
        Case 47, 92, 60, 62, 58, 42, 124, 63, 34 'Illegal chars /\<>:*|?"
            Beep
            Call ShowBalloonTipEx(hWnd, "", "File names may not contain any of the following characters:" & vbCrLf & " / \ < > : ? * | " & Chr$(34), TTI_NONE) ' TTI_ERROR)
            wParam = 0
    End Select
   
    Case WM_PASTE
        Dim iCheck As Integer
        iCheck = IsClipboardValidFileName()
        If iCheck = 0 Then
            Beep
            Call ShowBalloonTipEx(hWnd, "", "File names may not contain any of the following characters:" & vbCrLf & " / \ < > : ? * | " & Chr$(34), TTI_NONE) ' TTI_ERROR)
            Exit Function
        ElseIf iCheck = -1 Then
            Beep
            Call ShowBalloonTipEx(hWnd, "", "The file name you have entered is too long. The total length of the file name cannot exceed 260 characters.", TTI_NONE) ' TTI_ERROR)
            Exit Function

        End If
       
  Case WM_DESTROY
    Call UnSubclass(hWnd, PtrEditWndProc)

End Select
 
EditWndProc = DefSubclassProc(hWnd, uMsg, wParam, lParam)

End Function
Private Function PtrEditWndProc() As Long
PtrEditWndProc = FARPROC(AddressOf EditWndProc)
End Function

Private Function FARPROC(pfn As Long) As Long
  FARPROC = pfn
End Function

Private Sub ShowBalloonTipEx(hWnd As Long, sTitle As String, sText As String, btIcon As BalloonTipIconConstants)
Dim lR As Long
Dim tEBT As EDITBALLOONTIP
tEBT.cbStruct = LenB(tEBT)
tEBT.pszText = StrPtr(sText)
tEBT.pszTitle = StrPtr(sTitle)
tEBT.ttiIcon = btIcon
lR = SendMessageW(hWnd, EM_SHOWBALLOONTIP, 0, tEBT)
End Sub
Public Function IsClipboardValidFileName() As Integer
Dim i As Long
Dim sz As String
Dim sChr As String
'there's a couple scenarios for invalid file names i've trimmed out
'to keep this example as simple as possible, look into them if you're
'going to use this code in an actual rename procedure
sz = Clipboard.GetText

If Len(sz) > 260 Then
    IsClipboardValidFileName = -1
    Exit Function
End If
IsClipboardValidFileName = 1

If InStr(sz, "*") Or InStr(sz, "?") Or InStr(sz, "<") Or InStr(sz, ">") Or InStr(sz, "|") Or InStr(sz, Chr$(34)) Then
    IsClipboardValidFileName = 0
End If
End Function

It's still a little complicated, but this is the very simplest way to get subclassing going.
Attached Files

Here's some code for calculating hashes.

0
0
It works with MD2, MD4, MD5, SHA1, SHA2-256, SHA2-384, and SHA2-512. Put the below code in a module (BAS file). It does everything that CAPICOM does regarding hashes, but without using any ActiveX DLL files. It depends entirely on the standard cryptographic API DLL files, using declare statements. There are several publicly accessible functions. These are
HashBytes
HashStringA
HashStringU
HashArbitraryData
BytesToHex
BytesToB64

HashBytes computes a hash of a 1D byte array, who's lower bound is 0.

HashStringA computes the hash of an Ascii/Ansi (1 byte per character) string. As VB6 strings are actually Unicode (2 bytes per character), and due to the fact that this function is intended to calculate the hash of the Ascii version of the string, the function first converts VB6's unicode characters to true Ascii characters via VB6's StrConv function. However, because characters with an Ascii value above 127 will differ between locales, the LocaleID is needed to be known for this conversion. As such, LocaleID is a parameter for this function. By default, the LocaleID used by the program is the LocaleID of the PC that the program is running on. This should be used in most situations, as this will generate a hash that will match the output of most other programs that generate a hash (such as the program called Easy Hash).

HashStringU computes the hash of a Unicode (2 bytes per character) string. As VB6 strings are actually Unicode, there is no conversion needed, and thus is no need to specify LocaleID. Therefore, this function doesn't have a LocaleID parameter. Because each character is defined by 2 bytes, rather than 1, the output of this hash function will obviously differ from the hash calculated by HashStringA, and thus will differ from the hash calculated by most other hash calculating programs (such as the freeware one that I used for testing called Easy Hash). For example, a string with 3 spaces " " is represented as the byte array (shown in hex) 20 00 20 00 20 00 in Unicode encoding, but as 20 20 20 in Ascii encoding. These are 2 distinctly different byte arrays, and thus will produce 2 completely different hashes.
Side-Note regarding Unicode in VB6: Despite this fact, that internally in VB6 all the strings are Unicode, the implementation of Unicode in VB6 is VERY LIMITED. That is, it won't display any Unicode character that can't also be displayed as an extended ascii character for the computer's current locale. Instead it will show it as a question mark. This won't effect how this function works (or the above function, as it's computing a hash, not displaying anything), but it will effect whether or not a given string will be properly displayed.

HashArbitraryData computes the hash of absolutely anything. It just needs to know where in memory the first byte of data is, and how many bytes long the data is. It will work with multidimensional byte arrays, arrays of other data types, arrays that start with with a lower bound other than zero, user defined types, sections of memory allocated with API functions, etc. There's nothing that it can't compute the hash of. Of course this gives you the added responsibility of needing to know where exactly in memory the data is, and the size of the data in bytes.

BytesToHex. This is a function intended to convert the raw bytes output from a hash function to a displayable hexadecimal string.

BytesToB64. This is a function intended to convert the raw bytes output from a hash function to a displayable base64 string.



Code:

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Private Declare Function CryptAcquireContext Lib "advapi32.dll" Alias "CryptAcquireContextA" (ByRef phProv As Long, ByVal pszContainer As String, ByVal pszProvider As String, ByVal dwProvType As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptCreateHash Lib "advapi32.dll" (ByVal hProv As Long, ByVal Algid As Long, ByVal hKey As Long, ByVal dwFlags As Long, ByRef phHash As Long) As Long
Private Declare Function CryptHashData Lib "advapi32.dll" (ByVal hHash As Long, ByRef pbData As Any, ByVal dwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptGetHashParam Lib "advapi32.dll" (ByVal hHash As Long, ByVal dwParam As Long, ByRef pByte As Any, ByRef pdwDataLen As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptDestroyHash Lib "advapi32.dll" (ByVal hHash As Long) As Long
Private Declare Function CryptReleaseContext Lib "advapi32.dll" (ByVal hProv As Long, ByVal dwFlags As Long) As Long
Private Declare Function CryptBinaryToString Lib "Crypt32.dll" Alias "CryptBinaryToStringA" (ByRef pbBinary As Any, ByVal cbBinary As Long, ByVal dwFlags As Long, ByVal pszString As String, ByRef pcchString As Long) As Long

Private Const PROV_RSA_AES As Long = 24
Private Const CRYPT_VERIFYCONTEXT As Long = &HF0000000

Public Enum HashAlgo
    HALG_MD2 = &H8001&
    HALG_MD4 = &H8002&
    HALG_MD5 = &H8003&
    HALG_SHA1 = &H8004&
    HALG_SHA2_256 = &H800C&
    HALG_SHA2_384 = &H800D&
    HALG_SHA2_512 = &H800E&
End Enum

Private Const HP_HASHSIZE As Long = &H4&
Private Const HP_HASHVAL As Long = &H2&


Public Function HashBytes(ByRef Data() As Byte, Optional ByVal HashAlgorithm As HashAlgo = HALG_MD5) As Byte()
Dim hProv As Long
Dim hHash As Long
Dim Hash() As Byte
Dim HashSize As Long

CryptAcquireContext hProv, vbNullString, vbNullString, 24, CRYPT_VERIFYCONTEXT
CryptCreateHash hProv, HashAlgorithm, 0, 0, hHash
CryptHashData hHash, Data(0), UBound(Data) + 1, 0
CryptGetHashParam hHash, HP_HASHSIZE, HashSize, 4, 0
ReDim Hash(HashSize - 1)
CryptGetHashParam hHash, HP_HASHVAL, Hash(0), HashSize, 0
CryptDestroyHash hHash
CryptReleaseContext hProv, 0

HashBytes = Hash()
End Function



Public Function HashStringA(ByVal Text As String, Optional ByVal LocaleID As Long, Optional ByVal HashAlgorithm As HashAlgo = HALG_MD5) As Byte()
Dim Data() As Byte
Data() = StrConv(Text, vbFromUnicode, LocaleID)
HashStringA = HashBytes(Data, HashAlgorithm)
End Function

Public Function HashStringU(ByVal Text As String, Optional ByVal HashAlgorithm As HashAlgo = HALG_MD5) As Byte()
Dim Data() As Byte
Data() = Text
HashStringU = HashBytes(Data, HashAlgorithm)
End Function

Public Function HashArbitraryData(ByVal MemAddress As Long, ByVal ByteCount As Long, Optional ByVal HashAlgorithm As HashAlgo = HALG_MD5) As Byte()
Dim Data() As Byte
ReDim Data(ByteCount - 1)
CopyMemory Data(0), ByVal MemAddress, ByteCount
HashArbitraryData = HashBytes(Data, HashAlgorithm)
End Function






Public Function BytesToHex(ByRef Bytes() As Byte) As String
Dim HexStringLen As Long
Dim HexString As String

CryptBinaryToString Bytes(0), UBound(Bytes) + 1, 12, vbNullString, HexStringLen
HexString = String$(HexStringLen, vbNullChar)
CryptBinaryToString Bytes(0), UBound(Bytes) + 1, 12, HexString, HexStringLen

BytesToHex = UCase$(HexString)
End Function

Public Function BytesToB64(ByRef Bytes() As Byte) As String
Dim B64StringLen As Long
Dim B64String As String

CryptBinaryToString Bytes(0), UBound(Bytes) + 1, 1, vbNullString, B64StringLen
B64String = String$(B64StringLen, vbNullChar)
CryptBinaryToString Bytes(0), UBound(Bytes) + 1, 1, B64String, B64StringLen

BytesToB64 = B64String
End Function

Code Snippet: Getting folder settings with SHGetSettings

0
0
So there's not a single result for SHGetSettings, and this is an odd function, so I just wanted to post a working method of using it. SHGetSetSettings isn't supported above XP, so even if it's still working you might want to use this function.

The way you'd think to use it would be using the structure SHELLFLAGSTATE, but whether ByRef or VarPtr, that doesn't seem to work. Apparently it's a bitfield, and you can pass it an Integer. The Mask can be passed as normal.

Code:

Public Declare Function SHGetSettings Lib "shell32" (lpsfs As Integer, ByVal dwMask As SFS_MASK) As Long

Public Enum SFS_MASK
    SSF_SHOWALLOBJECTS = &H1
    SSF_SHOWEXTENSIONS = &H2
    SSF_SHOWCOMPCOLOR = &H8
    SSF_SHOWSYSFILES = &H20
    SSF_DOUBLECLICKINWEBVIEW = &H80
    SSF_SHOWATTRIBCOL = &H100
    SSF_DESKTOPHTML = &H200
    SSF_WIN95CLASSIC = &H400
    SSF_DONTPRETTYPATH = &H800
    SSF_SHOWINFOTIP = &H2000
    SSF_MAPNETDRVBUTTON = &H1000
    SSF_NOCONFIRMRECYCLE = &H8000
    SSF_HIDEICONS = &H4000
End Enum

The structure that's supposed to be returned looks like this:
Code:

Public Type SHELLFLAGSTATE
  fShowAllObjects  As Boolean
  fShowExtensions  As Boolean
  fNoConfirmRecycle  As Boolean
  fShowSysFiles  As Boolean
  fShowCompColor  As Boolean
  fDoubleClickInWebView  As Boolean
  fDesktopHTML  As Boolean
  fWin95Classic  As Boolean
  fDontPrettyPath  As Boolean
  fShowAttribCol  As Boolean
  fMapNetDrvBtn  As Boolean
  fShowInfoTip  As Boolean
  fHideIcons  As Boolean
  fAutoCheckSelect  As Boolean
  fIconsOnly  As Boolean
  fRestFlags  As Long
End Type

Instead, we're not going to use that structure at all, but its members represent bits (and fRestFlags isn't used for anything), so their order matters. fShowAllObjects is 2^0, fShowExtensions is 2^1, etc.

Code:

Public Function ExplorerSettingEnabled(lSetting As SFS_MASK) As Boolean
Dim lintg As Integer
Call SHGetSettings(lintg, lSetting)
Select Case lSetting
    Case SSF_SHOWALLOBJECTS
        ExplorerSettingEnabled = lintg And 2 ^ 0 'fShowAllObjects
    Case SSF_SHOWEXTENSIONS
        ExplorerSettingEnabled = lintg And 2 ^ 1 'fShowExtensions
    Case SSF_NOCONFIRMRECYCLE
        ExplorerSettingEnabled = lintg And 2 ^ 2 'fNoConfirmRecycle
    Case SSF_SHOWSYSFILES
        ExplorerSettingEnabled = lintg And 2 ^ 3 'fShowSysFiles
    Case SSF_SHOWCOMPCOLOR
        ExplorerSettingEnabled = lintg And 2 ^ 4 'fShowCompColor
    Case SSF_DOUBLECLICKINWEBVIEW
        ExplorerSettingEnabled = lintg And 2 ^ 5 'fDoubleClickInWebView
    Case SSF_DESKTOPHTML
        ExplorerSettingEnabled = lintg And 2 ^ 6 'fDesktopHTML
    Case SSF_WIN95CLASSIC
        ExplorerSettingEnabled = lintg And 2 ^ 7 'fWin95Classic
    Case SSF_DONTPRETTYPATH
        ExplorerSettingEnabled = lintg And 2 ^ 8 'fDontPrettyPath
    Case SSF_SHOWATTRIBCOL
        ExplorerSettingEnabled = lintg And 2 ^ 9 'fShowAttribCol
    Case SSF_MAPNETDRVBUTTON
        ExplorerSettingEnabled = lintg And 2 ^ 10 'fMapNetDrvButton
    Case SSF_SHOWINFOTIP
        ExplorerSettingEnabled = lintg And 2 ^ 11 'fShowInfoTip
    Case SSF_HIDEICONS
        ExplorerSettingEnabled = lintg And 2 ^ 12 'fHideIcons
   
End Select
End Function

VB6 Threading, using the small DirectCOM.dll-HelperLib

0
0
Just for those who want to try a proven approach, which works reliably (and comparably simple)
in spanning up STAs (Single-Threaded-Apartments) for over 10 years now (one can use his own
VB6-compiled AX-Dlls which provide a Class-Instance that runs on said STA - no Assembler-Thunking,
no TypeLibs and also no "special Dll-Exports" are needed - it's aside from a few API-calls just straight VB-Code).

The Thread-Class-Instances in question are always created Regfree in this case (so,
no Setup is needed - just ship your Thread-Dlls alongside DirectCOM.dll in a SubFolder
of your App).

The Demo here tries to show not only how to create the STA-threads with a Class-
Instance in it, but also how to share Memory with the Applications Main-Thread
(which is the fastest way of cross-thread-communication).

The implementation of the Main-App is using a separate (Private) Wrapper-Class
for handling the "Remote-Thread" (offering Properties to wrap the shared Memory-area,
and such a Class will also automatically close the thread it wraps, in case it is itself terminated).

That allows for cleaner Code in the "Thread-consuming-instance" (in our case the Apps fMain-Form).

The Code for the ThreadLib.dll on the other hand - (this is the AX-Dll which provides a Public
cThread-Class, which will finally run on its own threaded Apartment) - is contained in the
\Bin\... SubFolder of the Zip.

Just leave this Bin-SubFolder as it is, when you run the Main-Apps *.vbp File.

Here's the Code for the Demo:
VB6ThreadingDirectCOM.zip

And here is a ScreenShot (the colored Forms are created inside the 4 Threads - and perform
an endless loop, to show some kind of "Plasma-Effect" - just to put the threads under stress a bit).



Have fun (and just ask when you have any questions - though I tried to comment the Demo well enough, I hope).

Olaf
Attached Files

Register/Unregister both DLLs and OCXs with RightClick

0
0
I used a vbscript provided by Olaf to register vbRichClient5, changed it a bit, and added 4 entries to registry.
Now I'm able to register/unregister both DLLs and OCXs with a simple RightMouse click over the file.

This probably worth less than nothing, but it works for me, and might be useful for somebody else.
Just copy Register.vbs to C:\Windows and execute the file Register.reg

Register.zip
Attached Files

[VB6] - Module for working with COM-Dll without registration.

0
0
Hello. I give my module for working with COM-DLL without registration in the registry.
The module has several functions:
  1. GetAllCoclasses - returns to the list of classes and unique identifiers are extracted from a type library.
  2. CreateIDispatch - creates IDispatch implementation by reference to the object and the name of the interface.
  3. CreateObjectEx2 - creates an object by name from a type library.
  4. CreateObjectEx - creates an object by CLSID.
  5. UnloadLibrary - unloads the DLL if it is not used.

vb Code:
  1. ' The module modTrickUnregCOM.bas - for working with COM libraries without registration.
  2. ' © Krivous Anatolii Anatolevich (The trick), 2015
  3.  
  4. Option Explicit
  5.  
  6.  D E C L A R A T I O N
  7.  
  8. Dim iidClsFctr      As GUID
  9. Dim iidUnk          As GUID
  10. Dim isInit          As Boolean
  11.  
  12. ' // Get all co-classes described in type library.
  13. Public Function GetAllCoclasses( _
  14.                 ByRef path As String, _
  15.                 ByRef listOfClsid() As GUID, _
  16.                 ByRef listOfNames() As String, _
  17.                 ByRef countCoClass As Long) As Boolean
  18.                
  19.     Dim typeLib As IUnknown
  20.     Dim typeInf As IUnknown
  21.     Dim ret     As Long
  22.     Dim count   As Long
  23.     Dim index   As Long
  24.     Dim pAttr   As Long
  25.     Dim tKind   As Long
  26.    
  27.     ret = LoadTypeLibEx(StrPtr(path), REGKIND_NONE, typeLib)
  28.    
  29.     If ret Then
  30.         Err.Raise ret
  31.         Exit Function
  32.     End If
  33.    
  34.     count = ITypeLib_GetTypeInfoCount(typeLib)
  35.     countCoClass = 0
  36.    
  37.     If count > 0 Then
  38.    
  39.         ReDim listOfClsid(count - 1)
  40.         ReDim listOfNames(count - 1)
  41.        
  42.         For index = 0 To count - 1
  43.        
  44.             ret = ITypeLib_GetTypeInfo(typeLib, index, typeInf)
  45.                        
  46.             If ret Then
  47.                 Err.Raise ret
  48.                 Exit Function
  49.             End If
  50.            
  51.             ITypeInfo_GetTypeAttr typeInf, pAttr
  52.            
  53.             GetMem4 ByVal pAttr + &H28, tKind
  54.            
  55.             If tKind = TKIND_COCLASS Then
  56.            
  57.                 memcpy listOfClsid(countCoClass), ByVal pAttr, Len(listOfClsid(countCoClass))
  58.                 ret = ITypeInfo_GetDocumentation(typeInf, -1, listOfNames(countCoClass), vbNullString, 0, vbNullString)
  59.                
  60.                 If ret Then
  61.                     ITypeInfo_ReleaseTypeAttr typeInf, pAttr
  62.                     Err.Raise ret
  63.                     Exit Function
  64.                 End If
  65.                
  66.                 countCoClass = countCoClass + 1
  67.                
  68.             End If
  69.            
  70.             ITypeInfo_ReleaseTypeAttr typeInf, pAttr
  71.            
  72.             Set typeInf = Nothing
  73.            
  74.         Next
  75.        
  76.     End If
  77.    
  78.     If countCoClass Then
  79.        
  80.         ReDim Preserve listOfClsid(countCoClass - 1)
  81.         ReDim Preserve listOfNames(countCoClass - 1)
  82.    
  83.     Else
  84.    
  85.         Erase listOfClsid()
  86.         Erase listOfNames()
  87.        
  88.     End If
  89.    
  90.     GetAllCoclasses = True
  91.    
  92. End Function
  93.  
  94. ' // Create IDispach implementation described in type library.
  95. Public Function CreateIDispatch( _
  96.                 ByRef obj As IUnknown, _
  97.                 ByRef typeLibPath As String, _
  98.                 ByRef interfaceName As String) As Object
  99.                
  100.     Dim typeLib As IUnknown
  101.     Dim typeInf As IUnknown
  102.     Dim ret     As Long
  103.     Dim retObj  As IUnknown
  104.     Dim pAttr   As Long
  105.     Dim tKind   As Long
  106.    
  107.     ret = LoadTypeLibEx(StrPtr(typeLibPath), REGKIND_NONE, typeLib)
  108.    
  109.     If ret Then
  110.         Err.Raise ret
  111.         Exit Function
  112.     End If
  113.    
  114.     ret = ITypeLib_FindName(typeLib, interfaceName, 0, typeInf, 0, 1)
  115.    
  116.     If typeInf Is Nothing Then
  117.         Err.Raise &H80004002, , "Interface not found"
  118.         Exit Function
  119.     End If
  120.    
  121.     ITypeInfo_GetTypeAttr typeInf, pAttr
  122.     GetMem4 ByVal pAttr + &H28, tKind
  123.     ITypeInfo_ReleaseTypeAttr typeInf, pAttr
  124.    
  125.     If tKind = TKIND_DISPATCH Then
  126.         Set CreateIDispatch = obj
  127.         Exit Function
  128.     ElseIf tKind <> TKIND_INTERFACE Then
  129.         Err.Raise &H80004002, , "Interface not found"
  130.         Exit Function
  131.     End If
  132.  
  133.     ret = CreateStdDispatch(Nothing, obj, typeInf, retObj)
  134.    
  135.     If ret Then
  136.         Err.Raise ret
  137.         Exit Function
  138.     End If
  139.    
  140.     Set CreateIDispatch = retObj
  141.  
  142. End Function
  143.  
  144. ' // Create object by Name.
  145. Public Function CreateObjectEx2( _
  146.                 ByRef pathToDll As String, _
  147.                 ByRef pathToTLB As String, _
  148.                 ByRef className As String) As IUnknown
  149.                
  150.     Dim typeLib As IUnknown
  151.     Dim typeInf As IUnknown
  152.     Dim ret     As Long
  153.     Dim pAttr   As Long
  154.     Dim tKind   As Long
  155.     Dim clsid   As GUID
  156.    
  157.     ret = LoadTypeLibEx(StrPtr(pathToTLB), REGKIND_NONE, typeLib)
  158.    
  159.     If ret Then
  160.         Err.Raise ret
  161.         Exit Function
  162.     End If
  163.    
  164.     ret = ITypeLib_FindName(typeLib, className, 0, typeInf, 0, 1)
  165.    
  166.     If typeInf Is Nothing Then
  167.         Err.Raise &H80040111, , "Class not found in type library"
  168.         Exit Function
  169.     End If
  170.  
  171.     ITypeInfo_GetTypeAttr typeInf, pAttr
  172.    
  173.     GetMem4 ByVal pAttr + &H28, tKind
  174.    
  175.     If tKind = TKIND_COCLASS Then
  176.         memcpy clsid, ByVal pAttr, Len(clsid)
  177.     Else
  178.         Err.Raise &H80040111, , "Class not found in type library"
  179.         Exit Function
  180.     End If
  181.    
  182.     ITypeInfo_ReleaseTypeAttr typeInf, pAttr
  183.            
  184.     Set CreateObjectEx2 = CreateObjectEx(pathToDll, clsid)
  185.    
  186. End Function
  187.                
  188. ' // Create object by CLSID and path.
  189. Public Function CreateObjectEx( _
  190.                 ByRef path As String, _
  191.                 ByRef clsid As GUID) As IUnknown
  192.                
  193.     Dim hLib    As Long
  194.     Dim lpAddr  As Long
  195.    
  196.     hLib = LoadLibrary(StrPtr(path))
  197.     If hLib = 0 Then
  198.         Err.Raise 53, , Error(53) & " " & Chr$(34) & path & Chr$(34)
  199.         Exit Function
  200.     End If
  201.    
  202.     lpAddr = GetProcAddress(hLib, "DllGetClassObject")
  203.    
  204.     If lpAddr = 0 Then
  205.         Err.Raise 453, , "Can't find dll entry point DllGetClasesObject in " & Chr$(34) & path & Chr$(34)
  206.         Exit Function
  207.     End If
  208.  
  209.     If Not isInit Then
  210.         CLSIDFromString StrPtr(IID_IClassFactory), iidClsFctr
  211.         CLSIDFromString StrPtr(IID_IUnknown), iidUnk
  212.         isInit = True
  213.     End If
  214.    
  215.     Dim ret     As Long
  216.     Dim out     As IUnknown
  217.    
  218.     ret = DllGetClassObject(lpAddr, clsid, iidClsFctr, out)
  219.    
  220.     If ret = 0 Then
  221.  
  222.         ret = IClassFactory_CreateInstance(out, 0, iidUnk, CreateObjectEx)
  223.  
  224.     Else: Err.Raise ret: Exit Function
  225.     End If
  226.    
  227.     Set out = Nothing
  228.    
  229. End Function
  230.  
  231. ' // Unload DLL if not used.
  232. Public Function UnloadLibrary( _
  233.                 ByRef path As String) As Boolean
  234.                
  235.     Dim hLib    As Long
  236.     Dim lpAddr  As Long
  237.     Dim ret     As Long
  238.    
  239.     If Not isInit Then Exit Function
  240.    
  241.     hLib = GetModuleHandle(StrPtr(path))
  242.     If hLib = 0 Then Exit Function
  243.    
  244.     lpAddr = GetProcAddress(hLib, "DllCanUnloadNow")
  245.     If lpAddr = 0 Then Exit Function
  246.    
  247.     ret = DllCanUnloadNow(lpAddr)
  248.    
  249.     If ret = 0 Then
  250.         FreeLibrary hLib
  251.         UnloadLibrary = True
  252.     End If
  253.    
  254. End Function
  255.  
  256. ' // Call "DllGetClassObject" function using a pointer.
  257. Private Function DllGetClassObject( _
  258.                  ByVal funcAddr As Long, _
  259.                  ByRef clsid As GUID, _
  260.                  ByRef iid As GUID, _
  261.                  ByRef out As IUnknown) As Long
  262.                  
  263.     Dim params(2)   As Variant
  264.     Dim types(2)    As Integer
  265.     Dim list(2)     As Long
  266.     Dim resultCall  As Long
  267.     Dim pIndex      As Long
  268.     Dim pReturn     As Variant
  269.    
  270.     params(0) = VarPtr(clsid)
  271.     params(1) = VarPtr(iid)
  272.     params(2) = VarPtr(out)
  273.    
  274.     For pIndex = 0 To UBound(params)
  275.         list(pIndex) = VarPtr(params(pIndex)):   types(pIndex) = VarType(params(pIndex))
  276.     Next
  277.    
  278.     resultCall = DispCallFunc(0&, funcAddr, CC_STDCALL, vbLong, 3, types(0), list(0), pReturn)
  279.              
  280.     If resultCall Then Err.Raise 5: Exit Function
  281.    
  282.     DllGetClassObject = pReturn
  283.    
  284. End Function
  285.  
  286. ' // Call "DllCanUnloadNow" function using a pointer.
  287. Private Function DllCanUnloadNow( _
  288.                  ByVal funcAddr As Long) As Long
  289.                  
  290.     Dim resultCall  As Long
  291.     Dim pReturn     As Variant
  292.    
  293.     resultCall = DispCallFunc(0&, funcAddr, CC_STDCALL, vbLong, 0, ByVal 0&, ByVal 0&, pReturn)
  294.              
  295.     If resultCall Then Err.Raise 5: Exit Function
  296.    
  297.     DllCanUnloadNow = pReturn
  298.    
  299. End Function
  300.  
  301. ' // Call "IClassFactory:CreateInstance" method.
  302. Private Function IClassFactory_CreateInstance( _
  303.                  ByVal obj As IUnknown, _
  304.                  ByVal punkOuter As Long, _
  305.                  ByRef riid As GUID, _
  306.                  ByRef out As IUnknown) As Long
  307.    
  308.     Dim params(2)   As Variant
  309.     Dim types(2)    As Integer
  310.     Dim list(2)     As Long
  311.     Dim resultCall  As Long
  312.     Dim pIndex      As Long
  313.     Dim pReturn     As Variant
  314.    
  315.     params(0) = punkOuter
  316.     params(1) = VarPtr(riid)
  317.     params(2) = VarPtr(out)
  318.    
  319.     For pIndex = 0 To UBound(params)
  320.         list(pIndex) = VarPtr(params(pIndex)):   types(pIndex) = VarType(params(pIndex))
  321.     Next
  322.    
  323.     resultCall = DispCallFunc(obj, &HC, CC_STDCALL, vbLong, 3, types(0), list(0), pReturn)
  324.          
  325.     If resultCall Then Err.Raise resultCall: Exit Function
  326.      
  327.     IClassFactory_CreateInstance = pReturn
  328.    
  329. End Function
  330.  
  331. ' // Call "ITypeLib:GetTypeInfoCount" method.
  332. Private Function ITypeLib_GetTypeInfoCount( _
  333.                  ByVal obj As IUnknown) As Long
  334.    
  335.     Dim resultCall  As Long
  336.     Dim pReturn     As Variant
  337.  
  338.     resultCall = DispCallFunc(obj, &HC, CC_STDCALL, vbLong, 0, ByVal 0&, ByVal 0&, pReturn)
  339.          
  340.     If resultCall Then Err.Raise resultCall: Exit Function
  341.      
  342.     ITypeLib_GetTypeInfoCount = pReturn
  343.    
  344. End Function
  345.  
  346. ' // Call "ITypeLib:GetTypeInfo" method.
  347. Private Function ITypeLib_GetTypeInfo( _
  348.                  ByVal obj As IUnknown, _
  349.                  ByVal index As Long, _
  350.                  ByRef ppTInfo As IUnknown) As Long
  351.    
  352.     Dim params(1)   As Variant
  353.     Dim types(1)    As Integer
  354.     Dim list(1)     As Long
  355.     Dim resultCall  As Long
  356.     Dim pIndex      As Long
  357.     Dim pReturn     As Variant
  358.    
  359.     params(0) = index
  360.     params(1) = VarPtr(ppTInfo)
  361.    
  362.     For pIndex = 0 To UBound(params)
  363.         list(pIndex) = VarPtr(params(pIndex)):   types(pIndex) = VarType(params(pIndex))
  364.     Next
  365.    
  366.     resultCall = DispCallFunc(obj, &H10, CC_STDCALL, vbLong, 2, types(0), list(0), pReturn)
  367.          
  368.     If resultCall Then Err.Raise resultCall: Exit Function
  369.      
  370.     ITypeLib_GetTypeInfo = pReturn
  371.    
  372. End Function
  373.  
  374. ' // Call "ITypeLib:FindName" method.
  375. Private Function ITypeLib_FindName( _
  376.                  ByVal obj As IUnknown, _
  377.                  ByRef szNameBuf As String, _
  378.                  ByVal lHashVal As Long, _
  379.                  ByRef ppTInfo As IUnknown, _
  380.                  ByRef rgMemId As Long, _
  381.                  ByRef pcFound As Integer) As Long
  382.    
  383.     Dim params(4)   As Variant
  384.     Dim types(4)    As Integer
  385.     Dim list(4)     As Long
  386.     Dim resultCall  As Long
  387.     Dim pIndex      As Long
  388.     Dim pReturn     As Variant
  389.    
  390.     params(0) = StrPtr(szNameBuf)
  391.     params(1) = lHashVal
  392.     params(2) = VarPtr(ppTInfo)
  393.     params(3) = VarPtr(rgMemId)
  394.     params(4) = VarPtr(pcFound)
  395.    
  396.     For pIndex = 0 To UBound(params)
  397.         list(pIndex) = VarPtr(params(pIndex)):   types(pIndex) = VarType(params(pIndex))
  398.     Next
  399.    
  400.     resultCall = DispCallFunc(obj, &H2C, CC_STDCALL, vbLong, 5, types(0), list(0), pReturn)
  401.          
  402.     If resultCall Then Err.Raise resultCall: Exit Function
  403.      
  404.     ITypeLib_FindName = pReturn
  405.    
  406. End Function
  407.  
  408. ' // Call "ITypeInfo:GetTypeAttr" method.
  409. Private Sub ITypeInfo_GetTypeAttr( _
  410.             ByVal obj As IUnknown, _
  411.             ByRef ppTypeAttr As Long)
  412.    
  413.     Dim resultCall  As Long
  414.     Dim pReturn     As Variant
  415.    
  416.     pReturn = VarPtr(ppTypeAttr)
  417.    
  418.     resultCall = DispCallFunc(obj, &HC, CC_STDCALL, vbEmpty, 1, vbLong, VarPtr(pReturn), 0)
  419.          
  420.     If resultCall Then Err.Raise resultCall: Exit Sub
  421.  
  422. End Sub
  423.  
  424. ' // Call "ITypeInfo:GetDocumentation" method.
  425. Private Function ITypeInfo_GetDocumentation( _
  426.                  ByVal obj As IUnknown, _
  427.                  ByVal memid As Long, _
  428.                  ByRef pBstrName As String, _
  429.                  ByRef pBstrDocString As String, _
  430.                  ByRef pdwHelpContext As Long, _
  431.                  ByRef pBstrHelpFile As String) As Long
  432.    
  433.     Dim params(4)   As Variant
  434.     Dim types(4)    As Integer
  435.     Dim list(4)     As Long
  436.     Dim resultCall  As Long
  437.     Dim pIndex      As Long
  438.     Dim pReturn     As Variant
  439.    
  440.     params(0) = memid
  441.     params(1) = VarPtr(pBstrName)
  442.     params(2) = VarPtr(pBstrDocString)
  443.     params(3) = VarPtr(pdwHelpContext)
  444.     params(4) = VarPtr(pBstrHelpFile)
  445.    
  446.     For pIndex = 0 To UBound(params)
  447.         list(pIndex) = VarPtr(params(pIndex)):   types(pIndex) = VarType(params(pIndex))
  448.     Next
  449.    
  450.     resultCall = DispCallFunc(obj, &H30, CC_STDCALL, vbLong, 5, types(0), list(0), pReturn)
  451.          
  452.     If resultCall Then Err.Raise resultCall: Exit Function
  453.      
  454.     ITypeInfo_GetDocumentation = pReturn
  455.    
  456. End Function
  457.  
  458. ' // Call "ITypeInfo:ReleaseTypeAttr" method.
  459. Private Sub ITypeInfo_ReleaseTypeAttr( _
  460.             ByVal obj As IUnknown, _
  461.             ByVal ppTypeAttr As Long)
  462.    
  463.     Dim resultCall  As Long
  464.    
  465.     resultCall = DispCallFunc(obj, &H4C, CC_STDCALL, vbEmpty, 1, vbLong, VarPtr(CVar(ppTypeAttr)), 0)
  466.          
  467.     If resultCall Then Err.Raise resultCall: Exit Sub
  468.  
  469. End Sub
Attached Files
Viewing all 1300 articles
Browse latest View live




Latest Images