hi i make a small game with vb6 and i need play 2 sound in some time
i use this code
Private Declare Function PlaySoundMem Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As Long, ByVal hModule As Long, ByVal dwFlags As Long) As Long
Const SND_ASYNC = &H1, SND_MEMORY = &H4, SND_NODEFAULT = &H2, SND_NOSTOP = &H1, SND_NOWAIT = &H2000
Dim Sound() As Byte
Dim x As Integer
Private Sub Form_Load()
On Error Resume Next
Sound = LoadResData("music", "CUSTOM")
Call PlaySoundMem(VarPtr(Sound(0)), 0, SND_NOWAIT Or SND_NODEFAULT Or SND_MEMORY Or SND_ASYNC Or SND_NOSTOP)
DoEvents
End Sub
Private Sub snd()
If nrd.Text = 1 Then
x = 1
snd_hero
ElseIf nrd.Text = 2 Then
x = 2
snd_hero
ElseIf nrd.Text = 3 Then
x = 3
snd_hero
ElseIf nrd.Text = 4 Then
x = 4
snd_hero
ElseIf nrd.Text = 5 Then
x = 5
snd_hero
ElseIf nrd.Text = 6 Then
x = 6
snd_hero
End If
End Sub
Private Sub snd_hero()
On Error Resume Next
Sound = LoadResData(x, "CUSTOM")
Call PlaySoundMem(VarPtr(Sound(0)), 0, SND_NOWAIT Or SND_NODEFAULT Or SND_MEMORY Or SND_ASYNC Or SND_NOSTOP)
DoEvents
ReDim Sound(0)
its play music whin game start but the music stop whin play another sound
i need play to sound at some time what i do thanks
You can try using a windows media player control and set it to loop. Since it behaves like an external media player (to some extent) it mixes the audio into directshow, so it will not prevent other sounds from playing, and vice-versa.
Check this link out. It's for VB.Net, but it looks like the only thing you need to change is the button click event handler. mciSendString is part of the WinAPI for MCI devices (winmm.dll), which is just as easy to use in VB6.
Related
The scenario is such that the news is read from the database and each news is displayed for a few seconds and then fades out and the next news is displayed. Like breaking news on news networks like Fox news and so on ..
My main problem is how the text fades out and the next news is displayed?
There are many examples of form fading in/out in Visual Basic 6, but not for text.
With this code, I can display the news text after 3 seconds and then delete it. But I would like the news text to gradually fade and the next news to be displayed.
Dim EndTime As Long
Dim eee As String
EndTime = Timer + 3
Do While Timer < EndTime
eee = CLng(EndTime - Timer)
DoEvents
Loop
lbl(0).Caption = ""
As mentioned in the comments, the simple approach is to modify the text color. For the example below, drop a PictureBox onto a Form. I chose to use a PictureBox instead of a Label to eliminate flickering:
Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub Form_Initialize()
Picture1.BorderStyle = 0
Picture1.AutoRedraw = True
End Sub
Private Sub Form_Activate()
ShowNewsItem "This is the first news item", 3000
ShowNewsItem "This is the second news item", 3000
ShowNewsItem "This is the third news item", 3000
End Sub
Private Sub ShowNewsItem(ByVal NewsItem As String, ByVal HoldTime As Integer)
Dim i As Integer
'fade in from ButtonFace to ButtonText (gray to black)
i = 237 'vbButtonFace
Do
Picture1.ForeColor = RGB(i, i, i)
Picture1.CurrentX = 0
Picture1.CurrentY = 0
Picture1.Print NewsItem
DoEvents
i = i - 1
Sleep 5
Loop Until i < 0
'hold the item
Sleep HoldTime
'fade out from ButtonText to ButtonFace (black to gray)
i = 0 'vbButtonText
Do
Picture1.ForeColor = RGB(i, i, i)
Picture1.CurrentX = 0
Picture1.CurrentY = 0
Picture1.Print NewsItem
DoEvents
i = i + 1
Sleep 5
Loop Until i > 237
End Sub
I am new to vba and I want to learn. Please help me with the following:
I have this application(see the picture) which I use to enter data in a worksheet (it is more easy to use compared to completing manually). It is basically an inventory management system. When I add a product in there I can choose between sale or purchase.
The next thing I would like to implement is to autofill the form whenever I want to add a sale (considering it was added as a purchase in the first place), based on a serial code for example. This would be very useful because I wont have to complete all the text boxes again when I enter a sale in the database
Do you have any ideas about how I could do this?
Kind regard,
Traian.
So, basically I shouldn't help since you have not done your research, but I did find it interesting to see if I could create such a function.
You wont be able to simply paste the code but it does work exactly as a autofill.
This is the "data" source I used for the autofill, it's looking for the left value and will autocomplete that textbox, as well as a secondary textbox with the value from column C. This would work with n numbers of autofills.
I only used 2 different fields to test this idea, disregard the labels. This is how it looked without typing anything.
As soon as you start to type, the "autofill" appears.
If you were to "hover" over the autofill, it will turn a different color, as well as all the input sheets, the input sheet also now includes the autofilled answers. if you were to "unhover"(hover over anything except the autofill) it will revert back to the second picture.
If I were to write this code again for a real project, I would change a couple of thing.
There might be leftover code from my testing, I would remove this.
I would use global variables so to avoid declaring variables more than one time.
I would name the textboxes and label in a better way.
I would complicate the textboxes with labels as to get the text to align in center.
The order of the code might not be the best for you to understand.
etc.
Here is the code:
Private Sub Autofill_Click()
Dim BestOption As Integer
Dim ValueRange As Range
Set ValueRange = Sheets("sheet1").Range("B8:B13")
Dim Start As Range
Set Start = Sheets("sheet1").Range("B7")
BestOption = WorksheetFunction.Match(Autofill, ValueRange, 0)
TextBox2 = Start.Offset(BestOption, 1)
TextBox1 = Start.Offset(BestOption, 0)
Autofill.Visible = False
TextBox3.Visible = False
TextBox4.Visible = False
End Sub
Private Sub TextBox1_Change()
Dim Start As Range
Dim ValueRange As Range
Dim MatchCounter As Integer
Set Start = Sheets("sheet1").Range("B7")
Set ValueRange = Sheets("sheet1").Range("B8:B13")
If TextBox1 = "" Then
Autofill.Visible = False
Else
'Call FindClosestMatch(TextBox1)
Autofill.Visible = True
Autofill = Start.Offset(FindClosestMatch(TextBox1) + 1, 0)
End If
End Sub
Function FindClosestMatch(Entry As String) As Integer
Dim BestOption As Integer
Dim Start As Range
Set Start = Sheets("sheet1").Range("B7")
Dim MyArray(6) As String
Dim i As Integer
Dim j As Integer
Dim iChar As String
Dim EntryChar As String
For i = 0 To 5
MyArray(i) = Start.Offset(i + 1, 0)
Next i
For j = 1 To Len(Entry)
EntryChar = Mid(Entry, j, 1)
For i = 0 To 5
If EntryChar = "" Then
Exit For
End If
iChar = Mid(MyArray(i), j, 1)
If iChar = EntryChar Then
BestOption = i
Else
MyArray(i) = "................."
End If
Next i
Next j
FindClosestMatch = BestOption
End Function
'hover
Private Sub Autofill_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Autofill.BackColor = &H80000002
TextBox3.BackColor = &H80000002
TextBox4.BackColor = &H80000002
Dim BestOption As Integer
Dim ValueRange As Range
Set ValueRange = Sheets("sheet1").Range("B8:B13")
Dim Start As Range
Set Start = Sheets("sheet1").Range("B7")
BestOption = WorksheetFunction.Match(Autofill, ValueRange, 0)
TextBox3.Visible = True
TextBox4.Visible = True
TextBox4 = Start.Offset(BestOption, 1)
TextBox3 = Start.Offset(BestOption, 0)
End Sub
Private Sub TextBox1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Private Sub TextBox2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Private Sub TextBox3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Private Sub TextBox4_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Private Sub UserForm_Click()
Call test
Autofill.Visible = False
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
Call test
End Sub
Sub test()
Autofill.BackColor = &H80000000
TextBox1.BackColor = &H80000005
TextBox2.BackColor = &H80000005
TextBox3.Visible = False
TextBox4.Visible = False
End Sub
Problem to think about:
The autofill always give the best answer, even if no good answer exist. In those cases, the best answer is the first answer in the data structure.
It is case sensitive.
One charachter wrong and you wont find your answer.
Notes:
I used 4 textboxes, number 1 and 2 are sitting on top of each other, and number 2 and 4 are on top of each other. This was done to not lose the already typed input if you accidently hovered over the autofill.
Requirement:
We have a chart with a considerable cardinality in filters. User wants to single-click print all permutations.
My idea:
Iterate all, setting the filters and rendering the chart as image to a single sheet (unfortunately, I haven't found a way to do it w/o using clipboard).
Solution:
#If VBA7 Then
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr) 'For 64 Bit Systems
#Else
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 'For 32 Bit Systems
#End If
Sub PrintButton_Click()
Dim ps As Worksheet
Dim gs As Worksheet
Dim r As Range
Dim c As ChartObject
Dim s As Shapes
Dim n As Integer
Application.ScreenUpdating = False
Set gs = Sheets("Graph")
Set ps = gs
Set c = gs.ChartObjects("Chart")
n = 0
For Each loopRow In Sheets("Klassen").UsedRange.Rows
' there seems to be 1024 PageBreaks per Sheet limit
If n Mod 1024 = 0 Then
Set ps = Sheets.Add(After:=ps)
ps.Name = "Print" + IIf(n / 1024 = 0, "", "_" + CStr(n / 1024))
ps.PageSetup.Orientation = xlLandscape
Set s = ps.Shapes
Set r = ps.Cells(1, 1)
End If
If loopRow.Row <> 1 And loopRow.Cells(1).Value <> "" And loopRow.Cells(2).Value <> "" Then
gs.Cells(1, 2).Value = loopRow.Cells(1).Value
gs.Cells(2, 2).Value = loopRow.Cells(2).Value
c.CopyPicture
DoEvents
'Sleep 1000
'DoEvents
'EnsureClipboard (xlClipboardFormatPICT)
'dbg = Application.ClipboardFormats(1)
r.PasteSpecial
'ps.Paste Destination:=r
Set r = ps.Cells(s(s.Count).BottomRightCell.Row + 1, 1)
r.PageBreak = xlPageBreakManual
'gs.Cells(1, 1).Copy
'EnsureClipboard (xlClipboardFormatText)
End If
n = n + 1
Next
gs.Cells(1, 2).Value = "(All)"
gs.Cells(2, 2).Value = "(All)"
Application.ScreenUpdating = True
End Sub
Sub EnsureClipboard(desiredFmt As XlClipboardFormat)
Dim present As Boolean
DoEvents
present = False
Do While Not present
aFmts = Application.ClipboardFormats
For Each fmt In aFmts
If fmt = desiredFmt Then
present = True
End If
Next
If Not present Then
DoEvents
Sleep 100
DoEvents
End If
Loop
End Sub
Problem:
After a variable amount of iterations, Excel throws "Run-time error '1004' PasteSpecial method of Range class failed".
Debug:
Both "r.PasteSpecial" and "ps.Paste Destination:=r" fails.
dbg variable contains xlClipboardFormatPICT, so it seems the data is there and inspecting the clipboard confirms it.
I was even desperate enough to wait a whole second between copying and pasting to eliminate the race condition - paste typically fails after pretty much the same number of successes.
I'm using Office 365 ProPlus. Funny thing is it used to work on v1705, it fails on v1803. Even funnier is that for some time after the upgrade it worked, so I'm not sure if it would still work on previous version...
I was researching different components of VBA and APIs and came across a website that proposes a personalized API that runs the game Pong within a spreadsheet that contains certain subs and functions. The instance used was with Windows/Excel version 97 and is stated to not be compatible with the 2000 version (and, I am assuming, the current version). I was wondering if any VBA-savvy individuals who thought this was worth doing could let me know whether this is a function capable of implementing under the current iteration of Excel, and if so, what the workaround would be?
When I use the following code below, I get a run-time error declaring that
vba332.dll is missing
the debugger highlights the 9th line of the Public Function AddrOf which states:Call GetCurrentVbaProject (hProject) is the error line and (hProject) when hovered on is 0, which I am assuming is also a problem as it is supposed to be getting a value other than 0 to move forward...
According to some reading that I have found, the newer version of the referenced .dll would be something like:
vbe7.dll
But when I have substituted that line within this string of codes, it still does not return any data for the Declare Function.
This seemed like a fun API to play around with, but I could not devise a way to upgrade it to the current Excel version. The code:
Option Explicit
Private Declare Function GetCurrentVbaProject _
Lib "vba332.dll" Alias "EbGetExecutingProj" _
(hProject As Long) As Long
Private Declare Function GetFuncID Lib "vba332.dll" Alias "TipGetFunctionId" _
(ByVal hProject As Long, ByVal strFunctionName As String, _
ByRef strFunctionId As String) As Long
Private Declare Function GetAddr _
Lib "vba332.dll" Alias "TipGetLpfnOfFunctionId" _
(ByVal hProject As Long, ByVal strFunctionId As String, _
ByRef lpfn As Long) As Long
Private Declare Function SetTimer Lib "user32" _
(ByVal hwnd As Long, ByVal nIDEvent As Long, _
ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" _
(ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private lngTimerId As Long
Dim Paddle As Shape
Dim Ball As Shape
Dim nVertical As Integer
Dim nHorizontal As Integer
Dim nSpeed As Integer
Sub Auto_Open()
Application.OnKey "{F12}", "StartPong"
End Sub
Sub Auto_Close()
Timer_Terminate
On Error Resume Next
Paddle.Delete
Ball.Delete
End Sub
Sub StartPong()
Dim nLeft As Integer
Dim nTop As Integer
Dim nWidth As Integer
Dim nHeight As Integer
'Draw the paddle
nLeft = ActiveWindow.UsableWidth - 100
nTop = ActiveWindow.UsableHeight - 30
nWidth = 50
nHeight = 10
Set Paddle = ActiveSheet.Shapes.AddShape(1, nLeft, nTop, nWidth, nHeight)
Paddle.Fill.ForeColor.SchemeColor = 8
'Draw the ball
nLeft = CInt(ActiveWindow.UsableWidth / 2) - 20
nTop = 0
nWidth = 15
nHeight = 15
Set Ball = ActiveSheet.Shapes.AddShape(9, nLeft, nTop, nWidth, nHeight)
Ball.Fill.ForeColor.SchemeColor = 8
'Define keys
Application.OnKey "{ESC}", "EndPong"
Application.OnKey "{RIGHT}", "MoveRight"
Application.OnKey "{LEFT}", "MoveLeft"
Application.OnKey "{F12}"
'Set speed
nVertical = 10 'Ball Vertical
nHorizontal = 10 'Ball Horizontal
nSpeed = 18 'Paddle Horizontal
'Start the ball movement timer
Timer_Initialize (15) 'Ball will be moved every 15 milliseconds
'Now we wait for events to move things
End Sub
Sub MoveBall()
Dim nLeft As Integer
Dim nTop As Integer
With Ball
'Move Horizontal
.Left = .Left + nHorizontal
'Move vertical
.Top = .Top + nVertical
'Bounce horizontal
nLeft = .Left
If nLeft > (ActiveWindow.UsableWidth - 50) Then
nHorizontal = -1 * Abs((nHorizontal))
End If
If nLeft < 20 Then
nHorizontal = Abs(nHorizontal)
End If
'Bounce vertical
nTop = .Top
If nTop > (ActiveWindow.UsableHeight - 50) Then
nVertical = -1 * (Abs(nVertical))
'Did Paddle hit it?
If (.Left + (.Width / 2)) > Paddle.Left And _
(.Left + (.Width / 2)) < (Paddle.Left + Paddle.Width) Then
'Paddle hit the ball
If (.Left + (.Width / 2)) < (Paddle.Left + (Paddle.Width / 3)) Then
'Ball hit paddle on left third; apply english
nHorizontal = nHorizontal - 5
If nHorizontal < -15 Then nHorizontal = -15
End If
If (.Left + (.Width / 2)) > (Paddle.Left + (2 * Paddle.Width / 3)) Then
'Ball hit paddle on right third
nHorizontal = nHorizontal + 5
If nHorizontal > 15 Then nHorizontal = 15
End If
Else
Beep 'missed
'Move the paddle in case window was resized
Paddle.Top = ActiveWindow.UsableHeight - 30
End If
End If
If nTop < 20 Then
nVertical = Abs(nVertical)
End If
End With
End Sub
Sub EndPong()
Timer_Terminate
Application.OnKey "{ESC}"
Application.OnKey "{RIGHT}"
Application.OnKey "{LEFT}"
Application.OnKey "{F12}", "StartPong"
Paddle.Delete
Ball.Delete
End Sub
Sub MoveRight()
Paddle.Left = Paddle.Left + nSpeed
If Paddle.Left > (Application.UsableWidth - 30 - Paddle.Width) Then
Paddle.Left = Application.UsableWidth - 30 - Paddle.Width
End If
End Sub
Sub MoveLeft()
Paddle.Left = Paddle.Left - nSpeed
If Paddle.Left < 0 Then
Paddle.Left = 0
End If
End Sub
Public Function AddrOf(strFuncName As String) As Long
'Returns a function pointer of a VBA public function given its name.
'AddrOf code from Microsoft Office Developer magazine
'http://www.informant.com/mod/index.htm
Dim hProject As Long
Dim lngResult As Long
Dim strID As String
Dim lpfn As Long
Dim strFuncNameUnicode As String
Const NO_ERROR = 0
' The function name must be in Unicode, so convert it.
strFuncNameUnicode = StrConv(strFuncName, vbUnicode)
' Get the current VBA project
Call GetCurrentVbaProject(hProject)
' Make sure we got a project handle
If hProject <> 0 Then
' Get the VBA function ID
lngResult = GetFuncID(hProject, strFuncNameUnicode, strID)
If lngResult = NO_ERROR Then
' Get the function pointer.
lngResult = GetAddr(hProject, strID, lpfn)
If lngResult = NO_ERROR Then
AddrOf = lpfn
End If
End If
End If
End Function
Private Sub TimerProc(ByVal hwnd&, ByVal lngMsg&, ByVal lngTimerId&, ByVal
lngTime&)
Call MoveBall
End Sub
Sub Timer_Initialize(Optional vInterval As Variant)
Dim lngInterval As Long
lngInterval = CLng(vInterval)
If lngInterval = 0 Then lngInterval = 60 '60 milliseconds just a bit longer
than a "tick"
lngTimerId = SetTimer(0, 0, lngInterval, AddrOf("TimerProc"))
If lngTimerId = 0 Then
MsgBox "Unable to initialize a new timer!"
End If
End Sub
Sub Timer_Terminate()
If lngTimerId <> 0 Then
Call KillTimer(0, lngTimerId)
End If
End Sub
Thanks!
In later versions of Office, "TipGetLpfnOfFunctionId" is exposed as AddressOf.
And since you can use AddressOf directly to get the address of a function, you don't need "TipGetFunctionId" nor all the "addrof" code.
Sub Timer_Initialize(Optional vInterval As Variant)
Dim lngInterval As Long
lngInterval = CLng(vInterval)
If lngInterval = 0 Then lngInterval = 60
lngTimerId = SetTimer(0, 0, lngInterval, AddressOf TimerProc)
If lngTimerId = 0 Then
MsgBox "Unable to initialize a new timer!"
End If
End Sub
Note the unique syntax of the "AddressOf" operator: it's not a function.
With the Top and Left arguments for this function is there a Centre screen option, or will it always be a number?
I'm using this instead of a regular inputbox as it handles the cancel event better but it always appears in the bottom right of the screen which is less than helpful :/
There is no center screen option. You'd have to calculate it. But, assuming you are using Excel 2007 or later, there's another issue...
This was news to me, but in googling and testing I see that in Excel 2007 and 2010 Application.Inputbox reverts to its last position, disregarding the Top and Left settings. This problem seems to persist even if a new Inputbox is called from a new worksheet. When I try it in XL 2003 it works correctly, and the Inputbox is placed at the correct left and right coordinates.
You can maybe just drag the Inputbox where you want and then save. Unless somebody drags it later, it will re-open in the same place.
Here's a link to a solution that worked for somebody to bring back the correct behavior, and also addresses centering the inputbox. It does require API calls, so save your work before you try it.
EDIT - Per JMax's comment, here's the code from the link above. It's by a user called KoolSid on the vbforums.com site:
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" (ByVal idHook As Long, _
ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
'~~> Handle to the Hook procedure
Private hHook As Long
'~~> Hook type
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
'~~> SetWindowPos Flags
Private Const SWP_NOSIZE = &H1 '<~~ Retains the current size
Private Const SWP_NOZORDER = &H4 '<~~ Retains the current Z order
Dim InputboxTop As Long, InputboxLeft As Long
Sub TestInputBox()
Dim stringToFind As String, MiddleRow As Long, MiddleCol As Long
hHook = SetWindowsHookEx(WH_CBT, _
AddressOf MsgBoxHookProc, 0, GetCurrentThreadId)
'~~> Get the center cell (keeping the excel menus in mind)
MiddleRow = ActiveWindow.VisibleRange.Rows.Count / 1.2
'~~> Get the center column
MiddleCol = ActiveWindow.VisibleRange.Columns.Count / 2
InputboxTop = Cells(MiddleRow, MiddleCol).Top
InputboxLeft = Cells(MiddleRow, MiddleCol).Left
'~~> Show the InputBox. I have just used "Sample" Change that...
stringToFind = Application.InputBox("Sample", _
"Sample", "Sample", InputboxLeft, InputboxTop, , , 2)
End Sub
Private Function MsgBoxHookProc(ByVal lMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
If lMsg = HCBT_ACTIVATE Then
'~~> Change position
SetWindowPos wParam, 0, InputboxLeft, InputboxTop, _
0, 0, SWP_NOSIZE + SWP_NOZORDER
'~~> Release the Hook
UnhookWindowsHookEx hHook
End If
MsgBoxHookProc = False
End Function
You can test the regular inputbox to see if cancel was pressed, and it has the extra benifit of always being centered. Just use StrPtr(variable) = 0 to test it. Simple!
Another way to avoid a user hitting OK with nothing typed is to add a default value inside the input box to start with, that way you know that if it returns an empty string, it's most likely due to the cancel button being pressed.
StrPtr will return a 0 if cancel was selected (also returns 0 for vbNullString, btw). Please note that StrPtr work in VB5, VB6, and VBA, but since it's not officially supported, it could be rendered unusuable years down the line. I highly doubt they'd get rid of it but it's worth considering if this is an application you plan to distribute.
Sub CancelTest()
Dim temp As String
temp = InputBox("Enter your name", "Cancel Test")
If StrPtr(temp) = 0 Then
' You pressed cancel
Else
If temp = "" Then
'You pressed OK but entered nothing
Else
'Do your thing
End If
End If
End Sub
Some more info on strptr:
StrPtr(S) returns a pointer to the actual string data currently stored in S. This is what you need when passing the string to Unicode API calls. The pointer you get points to the Datastring field, not the Length prefix field. In COM terminology, StrPtr returns the value of the BSTR pointer. (from the fantastic site: http://www.aivosto.com/vbtips/stringopt2.html)
' assume normal screen else go through GetDeviceCaps(hDCDesk, LOGPIXELSX) etc etc
' 1440 twips / inch pts / pix = 3/4 inch 100 pts
' so twips / pixel = 15
Sub GetRaXy(Ra As Range, X&, Y&) ' in twips
Dim ppz!
ppz = ActiveWindow.Zoom / 75 ' zoom is % so 100 * 3/4 =>75
' only the pixels of rows and columns are zoomed
X = (ActiveWindow.PointsToScreenPixelsX(0) + Ra.Left * ppz) * 15
Y = (ActiveWindow.PointsToScreenPixelsY(0) + Ra.Top * ppz) * 15
End Sub
Function InputRealVal!(Optional RaTAdd$ = "K11")
Dim IStr$, RAt As Range, X&, Y&
Set RAt = Range(RaTAdd)
GetRaXy RAt, X, Y
IStr = InputBox(" Value ", "ENTER The Value ", 25, X, Y)
If StrPtr(IStr) = 0 Then
MsgBox "Cancel Pressed"
Exit Function
End If
If IsNumeric(IStr) Then
InputRealVal = CDec(IStr)
Else
MsgBox "Bad data entry"
Exit Function
End If
End Function