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

[VB6] GDI+ Matrix For Rendering and Hit Testing

$
0
0
GDI+ offers a matrix object that can be applied to various other GDI+ objects. One of those is the Graphics object (similar to GDI's hDC). With a matrix, we can simultaneously scale, rotate, shear & offset/translate a rendering in basically one call.

The attached offers such options in a simple sample project. The matrix is created and can be cached for all future rendering, unless of course something changes and the matrix should be recreated. What's kind of neat is that an inverted copy of the matrix can be used for hit testing on the rotated, scaled, sheared, translated rendering relative to the original object, un-rotated, un-scaled, un-sheared, un-translated.

Please read the comments included in the code, especially within the pvCreateDisplayMatrix routine, before asking questions about the code

Name:  Untitled.jpg
Views: 40
Size:  44.6 KB
Attached Images
 
Attached Files

FloodFill code using pure VB code (no API)

$
0
0
Note it runs slow, but I believe this has more to do with the fact that it uses PSet and Point (rather than getting an array of pixels using GetDibBits and then operating on the array) than it does with some inherant slowness of the algorithm. The algorithm uses a stack (albeit a simulated one with a Long array and a separate Long variable for the stack pointer, not the real stack and pointer that you can directly access if you know assembly language) to store points to check to see if they are clear (equal to RefCol, the reference color), and thus to be filled in with a fill color (FillCol) which is generated randomly at the start of the FloodFill operation (and is always guarantied to not be the same as RefCol, because of how it is picked).

Here is the code for Module1
Code:

Dim Stack(10000000 - 1) As Long
Public SP As Long

Public Sub Push(ByVal Value As Long)
SP = SP + 1
Stack(SP) = Value
End Sub

Public Sub Pop(ByRef Value As Long)
Value = Stack(SP)
SP = SP - 1
End Sub

And here is the code for Form1
Code:

Private Sub Form_Load()
Randomize
SP = -1
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button <> 1 Then Exit Sub
If Check1.Value Then FloodFill X, Y Else PSet (X, Y)
End Sub

Public Sub FloodFill(ByVal X0 As Long, ByVal Y0 As Long)
Dim X As Long
Dim Y As Long
Dim n As Long
Dim RefCol As Long
Dim FillCol As Long

RefCol = Me.Point(X0, Y0)
Do
    FillCol = RGB(Int(Rnd * 256), Int(Rnd * 256), Int(Rnd * 256))
Loop Until FillCol <> RefCol

Push Y0
Push X0


Do Until SP = -1
    Pop X
    Pop Y
    If Point(X, Y) = RefCol Then
        PSet (X, Y), FillCol
        n = n + 1
        If n Mod 10000 = 0 Then
            Refresh
            If n Mod 100000 = 0 Then DoEvents
        End If
        If Point(X, Y - 1) = RefCol Then
            Push Y - 1
            Push X
        End If
        If Point(X, Y + 1) = RefCol Then
            Push Y + 1
            Push X
        End If
        If Point(X - 1, Y) = RefCol Then
            Push Y
            Push X - 1
        End If
        If Point(X + 1, Y) = RefCol Then
            Push Y
            Push X + 1
        End If
    End If
Loop
Form1.Caption = n
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If (Button = 1) And (Check1.Value = 0) Then Line -(X, Y)
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If (Button = 1) And (Check1.Value = 0) Then PSet (X, Y)
End Sub

The only things you need to do to Form1 to make this work are add a checkbox control, change the form's ScaleMode to Pixel, and change the form's AutoRedraw property to True.

Draw shapes with the checkbox unchecked, and then click inside the shapes you draw after making the checkbox checked, to fill the shapes you have drawn.

[VB6] API File Drag from multiple paths w/o native OLE or dragsource, SHDoDragDrop

$
0
0


It took many months of wasting hours, giving up, and revisiting to finally get a working solution, and the only previous VB solution was monstrously complex. I understand very few people will find this useful, but wanted to share anyway due to the lack of answers I found while trying to get it working and the simplicity over other solutions.

Background
DragDrop functionality is easy if you're using, say, VB's ListView, but what if you're using a ListView created via CreateWindowEx that has no OLEStartDrag/OLESetData with pre-provided DataObject, and want to start a drag operation that can be dragged around Windows Explorer (or any drop target accepting dropped files)? Previous solutions have used the DoDragDrop API and then had to implement their own IDataObject and IDropSource interfaces, and I had yet to see one that supported multiple paths. Turns out that unless you require other-than-default behavior, you accomplish a full drag-to-explorer operation in just a few lines of code. The SHDoDragDrop API provides both a default drag source and a default drag icon showing the number of files, just like Explorer. It also supports the action options menu if you drag with the right button. And no further action is required, the receiving program handles the operation.

The included sample project doesn't use any subclassed/CreateWindowEx ListViews, but does show how you can initiate the operation from any arbitary point in code given a list of files.

Requirements
This code does require a typelib with the IDataObject interface such as olelib (either the original or my expansion) or OLEGuids to be added as a reference. Works with XP and above.

For the purposes of the below code, we'll assume you have your own routine to enumerate the full paths of the files that are selected. This code will typically be for a Begin Drag notification, such as LVN_BEGINDRAG.

Code:

Public Sub InitDrag(sSelFullPath() As String)
Dim hr0 As Long
Dim iData As IDataObject
Dim apidl() As Long
Dim cpidl As Long
Dim rpidl As Long
Dim pidlDesk As Long
Dim lRetDD As Long
Dim i As Long
Dim AllowedEffects As DROPEFFECTS
Call SHGetSpecialFolderLocation(0, CSIDL_DESKTOP, pidlDesk) 'we support multiple paths by creating an IDataObject with the desktop as the root and then supplying fully qualified pidls rather than child pidls

'EnumSelectedFiles - Whatever routine you have to get your selected files list, a standard routine like
'  Do
'    i = ListView_GetNextItem(hLVS, i, LVNI_SELECTED)
'    If (i <> LVI_NOITEM) Then
ReDim apidl(UBound(sSelFullPath)) 'sSelFullPath would then contain the full path to the file, C:\folder\file.ext, //Computer/folder/file.ext
For i = 0 To UBound(apidl)
      apidl(i) = GetPIDLFromPathW(sSelFullPath(i)) 'support function to return fully qualified pidls for each file, see below
Next i
cpidl = UBound(apidl) + 1
Call SHCreateDataObject(pidlDesk, cpidl, VarPtr(apidl(0)), ByVal 0&, IID_IDataObject, iData) 'even though the desktop pidl is just the zero-terminator, don't confuse that with passing zero instead of this-- results in an invalid drag source that can't be dropped anywhere
If iData Is Nothing Then
    Debug.Print "Failed to created IDataObject"
    Exit Sub
End If
           
AllowedEffects = DROPEFFECT_COPY Or DROPEFFECT_MOVE Or DROPEFFECT_LINK

hr0 = SHDoDragDrop(0&, ObjPtr(iData), 0, AllowedEffects, lRetDD) 'theoretically you can supply your own IDropSource implementation, but I never got it working

Debug.Print "hr0=" & hr0 & ",lRet=" & lRetDD 'hr0 contains the HRESULT of the call, and lRetDD is the result of the operation, see the full DROPEFFECT description for all possible values
Call CoTaskMemFree(pidlDesk)
For i = 0 To UBound(apidl)
    Call CoTaskMemFree(apidl(i))
Next i
Set iData = Nothing

End Sub
'If instead this is in a WndProc, you'll probably want to cancel the notification by returning 1 and exiting before a DefWndProc call.

'Supporting declares and functions:
Public Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hWndOwner As Long, ByVal nFolder As Long, pidl As Long) As Long
Public Const CSIDL_DESKTOP = &H0
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long) ' Frees memory allocated by the shell

Public Declare Function SHCreateDataObject Lib "shell32" (ByVal pidlFolder As Long, ByVal cidl As Long, ByVal apidl As Long, pdtInner As Any, riid As UUID, ppv As Any) As Long
Public Declare Function SHDoDragDrop Lib "shell32" (ByVal hWnd As Long, ByVal pdtObj As Long, ByVal pdsrc As Long, ByVal dwEffect As Long, pdwEffect As Long) As Long
Public Declare Function ILCreateFromPathW Lib "shell32" (ByVal pwszPath As Long) As Long
Public Function GetPIDLFromPathW(sPath As String) As Long
  GetPIDLFromPathW = ILCreateFromPathW(StrPtr(sPath))
End Function
Public Function IID_IDataObject() As UUID
'0000010e-0000-0000-C000-000000000046
Static IID As UUID
 If (IID.Data1 = 0) Then Call DEFINE_UUID(IID, &H10E, CInt(&H0), CInt(&H0), &HC0, &H0, &H0, &H0, &H0, &H0, &H0, &H46)
  IID_IDataObject = IID
End Function
Public Sub DEFINE_UUID(Name As UUID, l As Long, w1 As Integer, w2 As Integer, B0 As Byte, b1 As Byte, b2 As Byte, B3 As Byte, b4 As Byte, b5 As Byte, b6 As Byte, b7 As Byte)
  With Name
    .Data1 = l
    .Data2 = w1
    .Data3 = w2
    .Data4(0) = B0
    .Data4(1) = b1
    .Data4(2) = b2
    .Data4(3) = B3
    .Data4(4) = b4
    .Data4(5) = b5
    .Data4(6) = b6
    .Data4(7) = b7
  End With
End Sub

You can specify your own drag image with something like LVM_CREATEDRAGIMAGE, but when dragged into Explorer the standard one is overlayed on top of it, here's a simple technique that creates a drag image of the selected items icon:
Code:

'from http://www.mvps.org/emorcillo/en/code/vb6/listviewdragdropimage.shtml
Public Sub ListView_StartDrag( _
  ByVal hWndListView As Long, _
  Optional ByVal X As Long = 20, _
  Optional ByVal Y As Long = 20)
Dim tPoint As POINTAPI
Dim LITEM As Long

  ' Get the selected item
  LITEM = SendMessage(hWndListView, LVM_GETNEXTITEM, -1, ByVal LVNI_SELECTED)

  ' Get a ImageList with
  ' the drag image
  m_lIL = SendMessage(hWndListView, LVM_CREATEDRAGIMAGE, LITEM, tPoint)

  ' Start the image dragging
  ImageList_BeginDrag m_lIL, 0, X, Y
  ImageList_DragEnter 0, 0, 0

  ' Start the timer
  m_lTimer = SetTimer(0, 0, 1, AddressOf pvTimerDragMove)

End Sub
Public Sub DragComplete()
 
  ' Stop the timer
  KillTimer 0, m_lTimer

  ' End the image dragging
  ImageList_EndDrag
 
  ' Destroy the ImageList
  ImageList_Destroy m_lIL
 
End Sub
Private Sub pvTimerDragMove( _
  ByVal hWnd As Long, _
  ByVal uMsg As Long, _
  ByVal idEvent As Long, _
  ByVal dwTime As Long)
Dim tPoint As POINTAPI
 
  ' Get the cursor position
  GetCursorPos tPoint

  ' Move the image to the new cursor position
  ImageList_DragMove tPoint.X, tPoint.Y
 
End Sub

Attached Files

[VB6] GDI+ Matrix For Rotation/Scale/Shear and Hit Testing

$
0
0
GDI+ offers a matrix object that can be applied to various other GDI+ objects. One of those is the Graphics object (similar to GDI's hDC). With a matrix, we can simultaneously scale, rotate, shear & offset/translate a rendering in basically one call.

The attached offers such options in a simple sample project. The matrix is created and can be cached for all future rendering, unless of course something changes and the matrix should be recreated. What's kind of neat is that an inverted copy of the matrix can be used for hit testing on the rotated, scaled, sheared, translated rendering relative to the original object, un-rotated, un-scaled, un-sheared, un-translated.

Please read the comments included in the code, especially within the pvCreateDisplayMatrix routine, before asking questions about the code

Name:  Untitled.jpg
Views: 96
Size:  44.6 KB


Just some notes. When rotating and not choosing both horizontal & vertical center alignment, keep in mind that you are rotating around a specific point on the edge of the picturebox. The top/left pixel of the image is where rotation begins within the image, not the center of the image. Should anyone want to rotate this way, obviously, the edges of the viewing area would not be a good point to begin rotation from, therefore the pvCreateDisplayMatrix allows an optional point to be passed. But since the sample project uses the edges of the viewing area if not centering rotation, the following is provided:

- Alignment determines point of rotation
- Point of rotation is optional passed parameters to function or, if no parameters passed, relative to display area

Center/Center :: rotation is from center of image over the point of rotation
any other combination :: rotation is from top/left pixel of image around the the point of rotation

So, let's say you have horizontal alignment on right edge & vertical alignment on bottom edge, ok? Well, the picturebox is now only displaying the northwest quadrant of the 360 degree rotation area. The other 3 quadrants are off the picturebox. If you try to rotate image at 45 degrees around the bottom/right corner, the rendering would fall in the southeast quadrant and not viewable. Angles from 180 to 269 would be the northwest quadrant.
Attached Images
 
Attached Files

VB6 + vbRichClient5 (lightweight, fully Alpha-aware Windowless-Controls)

$
0
0
Just a short Demo, to show how to write Alpha-aware, Windowless-Controls,
using Cairo-Drawing against a (Control-covering) BackBuffer-Surface (avoiding
AutoRedraw on the Control itself).

Note, that this is not using the RC5-WidgetEngine (which allows windowless controls
as well, but implemented in normal VB6-Classes) - here a normal VB6 (Project-Private)
Usercontrol is sufficient (only making use of the Raw-Drawing-capabilities of Cairo internally).

Tried for a BareBones-approach to keep the example easy to understand
(the whole Demo is only about 80 lines of code total).

What's interesting maybe (aside from the Cairo-Drawing), is the usage of the
RC5-Properties Enumerator, which allows (in a generic way) to write and read the 3
Properties of the Control (Alpha, ImgKey and Moveable) to and from the PropertyBag.

ScreenShot:



And Download-Link:
WindowlessControlsCairo.zip

Have fun,

Olaf
Attached Files

VB6 fast EdgeDetection (direct Pixel-Manipulation on Cairo-Surfaces)

$
0
0
Whilst cairo is known as a VectorGraphics-Library - it supports fast Blending-Operators
on its Pixel-Surfaces (aka ImageSurfaces) - and most wrappers around this library will
offer (in addition to cairos blending-ops) a few additional Pixel-Massaging-Methods.

The vbRichClient has 6 of that category already implemented:
- cCairo.PreMultiplyAlpha
- cCairo.DeMultiplyAlpha
- cCairoSurface.FastBlur
- cCairoSurface.GaussianBlur
- cCairoSurface.Sharpen
- cCairoSurface.AdjustColors (Brightness, Contrast, Gamma - all in one routine)

Now, there's certainly much more pixel-algorithms out there in the wild -
but the above few are what I restricted myself to, since they are often needed.

To accomodate those who want to perform their own PixelOps on those Surfaces, I've choosen
to make pixel-access as easy as possible - and so there exist two Array-Binding-Methods:
- cCairoSurface.BindArray(ByteArray) ... and its companion .ReleaseArray ByteArray
- cCairoSurface.BindArrayLong(LongArray) ... and its companion .ReleaseArrayLong LongArray

This is done without copying any Data - I guess the underlying SafeArray-technique is quite
wellknown in the meantime - and the Arrays in question need to be dynamic and uninitialized ones.

Well, that said - let's look at what the Demo has to offer:
Edge-Detection is a wide field - and I decided not to implement "the whole bunch of algos for comparison",
instead I concentrated on a very simple one (the "Roberts-Cross") - with focus on performance.

Since the algorithm is so simple (only using a small 2x2 Kernel), it was quite easy to avoid an
"inner Kernel-Loop" - and since the Formulas were not all that complex in this case too, coming
up with some Lookup-Tables for them was also relative easy to accomplish.

I've tuned it a bit though:
Instead of a SquareRoot on the "squared differences", I found that a logarithmic scaling produced
somewhat nicer results - and since the kernel is so small (compared to Sobel, Prewitt & Co.), the
algo captures fine details quite well, but tends to be "noisy" - so, a slight (and fast) PreBlurring was
added into the processing-queue, to remedy that.

For comparison (direct links instead of the forums img-tag, to get "the real image" -
and to easier compare - after loading them all - by just clicking between Browser-Tabs):
https://softwarebydefault.files.word..._grayscale.jpg
https://softwarebydefault.files.word..._grayscale.jpg
http://vbRichClient.com/Downloads/Lo...ithPreBlur.png

The last link of the above three, was generated with the Demo.

Performancewise, the Algo (including the steps: PreBlur, GreyScaling, LogarithmicRoberts, GammaCorrection, Sharpen)
takes in Sum only about 20msec total when native compiled (performing all steps on a 800x600 TrueColor-Image).

The Demo includes a few Demo-Images - here some ScreenShots:

Monarch-Original-Image:


Monarch-EdgeDetected and in ColorMode (algo performed on each color-channel separately).
The GreyScale-Result-Link I've posted already further above...


And another Result of one of the Demo-Images in Color-Mode:


Here's the Source-Zip:
EdgeDetection.zip

Have fun,

Olaf
Attached Files

Exporting crystal report generated from vb6 straight to pdf without the viewing...

$
0
0
Private Sub cmdView_Click(Index As Integer)
Select Case Index
Case 0
If Me.optRR(0).Value = True Then irisreports (16)
If Me.optRR(1).Value = True Then irisreports (17)
If Me.optRR(2).Value = True Then irisreports (18)
If Me.optRR(3).Value = True Then irisreports (19)
If Me.optRR(4).Value = True Then irisreports (20)
If Me.optRR(5).Value = True Then irisreports (21)
If Me.optRR(6).Value = True Then irisreports (22)

If Me.optTransfer(0).Value = True Then irisreports (23)
If Me.optTransfer(1).Value = True Then irisreports (24)
If Me.optTransfer(2).Value = True Then irisreports (25)
If Me.optTransfer(3).Value = True Then irisreports (26)
If Me.optTransfer(4).Value = True Then irisreports (27)
If Me.optTransfer(5).Value = True Then irisreports (28)
If Me.optTransfer(6).Value = True Then irisreports (29)
Case 1
If Me.optEndingInv(0).Value = True Then irisreports (12)
If Me.optEndingInv(1).Value = True Then irisreports (13)
If Me.optEndingInv(2).Value = True Then irisreports (14)
If Me.optEndingInv(3).Value = True Then irisreports (15)
If Me.optEndingInv(4).Value = True Then irisreports (33)
Case 2
If Me.optCGS.Value = True Then
generateAverageCost
irisreports (30)
End If
If Me.optSalesSummary(0).Value = True Then irisreports (31)
If Me.optSalesSummary(1).Value = True Then irisreports (32)
'mat 08082006
If Me.optReportToGenerate(6).Value = True Then irisreports (46)

If Me.optReportToGenerate(0).Value = True Then irisreports (35) 'product breakdown
If Me.optReportToGenerate(1).Value = True Then irisreports (36) 'daily sales report net
If Me.optReportToGenerate(2).Value = True Then irisreports (40) 'daily sales report gross
If Me.optReportToGenerate(3).Value = True Then irisreports (37) 'tender department
If Me.optReportToGenerate(4).Value = True Then irisreports (38) 'sales register
If Me.optReportToGenerate(5).Value = True Then irisreports (39) 'gross profit

If Me.optSalesReceiptsWithTender.Value = True Then irisreports (60)
If Me.optSalesReceiptNumbers.Value = True Then irisreports (61)
If Me.optVATSales.Value = True Then irisreports (63)


Case 3
If Me.optJournal.Value = True Then irisreports (34)
Case 4
If Me.OptInventoryAdjustment.Value = True Then irisreports (62)


End Select

End Sub

How to track TextBox carot position, notify use if text1.SelStart = Len(text1.Text)

$
0
0
On the Form two ListBoxes are displayed side by side and a TextBox is on the right side.
ListBox 2 is displayed having several CheckBoxes. When the user clicks on a CheckBox,
from Private Sub List2_Click() I use selItem = List2.ListIndex to select an Article in a .txt file. Many times the length of the Article is too great to be assigned to text1.Text so I divide it into portions using .Text = Mid(Art, (thisPortion * ArtMaxSize ) + 1, ArtMaxSize), where thisPortion starts out as 0 and ArtMaxSize = the maximum length of text1.Text.
The TextBox is Locked (Read-Only).
I tried to track the TextBox carot position with a Do Loop before List2_Click() End Sub:
Do
Select Case text1.SelStart
Case 0 'at beginning of thisPortion
'InputBox(Read previous portion of Article Y/N)
Case Len(text1.Text)
' InputBox(Read next portion of Article Y/N)
'if yes then go to next portion, thisPortion=thisPortion +1
Case Else
'Let user move around in TextBox
End Select
Loop

The Do Loop causes the Form with the two ListBoxes and the TextBox not to be displayed. Do I need to Set the Focus on the TextBox before going into the Do Loop or is there a better way to track the TextBox carot position? I also tried using a Private Sub text1_KeyDown(KeyCode as Integer, Shift As Integer) to trap the navigation keys and setting the carot location for vbKeyLeft, VbKeyRight, etc. but this seemed more difficult to code.
Maybe someone knows of a Windows API for vb6 where I can track the TextBox carot position while moving around in the TextBox and notify the user when reaching the end of this portion, e.g. "Please Wait, Loading Portion 3 of 5."
Please help.
Thanks,
John

VB6 compact Charting-Class (using an InMemory-DB as the DataStorage for x,y-Plots)

$
0
0
This Demo is making use of the Cairo-Drawing-, as well as the InMemory-DB-features of vbRichClient5.

Background:
Although the contained cChart-Class is able to render any x,y-ValuePairs - often one has to
handle and store "timestamp-based Data", as e.g. from a "Stock-Exchange-Ticker" (when the
y-Values are Prices) - or from a "Data-Logger" of a measurement-device (where y-Data comes
in as more "physically related units"...

Though in both cases we have some kind of time-values in the x-Members of the x,y-Pairs -
and the amount of data can get quite large "over time".

So, a DB-based storage is not only useful to "archive and persist" such x,y-Pairs (on Disk) -
it is also useful, to make use of "time-range-queries".

These are usually queries which start from the most recent TimeStamp-Value in the DB-Table,
then covering a certain range "to the left of this RightMost-x,y-Pair".

E.g. "Show me a Chart for all the Values in the last hour" (or the last day, or the last week, etc.)

Now one might say: "Yeah - a DB and SQL-queries would be nicer to use - but for my small project
I don't want to introduce a DB-Engine, just for more comfortable Charting..."

Well, and this is the scenario where an InMemory-DB makes sense - offering all of the benefits
of a full DB-Engine, at basically no cost - later on (in case persisting of the Data on Disk becomes
a topic) - the App would be upgradable to a filebased-DB just by changing the DB-Creation-Line.

What's nice with DB-Engines in general, is that they offer a robust and convenient way, to
perform "grouping aggregations" - which is useful for Charting, in case one wants to visualize
trends, averages, Min- and Max-Values etc.

With SQL one can handle such tasks quite nicely and efficient in one single statement,
as e.g. this one here, which I used in the Demo, to do Grouping on the x.y-Pairs
with regards to Average, Min- and Max-Values - and the time-range (starting from
a MaxDate, then reaching parts - or multiples - of HoursBack into the DataStorage.

Code:

Private Function GetData(ByVal MaxDate#, Optional ByVal HoursBack# = 1, Optional ByVal GroupingSeconds& = 60) As cRecordset
  With New_c.StringBuilder
    .AppendNL "Select Avg(TS) AvgT, Avg(Price) AvgP, Min(Price) MinP, Max(Price) MaxP From Ch1"
    .AppendNL "Where TS Between " & Str(MaxDate - HoursBack / 24) & "+1e-6 And " & Str(MaxDate)
    .AppendNL "Group By CLng(0.500001 + TS*24*60/" & Str(GroupingSeconds / 60) & ") Order By TS"

    Set GetData = MemDB.GetRs(.ToString)
  End With
End Function

Important for InMemory-Usage of DB-Engines is, that they can be filled with Data fast (being
roughly at "Dictionary-Level") - and with SQLite that is a given, as the following ScreenShot
shows ... second-based values of two full days (2*86400) were transferred into the DB in
about 370msec, included in this case also the time, to create an index on the TimeStamp-column.



The above ScreenShot shows also, how the Min- Max- and Avg-Values are rendered finally -
due to the index we build at the time of data-import, we can then perform fast
querying and rendering in typically 10-30msec per complete Chart...

Below is another Picture, which shows the timing, needed for both (querying and rendering),
and at this occasion also how the same Data will be rendered with cChart, when certain
Options are changed (no BSpline, no Min-Values, no Max-Values - note the automatic
scaling of the Y-Axis, which now covers a different value-range):



Here's the Demo-Zip:
SimpleCharting.zip

So, yeah - and as is normal for RichClient-based code, the whole thing is quite compact -
cChart.cls, as well as the second Code-Module (fMain.frm) contain both less than 100 lines of code...
have fun adapting it to your needs.


Olaf
Attached Files

Well I did it. WMP Remoting in VB6, Change Vis, Control EQ Etc

$
0
0
Not sure where to put this, but I figured here would be as good a place
as any. Mods, do what you must if not lol :chuckle:

I sat down last week, 11 years after I actually needed it lol, and figured out how to remote Windows Media Player and control the visualizations, equalizer, and other things.

In case anyone finds it useful, I release it into the wild..

Here guys, feedback welcome.

Frodo



https://github.com/bagginsfrodo/VB6-...eMediaServices



Here is a copy of the readme, might explain a bit:

Code:

'Readme.txt
'©2015 Kevin Lincecum AKA FrodoBaggins  email: baggins DOT frodo AT_SYMBOL gmail DOT com
'License: Free usage as long as you send me an email and mention me somewhere in your readme, about, etc



Hi, I'm Kevin Lincecum, aka frodobaggins. A long time ago I developed a car pc application for
playing media and other things. "FrodoPlayer" if you want to search for it. Like a lot of beginning
programmers, I chose VB to do my programming in, mainly because of the rapid application development
aspect of it. I never really encountered any difficulties with the project, except when it came to
doing advanced stuff with windows media player. I used windows media player as the "engine" of my
media playing project, and for the most part, it was great. However, my users and I eventually wanted
to change the visualizations, and use the equalizer. Well Microsoft says you can't from VB..or
really from C++ either.

But it turns out you can, IF you use the remoting services to host the control in local mode, then
you can skin the player, and control the objects through the skin. BUT, Microsoft says you can't remote
the control in VB, only in C++. Well I didn't accept this then, or now. I searched off and on for a long
time trying to figure it out, even after I let that part of my life go, that application long behind me.
It still bothered me even years later, and after some more searching, it seems that no one else figured
it out, or did, but didn't share it ! Grrrr!

Recently, I was looking over some things where I had been playing with doing this in .NET. I had it working
pretty good there, and it got me interested in doing it in VB6. It turns out it's not that difficult to do
and most of the information on how to do it was in the documentation the whole time, I just wasn't looking
well enough.

Anyway, here's how it was done.

When I was looking before, an aquaintence I knew from the MP3Car forums, Chuck Holbrook, aka godofcpu, posted
in a microsoft mailing list some hints on how to control the visualization from C++ once the player was remoted.
It didn't seem to difficult to implement if I could get the player remoted, but getting the player remoted was
the real problem.

Microsoft says you can't remote the player in anything but C++. We all know that's bull, but figuring it out is
a bear. (Even though the information was actually in the docs![not for vb]) Well screwing around a few years ago
I wanted to do it in vb.net, so I began the search anew. I ran across Eric Gunnersons page which led me to a post
by Jonathan Dibble on how to remote the player in C#. It was pretty trivial to convert this code to VB.Net, and
soon I had a remoted player.

A short time after, I had complete control of the visualizations and EQ (thanks to the hints before from godofcpu)
in VB.NET. I was overjoyed, and used it a bit in some personal projects. I wondered then if I could back port it
to VB6, but never got very far because life got in the way. It happens!

Fast forward to a few days ago, and I decided, better late than never. I looked at the code again, and the docs
again. The lights went off in my head. The docs and code samples from .NET said I needed to implement
IWMPRemoteMediaServices, and IServiceProvider. To use IServiceProvider, I also needed to implement IOleClientSite.

So I first made a new type library with for VB with the IWMPRemoteMediaServices interface, then made a class
from the interface.

I started to make another TypLib for IOleClientSite, and IServiceProvider, but then remembered Eduardo A. Morcillo
aka Edanmo, had done some excellent work in the OLE area. Browsed google to find his website "Namespace Edanmo,"
and sure enough, he had two excellent ole type libraries with the definitions already there!

I implemented all the interfaces, tied it all together with ductape, spit, and bubblegum, and called SetClientSite on
the WMP Control... And BAM, I got a call to my IServiceProvider interface. I wired that up to my IWMPRemoteMediaServices
interface and that worked too. (Several crashes later).

Now I made a simple skin from my old VB.Net code I knew worked, and tried wmp.uimode = "custom"..
It didn't work.
For a long time.
And longer.
Then I realized my skin was *****.
So I fixed it, and HOLY MF CRAP IT WORKED. I EVEN PASSED IT A SCRIPTABLE OBJECT.
GOT INFO BACK FROM IT! WOOT!!

I celebrated.

Then I wrote the skin up properly to pass the visualization objects and eq back to my test code, and a few lines later,
that worked too!

I celebrated some more. I realize this is an OLD issue, but I was still excited.

Now a little while after that, I realized how stressed I had been back then that no one seemed to want to help with this
issue, and decided that it was time to show the world, just in case it was still usefull.


So, I have coded up a nice little test harness with I hope all the pieces to the puzzle for you to peruse and
use to your hearts content. All I ask for in return is if you actually use any of this, or find this helpful,
that you mention me somewhere in your about box, readme, etc. You probably want to mention some of the others too,
depending on what you do with it.


Better late than never,
Kevin Lincecum
AKA frodobaginns
baggins DOT frodo AT_SYMBOL gmail DOT com





P.S. This project is not meant to be a documentation of using wmp in a custom program, there are plenty of
examples on how best to do that.

Also, read the comments. It's real easy if you are not careful to cause an improper teardown (aka crash) of objects with this code.
I may in the future, or you may (I suggest) to wrap this up in a custom control or something to remove these obstacles from
your main app. Get it right, then just use it!

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: 39
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: 37
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.
Viewing all 1540 articles
Browse latest View live


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