I have an Excel file and a VBA macro that generates 2 buttons and puts a connector between them.The issue I encountered is that after I close the Excel file and reopen it, the connector is no longer connected to the buttons.
I noticed that the problem does not occur when I replace the buttons by simple rectangles. So I suspect that the way I connect the connectors to the buttons via ShapeRange.Item(1) might be incorrect. But I do not know any other way.
Sub CreateStuff()
Dim btn(1 To 2) As Button
Set btn(1) = ThisWorkbook.Worksheets(1).Buttons.Add(50, 50, 100, 200)
Set btn(2) = ThisWorkbook.Worksheets(1).Buttons.Add(300, 300, 150, 150)
Dim newConnector As Object
Set newConnector = ActiveSheet.Shapes.AddConnector(msoConnectorStraight, 0, 0, 100, 100)
With newConnector
.ConnectorFormat.BeginConnect btn(1).ShapeRange.Item(1), 1
.ConnectorFormat.EndConnect btn(2).ShapeRange.Item(1), 3
End With
End Sub
Sub TestConnection()
With ThisWorkbook.Worksheets(1).Shapes
Dim i As Integer
For i = 1 To .Count
If .Item(i).Connector Then
If .Item(i).ConnectorFormat.BeginConnected And .Item(i).ConnectorFormat.EndConnected Then
MsgBox "Connection present"
Else
MsgBox "No Connection"
End If
End If
Next i
End With
End Sub
Related
I'm trying to add an ImageCombo-ActiveX control to an Excel worksheet by using the VBA-function .OLEObjects.Add(classtype:="MSComctlLib.ImageComboCtl.2", Top:=TopPos, Left:=LeftPos, Height:=0, Width:=0).
When doing so, the ImageCombo control is displayed on the worksheet in a preloaded state:
ImageCombo Preloaded State
When doing a check with Winspector Spy, it turned out then the ActiveX-Window is loaded as a child-window of an invisible window within Excel named as 'CtlFrameworkParking':
ActiveX control window
instead of being diplayed as an ImageCombo-control. To force this, I first have to make the worksheet window invisble and then redisplay it:
Status after Re-displaying the worksheet window
Finally, after manually scrolling down a line, the ImageCombo-control is diplayed at the desired location with the desired size.
Status after worksheet scroll
Reinspecting with Winspector Spy the ActiveX-Window now is located within the worksheet window:
final correct status
Is there any way to programatically force the ActiveX-Window to show in final state on the worksheet window, probably with some api calls?
I Solved the problem doing it the dirty way by adding the following lines:
Function ShowLanguageDropDown(TargetSheetName As String, Optional TopPos As Single = 0#, Optional LeftPos As Single = 0#, Optional SetVisible As Boolean = False) As MSComctlLib.ImageCombo
'---------------------------------------------------------------------------------------
' Procedure : ShowLanguageDropDown
' Author : Bernd Birkicht
' Date : 05.11.2022
' Purpose : inserts an image dropdown on the target sheet, requires prelodad OLE-objects on a SourceSheet
' containing the ImageDropdown and the to be associated pre-set ImageList-activeX control
'---------------------------------------------------------------------------------------
'
'........
Set TargetSheet = ActiveWorkbook.Sheets(TargetSheetName)
'........
With TargetSheet
.Visible = xlSheetHidden
.Visible = xlSheetVisible
.Activate
End With
Set TargetSheet = Nothing
CurrentScrollRow = ActiveWindow.ScrollRow
ActiveWindow.ScrollRow = 2
ActiveWindow.ScrollRow = CurrentScrollRow
End function
These commands now do programmatically what I did manually before resulting in now correctly displaying the ImageDropdown control at the desired location on the worksheet.
I would welcome a more elegant solution.
I finally decided to to drop the approach of using an ImageCombo-ActiveX control directly on an Excel worksheet due to i encounterd a big bunch of problems with the ImageCombo-control further on.
When stopping the screen update, the Drop-down arrow within the control occasionally disappears and the control repaints not always fully. I was not able to fix this.
At the end of the day, I used the ImageCombo-ActiveX control within a modeless userform which is not affected at all from application screen updating or events processed by the application while the userform is displayed.
To prevent the userform from floating on the windows screen, I now attached the userform to the Excel-application window and cropped the userform frame around the ImageCombo-control.
Please find below the code:
Private Sub UserForm_Initialize()
'---------------------------------------------------------------------------------------
' Procedure : UserForm_Initialize
' Author : Bernd Birkicht
' Date : 10.11.2022
' Purpose : fills the image-Dropdownbox valid lnaguage entries
'---------------------------------------------------------------------------------------
'
Static BasicInit As Boolean
On Error GoTo UserForm_Initialize_Error
If BasicInit Then Exit Sub 'already initialised?
....
'adapt userform window to Dropbox size
Me.Height = Me!LanguageDropBox.Height
Me.Width = Me!LanguageDropBox.Width
With Me.LanguageDropBox
Set .ImageList = Nothing 'delete image list and import again
If .ImageList Is Nothing Then Set .ImageList = Me.LanguageSmallIconImageList
mlngptrCtlHwnd = .hwnd
.Locked = True
End With
PopulateComboItems Translate:=bTranslate
UserForm_Initialize_Exit:
Crop_UF_Frame
BasicInit = MakeChild(Me)
Exit Sub
UserForm_Initialize_Error:
Select Case Err.Number
Case Else
'MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Prozedur UserForm_Initialize aus Formular LanguageDropBoxForm"
'LogError Err.Number, Err.Description, "in Prozedur UserForm_Initialize aus Formular LanguageDropBoxForm"
ErrEx.CallGlobalErrorHandler ' Call the global error handler to deal with unhandled errors
Resume UserForm_Initialize_Exit:
End Select
End Sub
Private Sub Crop_UF_Frame()
'---------------------------------------------------------------------------------------
' Procedure : Crop_UF_Frame
' Author : Nepumuk https://www.herber.de/forum/archiv/1456to1460/1459854_Userform_komplett_ohne_Rand.html
' Date : 21.11.2015
' Purpose : crop the userform frame
' geändert : 11.11.2022 Bernd Birkicht
' ergänzt: Region eingrenzen auf einzelnes Control in der Userform
'---------------------------------------------------------------------------------------
'
Dim udtRect As RECT, udtPoint As POINTAPI
Dim lngptrStyle As LongPtr, lngptrRegion As LongPtr, lngParenthWnd As LongPtr
Static BasicInit As Boolean
On Error GoTo Crop_UF_Frame_Error
mlngptrHwnd = FindWindowA(GC_CLASSNAMEMSFORM, Caption)
lngptrStyle = GetWindowLongA(mlngptrHwnd, GWL_STYLE)
Call SetWindowLongA(mlngptrHwnd, GWL_STYLE, lngptrStyle And Not WS_CAPTION)
Call DrawMenuBar(mlngptrHwnd)
Call GetWindowRect(mlngptrHwnd, udtRect)
udtPoint.x = udtRect.right
udtPoint.y = udtRect.bottom
Call ScreenToClient(mlngptrHwnd, udtPoint)
'11.11.2022 set region
If mlngptrCtlHwnd = 0 Then 'Control in Userform gewählt?
'remove userform frame
With udtRect
.bottom = udtPoint.y
.left = 4
.right = udtPoint.x
.top = 4
End With
Else
'set region to WindowRect of the selected control
Call GetWindowRect(mlngptrCtlHwnd, udtRect)
End If
lngptrRegion = CreateRectRgnIndirect(udtRect)
Call SetWindowRgn(mlngptrHwnd, lngptrRegion, 1&)
Crop_UF_Frame_Exit:
Exit Sub
Crop_UF_Frame_Error:
Select Case Err.Number
Case Else
ErrEx.CallGlobalErrorHandler ' Call the global error handler to deal with unhandled errors
Resume Crop_UF_Frame_Exit:
End Select
End Sub
Private Function MakeChild(ByVal UF As UserForm) As Boolean
Dim DeskHWnd As LongPtr
Dim WindowHWnd As LongPtr
Dim UFhWnd As LongPtr
MakeChild = False
' get the window handle of the Excel desktop
DeskHWnd = FindWindowEx(Application.hwnd, 0&, "XLDESK", vbNullString)
If DeskHWnd > 0 Then
' get the window handle of the ActiveWindow
WindowHWnd = FindWindowEx(DeskHWnd, 0&, "EXCEL7", ActiveWindow.Caption)
If WindowHWnd > 0 Then
' ok
Else
MsgBox "Unable to get the window handle of the ActiveWindow."
Exit Function
End If
Else
MsgBox "Unable to get the window handle of the Excel Desktop."
Exit Function
End If
' get the window handle of the userform
Call IUnknown_GetWindow(UF, VarPtr(UFhWnd))
mlngptrOldParenthWnd = GetParent(UFhWnd)
If mlngptrOldParenthWnd = WindowHWnd Then Exit Function 'Assignment to Excel window already done
'make the userform a child window of the MDIForm
If (UFhWnd > 0) And (WindowHWnd > 0) Then
' make the userform a child window of the ActiveWindow
If SetParent(UFhWnd, WindowHWnd) = 0 Then
''''''''''''''''''''
' an error occurred.
''''''''''''''''''''
MsgBox "The call to SetParent failed."
Exit Function
End If
End If
MakeChild = True
End Function
call:
If Wb.ActiveSheet.Name = Translate_To_OriginalText(InitSheetName) And LanguageDropBoxUForm Is Nothing Then
LanguageDropBoxForm.Hide 'Lädt das Window ohne es anzuzeigen
If UserForms.count > 0 Then Set LanguageDropBoxUForm = UserForms(UserForms.count - 1)
LanguageDropBoxForm.Move 660#, 85#
LanguageDropBoxForm.Show vbModeless 'show Language-Select-Window modeless
endif
This worked before I switched to Office 2016 it doesn't any more.
Does anyone have an alternative way to make a simple popup box that closes after x seconds? I don't need an OK-button or any user interaction, just a plain simple popup message.
Sub MessageBoxTimer()
Dim AckTime As Integer, InfoBox As Object
Set InfoBox = CreateObject("WScript.Shell")
AckTime = 3
Select Case InfoBox.Popup("Click OK (this window closes automatically after
3 seconds).", _
AckTime, "This is your Message Box", 0)
Case 1, -1
Exit Sub
End Select
End Sub
I am needing a bit of assistance with Excel VBA. I am switching back and forth from Excel and another application and copying, pasting into Excel from the other application. I already have that process down, but I am needing advice on how I can paste into whatever cell is currently active, tab right, and at the end of that row go down one row, then start back in column D. Actually, here is a list of the exact process I am needing to happen inside the Excel application:
[Number Format] Paste into currently active cell (will always be in the D:D column)
Tab right one cell
[Date Format: "d-mmm"] Today's Date
Tab Right
[Text] Paste
Tab Right
[Accounting] Paste
Tab Right
Type the letter "X" in that column
Enter down one line, starting back in the D column.
Between all of these steps I have the majority of that code figured out that interacts with the other application. But I do have one question in regards to that as well -- In that application I am running this statement:
With ATC.ActiveSession (ATC is simply referencing the application's type library to interact with other application)
As opposed to me ending the With statement every time the applications switch back and forth copying and pasting, what would I need to do use as a with statement to use excel's library?
Example of what I don't want to happen:
Sub New_ATS()
Set ATC = GetObject(, "ATWin32.AccuTerm")
AppActivate "AccuTerm 2K2"
With ATC.ActiveSession
.InputMode = 1
.SetSelection 6, 15, 12, 15
.Copy
.InputMode = 0
End With
AppActivate "Microsoft Excel"
Selection.Paste '(not complete, part of question)
Selection.Offset 1, 0 'again, part of the question
AppActivate "AccuTerm 2K2"
With ATC.ActiveSession
.InputMode = 1
.SetSelection 14, 3, 20, 3
.Copy
.InputMode = 0
End With
AppActivate "Microsoft Excel"
' .... end of partial code (continues on)
End Sub
But instead, would like to 'chain' the With statements, but I don't know what statement I would use to point back to Excel's VBA. This is what I would like:
Sub New_ATS()
Set ATC = GetObject(, "ATWin32.AccuTerm")
AppActivate "AccuTerm 2K2"
With ATC.ActiveSession
.InputMode = 1
.SetSelection 6, 15, 12, 15
.Copy
.InputMode = 0
With Excels_Statement '?????
AppActivate "Microsoft Excel"
Selection.Paste '(not complete, part of question)
Selection.Offset 1, 0 'again, part of the question
AppActivate "AccuTerm 2K2"
With ATC.ActiveSession
.InputMode = 1
.SetSelection 14, 3, 20, 3
.Copy
.InputMode = 0
With Excels_Statement '????
AppActivate "Microsoft Excel"
End With
End With
End With
End With
' .... end of partial code (continues on)
End Sub
I don't have AccuTerm installed but I think you can paste into Excel without having to activate it each time. Instead of using With blocks, you could assign an object variable with minimal typing... not the best practice for variable naming but it would do the trick. Declaring the variable of the specific type would give you access to Excel's library.
Here's what I'm thinking... (partially tested so you might have to tweak it a little)
Sub New_ATS()
Set ATC = GetObject(, "ATWin32.AccuTerm")
Dim Sesh as ATWin32.AccuTerm.Session 'Not sure this exists
Dim XL as Excel.Range
AppActivate "AccuTerm 2K2"
Set Sesh = ATC.ActiveSession
Sesh.InputMode = 1
Sesh.SetSelection 6, 15, 12, 15
Sesh.Copy
Sesh.InputMode = 0
'AppActivate "Microsoft Excel" - don't need it
Set XL = application.activecell
XL.PasteSpecial
Set XL = XL.offset(0,1)
'AppActivate "AccuTerm 2K2" - no need, still active
Sesh.InputMode = 1 'Once this is set, do you need to set it again?
Sesh.SetSelection 14, 3, 20, 3
Sesh.Copy
Sesh.InputMode = 0 'Once this is set, do you need to set it again?
XL.PasteSpecial
XL.NumberFormat = "General" 'Bullet #1
Set XL = XL.offset(1,0)
'...and so on...
XL.PasteSpecial
XL.NumberFormat = "d-mmm" 'Bullet #3
Set XL = XL.offset(1,0)
XL.PasteSpecial
XL.NumberFormat = "#" 'Bullet #5
Set XL = XL.offset(1,0)
XL.PasteSpecial
XL.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* "-"??_);_(#_)" 'Bullet #7
Set XL = XL.offset(1,0)
XL = "X" 'Bullet #9
'When you've reached the end of the row
Set XL = XL.offset(1, 4 - XL.Column) 'Since col D = 4
'And repeat your procedure
End Sub
I have a worksheet that has two rows of option buttons. Option buttons 1 - 11 are on row 7 and option buttons 12 - 22 are on row 9 of the sheet. My code loops through and centers each option button in its appropriate cell by calling the centerOfCell function.
When I run my program Worksheets("Orders") gets passed into the CenterOptionButton procedure, and all of the option buttons get centered EXCEPT for option button 1. I cannot figure out why this happens.
Sub CenterOptionButton(wks As Worksheet)
Dim i As Byte
With wks
Select Case .Name
Case "RDC", "SKU"
optionCount = 8
Case "Orders"
optionCount = 11
Case Else
End Select
For i = 1 To optionCount
.OLEObjects("OptionButton" & i).Left = centerOfCell(.Cells(7, i + 1))
.OLEObjects("OptionButton" & i + optionCount).Left = centerOfCell(.Cells(9, i + 1))
Next i
End With
End Sub
If I then run the below procedure all by itself substituting out wks with Worksheets("Orders"), everything works perfectly. Any idea on what the issue could be?
Sub test()
Dim i As Byte
With Worksheets("Orders")
Select Case .Name
Case "RDC", "SKU"
optionCount = 8
Case "Orders"
optionCount = 11
Case Else
End Select
For i = 1 To optionCount
.OLEObjects("OptionButton" & i).Left = centerOfCell(.Cells(7, i + 1))
.OLEObjects("OptionButton" & i + optionCount).Left = centerOfCell(.Cells(9, i + 1))
Next i
End With
End Sub
Try to copy the other option button and replace the first option button. The issue might get resolved. As for why it is happening I would not know. Excel has been know to through up unknown errors. I would normally recreate the file or object and the issue is usually solved.
I've got a macro excel that makes many things. One of those things is to run a query (via ADODB.Connection). The query can last a lot, so I would like:
Show a modal informative dialog, saying "running query 3" (for example), without any buttons (the user shouln't be able to close it). It should be blocking for the user, but non-bloking for the macro.
Run the query.
Close the informative window.
In pseudo-code:
dim cn as new ADODB.Connection
dim rs as new ADODB.Recordset
dim dia as InfoDialog
set dia = new InfoDialog "running query 3"
cn.Open cn_string
rs.Open query_string, cn, ...
dia.close
I would prefer a solution without having to import new libraries (vba editor > tools > references). For example, with something similar to 'CreateObject("WScript.Shell")'. If not possible, then library import is welcome too (preferablily standard libraries, for not having to install things in users' computers).
Update: Following Kenda's suggestion, I have made a userForm "InfoDialog" with a label "Label1", and created two library functions to make it easy to use:
sub show_info(text as string)
InfoDialog.Label1.Caption = text
InfoDialog.Show
DoEvents
end sub
sub close_info()
InfoDialog.Hide
end sub
So now I can write:
show_info "Connecting to db ..."
cn.Open cn_string
show_info "Running query ..."
rs.Open query_string, cn, ...
close_info
just insert UserForm with Label than in your code you can use
Form1.Show
Form1.Label1.Text="running query 3"
...
Form1.Hide
on the end optional unload form with Unload Form1
I've another problem with running macro. When I run large code, an Excel 2010 looks like it freeze, but macro still running on backround. And user haven't ProgressBar. So I use some trick with Label with blue BackColor in Frame. (Contains: Label named lblDescription, Fram named FrameProgress where is Label named LabelProgress)
For nonFreezing make this:
1) add Sub on Activate form
Private Sub UserForm_activate()
Call ImportDat
End Sub
2) in Module1 make starting Sub
Sub ShowDialog()
UserForm1.LabelProgress.Width = 0
UserForm1.Show
End Sub
3) in Module1 make your Sub with this code (magic word is DoEvents)
Sub ImportDat()
Dim Counter As Integer
Dim RowMax As Integer
Dim PctDone As Single
Application.ScreenUpdating = False
Counter = 1
RowMax = 10000
For i = 0 To RowMax -1
PctDone = i / RowMax
With UserForm1
.lblDescription = "Processing " + CStr(i + 1) + " from " + CStr(RowMax)
.FrameProgress.Caption = Format(PctDone, "0%")
.LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)
End With
DoEvents
Next i
Application.ScreenUpdating = True
Unload UserForm1
End Sub
Hope it helps you.