I am calling an external application from MS Access in Vb6 and trying to change a combo box selection, but all the sendmessage constants I have tried do not work. Code I have so far successfully opens the App, navigates to the correct window, expands the combobox and thats as far as i get. I have also attached a link to the Spy ++ tree
Sub RunSailwaveUpdates()
Dim hwnd As Integer
Dim SortSelect As String
SortSelect = "Fleet"
hwnd = FindWindow(vbNullString, "Sailwave -
C:\Users\Public\Documents\Sailwave\Results\Summer Points.blw")
start_doc = ShellExecute(0&, "open", "
C:\Users\Public\Documents\Sailwave\Results\Summer Points.blw", 0, 0,
SW_NORMAL)
If start_doc = 2 Then Exit Sub
If start_doc = 3 Then Exit Sub
Do
DoEvents
hwindow2 = FindWindow(vbNullString, "Sailwave -
C:\Users\Public\Documents\Sailwave\Results\Summer Points.blw")
hwindow3 = FindWindowEx(hwindow2, ByVal 0&, "ClaChildClient", vbNullString)
scoreseriesbutton = FindWindowEx(hwindow3, 0&, "ClaButton_0400000H", "Score
Series")
Loop Until hwindow2 > 0 And hwindow3 > 0 And scoreseriesbutton > 0
WaitSeconds (0.5)
Call SendMessage(scoreseriesbutton, BM_CLICK, 0, ByVal 0&)
Do
DoEvents
scoreseries = FindWindow(vbNullString, "Score Series")
scoreseries2 = FindWindowEx(scoreseries, 0&, "ClaChildClient", vbNullString)
groupoption = FindWindowEx(scoreseries2, 0&, "ClaRadio_0400000H", "Score
groups of competitors separately - scoring system is applied to each
group")
groupfield = FindWindowEx(scoreseries2, 0&, "ClaPrompt_0400000H", "Grouping
field")
groupfield1 = FindWindowEx(scoreseries2, ByVal 0&, "ClaDrop_0400000H", " ")
groupfield3 = GetWindow(groupfield, GW_HWNDNEXT)
Loop Until scoreseries > 0 And groupoption > 0 And groupfield > 0 And
groupfield1 > 0 And scoreseries2 > 0 And groupfield1 > 0 And groupfield3 > 0
WaitSeconds (0.5)
Call SendMessage(groupoption, BM_CLICK, 0, ByVal 0&)
Do
DoEvents
Call SendMessage(groupfield3, CB_SHOWDROPDOWN, 1, 0)
Call SendMessage(groupfield3, CB_SETCURSEL, 2, 0)
Call SendMessage(groupfield3, WM_SETREDRAW, 1, 0)
selectedsort = SendMessage(groupfield3, CB_GETCURSEL, 0, 0)
Loop Until selectedsort > 0
End Sub
Spy++ Extract
Related
I've managed to make my form fade out correctly, but for some reason my fade in isn't working correctly. The form "hitches" during the load. It loads normally, and then fades in. Rather than just fading in the begin with.
It's done by creating a module, and then code within the form.
The form code:
Option Compare Database
Dim gintC
Private Sub Form_Load()
Me.TimerInterval = 2
FadeForm Me, Fadezero, 1, 5
End Sub
Private Sub Form_Timer()
If IsEmpty(gintC) Then
FadeForm Me, Fadein, 1, 15
End If
gintC = 1
Me.TimerInterval = 0
End Sub
Private Sub Form_Close()
FadeForm Me, Fadeout, 1, 255
End Sub
The module:
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function SetLayeredWindowAttributes Lib "user32" _
(ByVal hWnd As Long, ByVal crey As Byte, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Const GWL_EXSTYLE = (-20)
Public Const WS_EX_LAYERED = &H80000
Public Const WS_EX_TRANSPARENT = &H20&
Public Const LWA_ALPHA = &H2&
'Enum for determining the direction of the fade.
Public Enum FadeDirection
Fadein = -1
Fadeout = 0
Fadezero = 1
SetOpacity = 1
End Enum
Public Sub FadeForm(frm As Form, Optional Direction As FadeDirection = FadeDirection.Fadein, _
Optional iDelay As Integer = 0, Optional StartOpacity As Long = 5)
Dim lOriginalStyle As Long
Dim iCtr As Integer
'You can only set a form's opacity if it's Popup property = True.
If (frm.PopUp = True) Then
'Get the form window’s handle, and remember its original style.
lOriginalStyle = GetWindowLong(frm.hWnd, GWL_EXSTYLE)
SetWindowLong frm.hWnd, GWL_EXSTYLE, lOriginalStyle Or WS_EX_LAYERED
'If the form’s original style = 0, it hasn’t been faded since it was opened.
'To get fading to work, we have to set its style to something other than zero.
If (lOriginalStyle = 0) And (Direction <> FadeDirection.SetOpacity) Then
'Recursively call this same procedure to set the value.
FadeForm frm, SetOpacity, , StartOpacity
End If
'Depending on the direction of the fade...
Select Case Direction
Case FadeDirection.Fadezero
iCtr = StartOpacity
SetLayeredWindowAttributes frm.hWnd, 0, CByte(iCtr), LWA_ALPHA
Case FadeDirection.Fadein
'Just in case.
If StartOpacity < 1 Then StartOpacity = 1
'Fade the form in by varying its opacity
'from the value supplied in 'StartOpacity'
'to 255 (completely opaque).
For iCtr = StartOpacity To 255 Step 1
SetLayeredWindowAttributes frm.hWnd, 0, CByte(iCtr), LWA_ALPHA
'Process any outstanding events.
DoEvents
'Wait a while, so the user can see the effect.
Sleep iDelay
Next
Case FadeDirection.Fadeout
'Just in case.
If StartOpacity < 6 Then StartOpacity = 255
'Fade the form out by varying its opacity
'from 255 to 1 (almost transparent).
For iCtr = StartOpacity To 1 Step -1
SetLayeredWindowAttributes frm.hWnd, 0, CByte(iCtr), LWA_ALPHA
'Process any outstanding events.
DoEvents
'Wait a while, so the user can see the effect.
Sleep iDelay
Next
Case Else 'FadeDirection.SetOpacity.
'Just in case.
Select Case StartOpacity
Case Is < 1: StartOpacity = 1
Case Is > 255: StartOpacity = 255
End Select
'Set the form's opacity to a specific value.
SetLayeredWindowAttributes frm.hWnd, 0, CByte(StartOpacity), LWA_ALPHA
'Process any outstanding events.
DoEvents
'Wait a while, so the user can see the effect.
Sleep iDelay
End Select
Else
'The form’s Popup property MUST = True
DoCmd.Beep
MsgBox "The form's Popup property must be set to True.", vbOKOnly & vbInformation, "Cannot fade form"
End If
End Sub
Any Advice? Any idea why the closing fade works, but the loading fade doesn't?
Thanks.
You should
move code from Load to Open event
call OpenForm with WindowMode = acHidden
set Me.Visible = True in Timer
I had lots of issues dealing with that IE 11 download bar when downloading a file.
I checked different solutions but the only way to make it work the most reliably possible was to put two of them together.
Then I set the default internet download folder as my Desktop so that whenever I download a file with SendKeys I know where to find it with the code.
For the little story, my code is downloading the attached files for all the different incident cases. The number/type of attachments can vary and to oragnize it a little bit I decided to create a folder with the name of the incident case and store the attachments inside.
So here is my code, if you see a part which could be improved let me know :)
Option Explicit
Private objIE As SHDocVw.InternetExplorer
Private ContentFrame As HTMLIFrame
Public Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
Public Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)
Public Const MOUSEEVENTF_LEFTDOWN = &H2
Public Const MOUSEEVENTF_LEFTUP = &H4
Public Const MOUSEEVENTF_RIGHTDOWN As Long = &H8
Public Const MOUSEEVENTF_RIGHTUP As Long = &H10
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Sub LeftClick()
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0
Sleep 50
mouse_event MOUSEEVENTF_LEFTUP, 0, 0, 0, 0
End Sub
Sub DownloadAttachment()
'make sure Cell A4 isn't empty because it has to contain the incident case
If Sheets(1).Cells(4, 1) = "" Or Sheets(1).Cells(4, 1) = " " Then End
'make sure it's a valid case No. before going on
On Error GoTo Fin
If Len(Cells(4, 1)) <> 8 Or CLng(Sheets(1).Cells(4, 1)) = 0 Then
MsgBox "Please enter a valid Case No."
End
End If
Call GetDataFromIntranet(Sheets(1).Cells(4, 1)
'Delete content on cell A4
Fin:
Sheets(1).Cells(4, 1) = ""
End Sub
Function GetDataFromIntranet(CaseNo As Long)
Dim i As Integer
If ("attachmentDivId").Children(0).Children(1).Children.Length >= 1 Then Call CreateFolder(CaseNo) ' If there is at least 1 attachment then we'll create a folder which has the name of the incident case
For i = 0 To objIE.document.frames(1).frames(1).document.getElementById("attachmentDivId").Children(0).Children(1).Children.Length - 1 ' For each attachment...
RetourALaCaseDepart:
objIE.document.frames(1).frames(1).document.getElementById("attachmentDivId").Children(0).Children(1).Children(i).Click ' Click on it so that it gets activated (blue)
objIE.document.frames(1).frames(1).document.getElementsByName("download")(0).Click 'Click on Save as
'The following bit send keyboard keys to cope with the Internet Downaload window that appears down the page -> downloads the file and save it on the Desktop
Application.Wait Now + TimeSerial(0, 0, 10)
Application.SendKeys "%{S}"
Application.Wait Now + TimeSerial(0, 0, 10)
SendKeys "{F6}", True
SendKeys "{TAB}", True
SendKeys "{ENTER}", True
'Here we close the Desktop window which sometimes open because it can alter the SendKey codes which is very sensitive
Dim objShellWindows As New SHDocVw.ShellWindows
Dim win As Object
For Each win In objShellWindows
If win.LocationName = "Desktop" Then
win.Quit
End If
Next win
Application.Wait Now + TimeSerial(0, 0, 1)
If MakeSureDownloaded(objIE.document.frames(1).frames(1).document.getElementById("attachmentDivId").Children(0).Children(1).Children(i).Children(0).innerText, CaseNo) = False Then GoTo RetourALaCaseDepart ' We check if the attachment was successfully saved, if not we redo the saving process from "RetourALaCaseDepart
Next i
Exit Function
Fini:
MsgBox "No attachments found or attachment tab not found"
End Function
Function MakeSureDownloaded(FileName As String, CaseNo As Long) As Boolean
Dim FileSys As Object 'FileSystemObject
Dim objFile As Object 'File
Dim myFolder
Dim strFilename As String
Const myDir As String = "C:\Users\Seb\Desktop\"
'set up filesys objects
Set FileSys = CreateObject("Scripting.FileSystemObject") 'New FileSystemObject
Set myFolder = FileSys.GetFolder(myDir)
For Each objFile In myFolder.Files
If objFile.Name Like FileName & "*" Then ' If the file was saved then we will add it to the folder created earlier for that Case
strFilename = objFile.Name
MakeSureDownloaded = True
GoTo BienBien
End If
Next objFile
MakeSureDownloaded = False
Set FileSys = Nothing
Set myFolder = Nothing
Exit Function
BienBien:
Dim fso As Object
Set fso = VBA.CreateObject("Scripting.FileSystemObject")
Call fso.MoveFile("C:\Users\Seb\Desktop\" & strFilename, "Path...\Case_Attachments\" & CaseNo & "\" & strFilename)
Set FileSys = Nothing
Set myFolder = Nothing
End Function
Sub CreateFolder(CaseNo As Long)
Dim fsoFSO
Set fsoFSO = CreateObject("Scripting.FileSystemObject")
If fsoFSO.FolderExists("Path...\Case_Attachments\" & CaseNo) Then ' do nothing actually...
Else
fsoFSO.CreateFolder ("Path...\Case_Attachments\" & CaseNo)
End If
End Sub
While starting up my MS Access 2013 database, I only need it to show the startup form and nothing else. Desired result would be something like below. The background is my desktop.
Desired:
However when I open the DB, the form opens taking the entire screen.
The below VBA code runs when the startup form loads and initially it works, but if I minimize the window I can see the background again.
Option Compare Database
Option Explicit
Global Const SW_HIDE = 0
Global Const SW_SHOWNORMAL = 1
Global Const SW_SHOWMINIMIZED = 2
Global Const SW_SHOWMAXIMIZED = 3
Private Declare Function apiShowWindow Lib "user32" _
Alias "ShowWindow" (ByVal hWnd As Long, _
ByVal nCmdShow As Long) As Long
Function fSetAccessWindow(nCmdShow As Long)
Dim loX As Long
Dim loForm As Form
On Error Resume Next
Set loForm = Screen.ActiveForm
If Err <> 0 Then
loX = apiShowWindow(hWndAccessApp, nCmdShow)
Err.Clear
End If
If nCmdShow = SW_SHOWMINIMIZED And loForm.Modal = True Then
MsgBox "Cannot minimize Access with " _
& (loForm.Caption + " ") _
& "form on screen"
ElseIf nCmdShow = SW_HIDE And loForm.PopUp <> True Then
MsgBox "Cannot hide Access with " _
& (loForm.Caption + " ") _
& "form on screen"
Else
loX = apiShowWindow(hWndAccessApp, nCmdShow)
End If
fSetAccessWindow = (loX <> 0)
End Function
I have hidden ribbons, navigation pane and all access user interfaces, but I need to remove the Access background also.
Current:
Any help / advice would be appreciated. Thanks in advace !!!
You don’t need any API code.
The following settings should do the trick:
File->Options->Current Database
Uncheck “Display document tabs”
Choose Tabbed Documents.
In above also un-check Display navigation Pane.
To hide the ribbon, execute this ONE line of VBA in your startup:
DoCmd.ShowToolbar "Ribbon", acToolbarNo
The resulting screen will be this:
Make sure the form(s) are not dialog, and make sure they are not popup forms.
To go back into “development” mode, you exit the database and then re-launch holding down the shift key – that will by-pass all of the above and allow you to develop.
I use synchronization of main form and Access windows sizes, so Access window will be always behind main window. Here is code behind:
Private Sub Form_Resize()
'main form
'Let us know when Form is Maximized...
If CBool(IsZoomed(Me.hwnd)) = True Then
funSetAccessWindow (SW_SHOWMAXIMIZED)
DoCmd.Maximize
Me.TimerInterval = 0
ElseIf CBool(IsIconic(Me.hwnd)) = True Then
funSetAccessWindow (SW_SHOWMINIMIZED)
Me.TimerInterval = 0
Else
'enable constant size sync
Me.TimerInterval = 100
SyncMainWindowSize Me, True
End If
End Sub
Private Sub Form_Timer()
SyncMainWindowSize Me
End Sub
Public Function SyncMainWindowSize(frm As Form, Optional blnForce As Boolean = False)
Dim rctForm As RECT
Dim iRtn As Integer
Dim blnMoved As Boolean
Static x As Integer
Static y As Integer
Static cx As Integer
Static cy As Integer
#If VBA7 And Win64 Then
Dim hWndAccess As LongPtr
#Else
Dim hWndAccess As Long
#End If
If GetWindowRect(frm.hwnd, rctForm) Then
If x <> rctForm.Left Then
x = rctForm.Left
blnMoved = True
End If
If y <> rctForm.Top Then
y = rctForm.Top
blnMoved = True
End If
If cx <> rctForm.Right - rctForm.Left Then
cx = rctForm.Right - rctForm.Left
blnMoved = True
End If
If cy <> rctForm.Bottom - rctForm.Top Then
cy = rctForm.Bottom - rctForm.Top
blnMoved = True
End If
If blnMoved Or blnForce Then
'move/resize main window
hWndAccess = Application.hWndAccessApp
iRtn = apiShowWindow(hWndAccess, WM_SW_RESTORE)
Call SetWindowPos(hWndAccess, 0, x, y, cx, cy, WM_SWP_NOZORDER Or WM_SWP_SHOWWINDOW)
End If
End If
End Function
Function funSetAccessWindow(nCmdShow As Long)
'Usage Examples
'Maximize window:
' ?funSetAccessWindow(SW_SHOWMAXIMIZED)
'Minimize window:
' ?funSetAccessWindow(SW_SHOWMINIMIZED)
'Hide window:
' ?funSetAccessWindow(SW_HIDE)
'Normal window:
' ?funfSetAccessWindow(SW_SHOWNORMAL)
Dim loX As Long
On Error GoTo ErrorHandler
loX = apiShowWindow(hWndAccessApp, nCmdShow)
funSetAccessWindow = (loX <> 0)
End Function
I created a macro, in which I can fetch each URL from any webpage.
Now, I have each URL in column.
How can I check if a URL is working.
If any one of these URL is not working then it should show me error not working next to URL in next column.
Below is the code I wrote:
Sub CommandButton1_Click()
Dim ie As Object
Dim html As Object
Dim j As Integer
j = 1
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
url = "www.mini.co.uk"
ie.navigate url
Do While ie.READYSTATE <> READYSTATE_COMPLETE
Application.StatusBar = "Trying to go to website ..."
Loop
Application.StatusBar = " "
Set html = ie.document
'Dim htmltext As Collection
Dim htmlElements As Object
Dim htmlElement As Object
Set htmlElements = html.getElementsByTagName("*")
For Each htmlElement In htmlElements
'If htmlElement.getAttribute("href") <> "" Then Debug.Print htmlElement.getAttribute("href")
If htmlElement.getAttribute("href") <> "" Then Cells(j, 1).Value = htmlElement.getAttribute("href")
j = j + 1
Next
ActiveSheet.Range("$A$1:$A$2752").removeDuplicates Columns:=1, Header:=xlNo
End Sub
This code is to fetch the URL from web-page.
Below is the code to check the status of URL, if it is working or not.
Sub CommandButton2_Click()
Dim k As Integer
Dim j As Integer
k = 1
j = 1
'Dim Value As Object
'Dim urls As Object
'urls.Value = Cells(j, 1)
For Each url In Cells(j, 1)
Dim ie As Object
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = False
url = Cells(j, 1)
ie.navigate url
Do While ie.READYSTATE <> READYSTATE_COMPLETE
Application.StatusBar = "checking the Data. Please wait..."
Loop
Cells(k, 2).Value = "OK"
'Set html = ie.document
ie.Quit
j = j + 1
k = k + 1
Next
End Sub
Public Function IsURLGood(url As String) As Boolean
Dim request As New WinHttpRequest
On Error GoTo IsURLGoodError
request.Open "HEAD", url
request.Send
If request.Status = 200 Then
IsURLGood = True
Else
IsURLGood = False
End If
Exit Function
IsURLGoodError:
IsURLGood = False
End Function
Sub testLink()
Dim source As Range, req As Object, url$
Set source = Range("A2:B2")
source.Columns(2).Clear
For i = 1 To source.Rows.Count
url = source.Cells(i, 1)
If IsURLGood(url) Then
source.Cells(i, 2) = "OK"
Else
source.Cells(i, 2) = "Down"
End If
Next
MsgBox "Done"
End Sub
Since you are interested to know whether the link is working, xmlhttp may be one solution.
Set sh = ThisWorkBook.Sheets("Sheet1")
Dim column_number: column_number = 2
'Row starts from 2
For i=2 To 100
strURL = sh.cells(i,column_number)
sh.cells(i, column_number+1) = CallHTTPRequest(strURL)
Next
Function CallHTTPRequest(strURL)
Set objXMLHTTP = CreateObject("MSXML2.XMLHTTP")
objXMLHTTP.Open "GET", strURL, False
objXMLHTTP.send
status = objXMLHTTP.Status
'strContent = ""
'If objXMLHTTP.Status = 200 Then
' strContent = objXMLHTTP.responseText
'Else
' MsgBox "HTTP Request unsuccessfull!", vbCritical, "HTTP REQUEST"
' Exit Function
'End If
Set objXMLHTTP = Nothing
CallHTTPRequest = status
End Function
You can actually get the status codes using IE automation, but it requires working with events and a reference to the Microsoft Internet Controls library.
Private Declare PtrSafe Sub SleepEx Lib "Kernel32.dll" (ByVal dwMilliseconds As Long, Optional ByVal bAlertable As Boolean = True)
Private WithEvents ie As SHDocVw.InternetExplorer
Private LastStatusCode As Long
Private Sub ie_NavigateError(ByVal pDisp As Object, URL As Variant, TargetFrameName As Variant, StatusCode As Variant, Cancel As Boolean)
LastStatusCode = StatusCode
End Sub
Public Sub NavigateReturnStatus(url As String) As Long
Set ie = CreateObject("InternetExplorer.Application")
Status = 0
ie.Navigate url
Do While IEObject.ReadyState <> READYSTATE_COMPLETE Or IEObject.Busy
SleepEx 50 'No busy waiting, short wait time
DoEvents 'Need to receive events from IE application
Loop
NavigateReturnStatus = LastStatusCode
End Sub
This doesn't return a conventional HTTP status code, but instead returns a NavigateError status code. That means you can get more detailed information about errors, but no information about successful navigation. Of course, if it's 0, no error has occurred so the status is likely 200.
Speed is very much slower than a WinHTTP/MSXML approach, but I'm sharing this mainly for cases where someone's already navigating using Internet Explorer anyway.
Of course, the code can (and likely should) be modified to reuse the internet explorer application.
Sub URLWorkingorNot()
'Make Sure to Select Cells containing URL
Dim i As Long
AddReference
i= 1
Selection.Replace "#N/A", "NA": Selection.Offset(0, 1).EntireColumn.Insert
Dim IE As InternetExplorer
If ActiveWorkbook Is Nothing Then Exit Sub
For Each cell In Selection
If cell.Value <> "" Then
Set IE = New InternetExplorer
IE.Navigate2 cell.Value
IE.Left = 900
IE.Width = 900
IE.Visible = True
While IE.Busy: DoEvents: Wend
On Error Resume Next
If InStr(1, IE.document.body.innerText, "The webpage cannot be found", vbBinaryCompare) <> 0 Then cell.Offset(0, 1).Value = "Not Available"
'MsgBox IE.document.body.innerText
If err.Number <> 0 Then err.Clear: On Error GoTo 0
IE.Quit: Set IE = Nothing
End If
i = i + 1:
ProgressBar Selection.Count, i, "Working on " & i & " Cell": DoEvents
If ActiveWorkbook.Path <> "" And Left(i, 3) = "00" Then ActiveWorkbook.Save
Next cell
Unload UProgressBar
Application.StatusBar = ""
End Sub
Sub AddReference()
'cOPIED FROM iNTERNET
'Macro purpose: To add a reference to the project using the GUID for the
'reference library
Dim strGUID As String, theRef As Variant, i As Long
'Update the GUID you need below.
'strGUID = "{00020905-0000-0000-C000-000000000046}"
strGUID = "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}"
'iNTERNET cONTROLS - "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}" MAJOR 1 MINOR 1
'HTMLOBJECT "{3050F1C5-98B5-11CF-BB82-00AA00BDCE0B}" MAJOR 4 MINOR 0
'Set to continue in case of error
On Error Resume Next
'Remove any missing references
For i = ThisWorkbook.Vbproject.References.Count To 1 Step -1
Set theRef = ThisWorkbook.Vbproject.References.Item(i)
If theRef.isbroken = True Then
ThisWorkbook.Vbproject.References.Remove theRef
End If
Next i
'Clear any errors so that error trapping for GUID additions can be evaluated
err.Clear
'Add the reference
ThisWorkbook.Vbproject.References.AddFromGuid _
GUID:=strGUID, Major:=1, Minor:=0
ThisWorkbook.Vbproject.References.AddFromFile "C:\Windows\System32\UIAutomationCore.dll"
'If an error was encountered, inform the user
Select Case err.Number
Case Is = 32813
'Reference already in use. No action necessary
Case Is = vbNullString
'Reference added without issue
Case Else
'An unknown error was encountered, so alert the user
MsgBox "A problem was encountered trying to" & vbNewLine _
& "add or remove a reference in this file" & vbNewLine & "Please check the " _
& "references in your VBA project!", vbCritical + vbOKOnly, "Error!"
End Select
On Error GoTo 0
End Sub
I am trying to fire an event if a specific combobox value appears more than 3 times ("md") in my control set. At the moment however, I keep getting high values like 32 or 40 despite there only being 8 comboboxes on my Access form. What am I doing wrong?
Dim mdCount As Integer
For Each ctl In Me.Controls
If ctl.ControlType = acComboBox Then
Set cmb = ctl
If (currentDropDown.Value = cmb.Value) And (Not currentDropDown Is cmb) And (Not currentDropDown.Value = "md") Then
MsgBox "You cannot select the same value twice."
End If
If (currentDropDown.Value = "md") Then
mdCount = mdCount + 1
End If
End If
Next ctl
Set ctl = Nothing
Private Sub Submit_Click()
'MsgBox mdCount
If (mdCount > 2) Then
MsgBox "Error!"
Exit Sub
End Sub
If i understand you correctly... try something like this (bit hard-coded, but very quick):
Function CheckMatches() As Integer
Dim sTmp As String
sTmp = IIf(Nz(Me.Combo1.Value, "") = "md", ";", "") & _
IIf(Nz(Me.Combo2.Value, "") = "md", ";", "") & _
IIf(Nz(Me.Combo3.Value, "") = "md", ";", "") 'and so on...
CheckMatches = UBound(Split(sTmp, ";")) + 1
'+1 is necessary in case of Option Base 0, _
'because LBound(array) starts from 0
End Function
Usage:
Private Sub Submit_Click()
Dim mdCount as Integer
mdCount = CheckMatches
If (mdCount > 2) Then
MsgBox "Error!"
Exit Sub
End Sub
Your requirements are not clear, so i can't help more ;(