Run VB application via VBA

[jignesh142]

I have one vb application exe file which i want to run through the vba, is it possible?

the vb application have only one button and that is start/stop. Now i want to put one command button in excel file, when i press this command button, it should open the vb application and press its start button to run the application. i want to put another command button to press stop button of this vb application and close this application. The name of this exe file is "sgs.exe"

Please note that vb application have only one button and that is Start/Stop. When i press start its caption turned to stop and when i press stop its caption turns in start.

Is it possible?

[Bob Phillips]

Why not just add all the functionality to your VBA?

[jignesh142]

Well,

The VB application is a sound generation software which takes the frequency data from the excel file and plays the musical notes from that.

I don't think so that excel VBA has the functionality of producing such notes by generating the sine wave sound with directx. And that's why i can not incorporate into VBA

[Bob Phillips]

Surely, it is just API calls, so VBA can do that.

[Kenneth Hobs]

As xld said, I doubt that you can not do what you need in VBA.

It would be a bad idea to control the exe from vba. Just shell to it and make that application handle start stop.
Private Sub CommandButton1_Click()
Shell ThisWorkbook.Path & "\sgs.exe"
End Sub

[jignesh142]

I don't know how to use the directx in VBA, it is not the same methodology that we use in VB.
My earlier wish was that to develop such application in VBA only, but the procedures and the methods are not working as same as VB.
I don't know how to generate sine wave of desired frequency with the help of the directx. I posted the thread regarding this in this forum but nobody replied so i thought that it would not be possible in VBA.
I agree with xld that it is API call, even my VB use the API, but how to use this in VBA, i don't know.
Thanks for the Kenneth for showing me the path,i can use this as temporary use until to develop fully in VBA.
Thanks for your answers.

[Bob Phillips]

You could post the VB code and your Excel workbook and we could try and help integrate in VBA for you.

[jignesh142]

Here is my code--API.BAS

Option Explicit

' Oscillator_Frequency
Public Const O2F As Long = 450
Public Const SPS As Long = 44100

Public dsbBuffer(1) As DirectSoundBuffer
Public dsMain As DirectSound
Public dx7Main As New DirectX7
Public yPlayBuf() As Byte

Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function GetForegroundWindow Lib "user32" () As Long
Public Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private lSamples As Long

Public Sub Make440Hz()

Dim iI As Long
Dim nGsx As Single

lSamples = SPS / O2F
ReDim yPlayBuf(lSamples) As Byte

nGsx = 4 * Atn(1) * 2 / lSamples
For iI = 0 To lSamples
yPlayBuf(iI) = (Sin(iI * nGsx) * 127) + 128
Next iI

End Sub

Public Sub dsbWrite(Index As Integer, ByRef Buffer() As Byte)
' Writing an array of bytes to a given DirectSoundBuffer.
Call dsbBuffer(Index).WriteBuffer(0, lSamples, Buffer(0), DSBLOCK_ENTIREBUFFER)
End Sub

Public Sub DX7Initialize(lHwnd As Long)

Dim dbdMain As DSBUFFERDESC
Dim wfePCM As WAVEFORMATEX

' Create the DirectSound Object
Set dsMain = dx7Main.DirectSoundCreate("")

' DSSCL_NORMAL other applications can use the sound card
' DSSCL_EXCLUSIVE only i can use the sound card
' Set the Cooperative Level
Call dsMain.SetCooperativeLevel(lHwnd, DSSCL_NORMAL)

' Fill WaveFormat Structure
wfePCM.nFormatTag = WAVE_FORMAT_PCM
wfePCM.nChannels = 1
wfePCM.lSamplesPerSec = SPS
wfePCM.nBitsPerSample = 8
wfePCM.nBlockAlign = 1
wfePCM.lAvgBytesPerSec = wfePCM.lSamplesPerSec * wfePCM.nBlockAlign
wfePCM.nSize = 0

' DSBCAPS_CTRLPAN enables Pan, DSBCAPS_CTRLVOLUME enables volume control
dbdMain.lFlags = DSBCAPS_STATIC Or DSBCAPS_CTRLVOLUME Or DSBCAPS_CTRLFREQUENCY Or DSBCAPS_CTRLPAN
' set Bytes
dbdMain.lBufferBytes = lSamples

'********************************************************
' Create Buffers
Set dsbBuffer(0) = dsMain.CreateSoundBuffer(dbdMain, wfePCM)
Set dsbBuffer(1) = dsMain.CreateSoundBuffer(dbdMain, wfePCM)

' Initialize to play loop DSBPLAY_LOOPING
Call dsbBuffer(0).Play(DSBPLAY_LOOPING)
' (DSBPLAY_DEFAULT would play the sound only one time)
Call dsbBuffer(1).Play(DSBPLAY_LOOPING)

End Sub

' Clear the created dx7Main Objects.
Public Sub DX7Terminate()

Set dsbBuffer(0) = Nothing
Set dsbBuffer(1) = Nothing
Set dsMain = Nothing
Set dx7Main = Nothing

End Sub

Public Sub MakeHzTest(ByVal nFreq As Double)

Dim dbdTest As DSBUFFERDESC
Dim iI As Long
Dim nGsx As Single
Dim wfePCM As WAVEFORMATEX

lSamples = nFreq
ReDim yPlayBuf(lSamples) As Byte

For iI = 0 To lSamples
yPlayBuf(iI) = 0
Next iI

' Fill WaveFormat Structure
wfePCM.nFormatTag = WAVE_FORMAT_PCM
wfePCM.nChannels = 1
wfePCM.lSamplesPerSec = lSamples
wfePCM.nBitsPerSample = 8
wfePCM.nBlockAlign = 1
wfePCM.lAvgBytesPerSec = wfePCM.lSamplesPerSec * wfePCM.nBlockAlign
wfePCM.nSize = 0

dbdTest.lFlags = DSBCAPS_STATIC Or DSBCAPS_CTRLVOLUME Or DSBCAPS_CTRLFREQUENCY Or DSBCAPS_CTRLPAN
dbdTest.lBufferBytes = lSamples

' ReCreate Buffers
Set dsbBuffer(0) = Nothing
Set dsbBuffer(1) = Nothing

Set dsbBuffer(0) = dsMain.CreateSoundBuffer(dbdTest, wfePCM)
Set dsbBuffer(1) = dsMain.CreateSoundBuffer(dbdTest, wfePCM)

Call dsbBuffer(0).SetFrequency(lSamples)
Call dsbBuffer(1).SetFrequency(lSamples)

Call dsbBuffer(0).Play(DSBPLAY_LOOPING)
Call dsbBuffer(1).Play(DSBPLAY_LOOPING)

End Sub


The Main Forum Code

Option Explicit

Private Const xlCellTypeLastCell As Long = 11

Private Sub Main()
On Error Resume Next

Dim lFgw As Long
Dim lFreq As Long
Dim lRet As Long
Dim lRow As Long
Dim nDuration As Single
Dim nFreq As Single
Dim xclApp As Object
Dim wbW As Object
Dim wsW As Object

Set xclApp = CreateObject("Excel.Application")
If (xclApp Is Nothing) Then
lblStatus.Caption = "0x" & Hex(Err.Number) & " - " & Err.Description
Exit Sub
End If

Set wbW = xclApp.Workbooks.Open(FileName:=txtXls.Text, AddToMru:=False)
If (wbW Is Nothing) Then
lblStatus.Caption = "0x" & Hex(Err.Number) & " - " & Err.Description
GoTo ExitSub
End If

Set wsW = wbW.Worksheets(1)
For lRow = 1 To wsW.range("A1").SpecialCells(xlCellTypeLastCell).Row

nFreq = wsW.range("A" & lRow).Value
nDuration = wsW.range("B" & lRow).Value
If (nFreq = 0) Or (nDuration = 0) Then Exit For

lblStatus.Caption = " Playing " & wsW.range("C" & lRow).Value & " (" & wsW.range("A" & lRow).Value & " Hz) for " & Replace(nDuration, ",", ".") & " sec..."
DoEvents

lFreq = CLng(CDbl(nFreq) / CDbl(O2F) * CDbl(SPS))
Call dsbBuffer(0).SetFrequency(lFreq)
Call dsbBuffer(1).SetFrequency(lFreq)
If (lRow = 1) Then

' Call dsbBuffer(0).SetVolume(-1800)
' Call dsbBuffer(1).SetVolume(-1800)
Call dsbWrite(0, yPlayBuf())
Call dsbWrite(1, yPlayBuf())

End If

nDuration = Timer + nDuration
Do While (nDuration >= Timer)

DoEvents
Call Sleep(1)

lFgw = GetForegroundWindow()
If (lFgw > 0) Then Call dsMain.SetCooperativeLevel(lFgw, DSSCL_NORMAL)

If (Not cmdStartStop.Enabled) Then Exit Do

Loop
If (Not (cmdStartStop.Enabled)) Then Exit For

If (LCase(Command = "/s")) Then Call SaveScreen(wsW.range("C" & lRow).Value)

Next lRow

ExitSub:
If (Not (wsW Is Nothing)) Then Set wsW = Nothing

If (Not (wbW Is Nothing)) Then
Call wbW.Close(False)
Set wbW = Nothing
End If

If (Not (xclApp Is Nothing)) Then
xclApp.Quit
Set xclApp = Nothing
End If

End Sub

Private Sub SaveScreen(sVoice As String)

Dim dcDesktop As Long
Dim hwndDesktop As Long
Dim iP As Integer

hwndDesktop = GetDesktopWindow()
dcDesktop = GetWindowDC(hwndDesktop)
Call BitBlt(picTest.hDC, 0, 0, picTest.Width / Screen.TwipsPerPixelX, picTest.Height / Screen.TwipsPerPixelY, dcDesktop, Me.Left / Screen.TwipsPerPixelX, Me.Top / Screen.TwipsPerPixelY, vbSrcCopy)
If (Mid(sVoice, Len(sVoice) - 1) = "-") Then
iP = 2
Else
iP = 1
End If

Call ReleaseDC(hwndDesktop, dcDesktop)

End Sub

Private Sub cmdStartStop_Click()

Dim lRet As Long
Dim nTest As Single

If (cmdStartStop.Caption = "&Start") Then

cmdStartStop.Caption = "&Stop"
Call DX7Initialize(Me.hWnd)
Main
DX7Terminate

cmdStartStop.Caption = "&Start"
If (cmdStartStop.Enabled) Then
lblStatus.Caption = " Finished."
Else
lblStatus.Caption = " Canceled by user."
cmdStartStop.Enabled = True
End If
If (Not Me.Visible) Then End

Else
cmdStartStop.Enabled = False
End If

End Sub

Private Sub Form_Load()

' Me.Left = 3780
' Me.Top = 180

picTest.Height = 500 * Screen.TwipsPerPixelY
picTest.Width = 900 * Screen.TwipsPerPixelX
picTest.Left = -picTest.Width - Screen.TwipsPerPixelX
picTest.Top = -picTest.Height - Screen.TwipsPerPixelY

dlgBrowse.InitDir = App.Path
txtXls.Text = App.Path & "\" & txtXls.Text
Make440Hz

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If (cmdStartStop.Caption = "&Stop") Then

Cancel = True
Me.Hide
cmdStartStop.Enabled = False

End If
End Sub

Private Sub Form_Resize()
On Error Resume Next
If (Me.WindowState <> vbMinimized) Then
txtXls.Width = Me.ScaleWidth - 78 * Screen.TwipsPerPixelX
lblStatus.Width = Me.ScaleWidth
End If
End Sub

Private Sub txtXls_DblClick()
On Error Resume Next

Err.Clear
dlgBrowse.ShowOpen
If (Err.Number <> 0) Then txtXls.Text = dlgBrowse.FileName

End Sub

Private Sub txtXls_GotFocus()
txtXls.SelStart = 0
txtXls.SelLength = Len(txtXls.Text)
End Sub

Private Sub txtXls_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error Resume Next

Dim sFile As String

sFile = Data.Files(1)
If (sFile <> vbNullString) Then txtXls.Text = sFile

End Sub

[jignesh142]

Hi,
Is it possible to incorporate the above code in VBA?

[jignesh142]

Hi,

I just want to know weather the above code can be incorporated in VBA?

[Kenneth Hobs]

When you do that, be sure to set the reference to DirectX.

[jignesh142]

I have set the reference to the Dx7 and Dx8 although i am using Dx7.

My main problem starts with the API that i have originally in the VB, how can i create the API in the VBA?

What i did is i have created the form like original VB program and put the code in that with one command button and text box, I have then put the above code in that form. After starting to debug that it gives me the errors.

The main errors are

dsbBuffer(1) As DirectSoundBuffer ---Error is the statement is invalid or outside the type block


yPlayBuf() As Byte ---Error is the statement is invalid or outside the type block

Also the Declare functions that used in API are also not allowed in the Public Declaration

[Jan Karel Pieterse]

PLease attach your workbook with the code you put into it so we can have a look.

[jignesh142]

Hi Jan,

I have posted the whole code in the earlier posts, however i am attaching the sheet in which i have copied the code.

Please go to developer-->Visual basic code to see the code

[Kenneth Hobs]

You must prefix those with Dim or Public when you declare them. Add the Compile button so that you can test those sorts of things.

If you make variables or functions Public, put them in a Module or Class Module or just make them Private for a Private object like the Userform.

' Oscillator_Frequency
Const O2F As Long = 450

Const SPS As Long = 44100

Public dsbBuffer(1) As DirectSoundBuffer
Public dsMain As DirectSound
Public dx7Main As New DirectX7
Public yPlayBuf() As Byte

Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Declare Function GetDesktopWindow Lib "user32" () As Long
Public Declare Function GetForegroundWindow Lib "user32" () As Long
Public Declare Function GetWindowDC Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

[jignesh142]

OK.
I have made the changes and i shifted my API.BAS to the module which now is not producing the errors and program runs successfully.

The main next error was me.hWnd, which is sorted by replacing it to

Application.ActiveWindow.hWnd- the program went successfully from there.

However my original program contains the textbox in which the excel file path is given to read the data from that. As VB Application has to create the object of excel.application in the original code.

I have made the similar form in the VBA and put the text box in that and changed the textbox name to my original VB application it gives me the error of "procedure declaration does not match the event or procedure having same name" in the below code

Private Sub txtXls_DblClick()
On Error Resume Next

Err.Clear
dlgBrowse.ShowOpen
If (Err.Number <> 0) Then txtXls.Text = dlgBrowse.Filename

End Sub

[Aflatoon]

The declaration should be
Private Sub txtXls_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

[jignesh142]

Finally i managed to transfer the application in the VBA....

Thanks to all to provide me the inspirations and new vision that such application also can be developed in VBA, specially to Kenneth Hobs and Xld...