i have a Userform where I have a command button to view the reports(can be any file in a folder). If this folder has n files then on click event of the command button , 'n' labels needs to be created dynamically on the UserForm with file names displayed as the caption. Below code runs without error but the labels are not displayed on the UserForm.
Private Sub cmdViewReports_Click()
Dim row_num As Long
Dim fso As Object
Dim src_path As String
Dim dest_path As String
Dim sub_folder As String
Dim theLabel1 As msforms.Label
Dim inc As Integer
Dim my_files As Object
Dim my_folder As Object
Dim i As Integer
Dim ctrl As Control
'Check if the record is selected in listbox
If Selected_List = 0 Then
MsgBox "No record is selected.", vbOKOnly + vbInformation, "Upload Results"
Exit Sub
End If
'Folder Name to be created as per the 3rd column value in the list
sub_folder = Me.lstDb.List(Me.lstDb.ListIndex, 3)
sub_folder = Replace(sub_folder, "/", "_")
dest_path = "C:\abc\xyz\Desktop\FV\" & sub_folder & "\"
Set fso = CreateObject("scripting.filesystemobject")
If Not fso.FolderExists(dest_path) Then
MsgBox "No reports are loaded"
Exit Sub
End If
Set my_folder = fso.GetFolder(dest_path)
Set my_files = my_folder.Files
i = 1
For Each oFiles In my_files
Set theLabel1 = Me.Controls.Add("Forms.Label.1", "File_name" & i, True)
With theLabel1
.Caption = oFiles.Name
.Left = 1038
.Width = 60
.Height = 12
.Top = 324 + inc
.TextAlign = 1
.BackColor = &HC0FFFF
.BackStyle = 0
.BorderStyle = 1
.BorderStyle = 0
'.Locked = True
.ForeColor = &H8000000D
.Font.Size = 9
.Font.Underline = True
.Visible = True
End With
MsgBox "Label" & i & " Created"
inc = inc + 12
i = i + 1
Next
End Sub
But when I run I am not able to see the labels. In this case I have 3 files in the folder so I should be 3 labels.
Also I want the labels to be hyperlinked, meaning that once I click the label the report/files should be displayed.
Any help will be highly appreciated. Thanks in Advance.
Related
I need to create an Object representing a UserForm, with methods to add Controls, and a method to present the UserForm.
I'm having a hard time wrapping my head around object-oriented VBA, and the tutorials/answers/documentation aren't helping me.
Here's how I imagine the Object and an example of its methods.
Sub UI_Window(caption as String)
Dim Form As Object
' This is to stop screen flashing while creating form
Application.VBE.MainWindow.Visible = False
Set Form = ThisWorkbook.VBProject.VBComponents.Add(1)
With Form
.Properties("Caption") = caption
.Properties("Width") = 600
.Properties("Height") = 50
End With
return Form
Sub addButton(action as String, code as String)
Set NewButton = Form.designer.Controls.Add("Forms.commandbutton.1")
With NewButton
.Name = "cmd_1"
.Caption = action
.Accelerator = "M"
.Top = Form.Height
.Left = 50
.Width = 500
.Height = 100
.Font.Size = 14
.Font.Name = "Tahoma"
.BackStyle = fmBackStyleOpaque
End With
' Adjust height of Form to added content
With Form
.Properties("Height") = Form.Height + NewButton.Height + 50
End With
' Should loop through code argument, line-by-line
Form.codemodule.insertlines 8, "Private Sub cmd_1_Click()"
Form.codemodule.insertlines 9, "msgbox (""Button clicked!"")"
Form.codemodule.insertlines 10, "End Sub"
End Sub
Sub present()
'Show the form
VBA.UserForms.Add(Form.Name).Show
'Delete the form
ThisWorkbook.VBProject.VBComponents.Remove Form
End Sub
End Sub
And here's how it would be used
Sub SampleWindow()
Set Window = UI_Window "Window Title"
Window.addButton "Click me", "msgbox (""Button clicked!"")"
Window.present()
End Sub
Please, try this adapted way:
Copy the next code on top of module where the following code exists:
Public frm As Object 'to use it even after the UserForm has been created
'to avoid it deletion when tested the code
Copy the next code in the same standard module:
Sub CreateAFormWithAButton()
Const formName As String = "MyNewForm"
Const formCaption As String = "My Form"
removeForm formName 'remove the previously created form, if the case
UI_Window formCaption, formName 'create the new form
addButton frm, "myFirstButton", "Click Me" 'add a button
VBA.UserForms.Add(frm.Name).Show 'show the newly created form
End Sub
Function formExists(frmName As String) As Boolean
Dim fr As Variant
For Each fr In ThisWorkbook.VBProject.VBComponents
If fr.Type = vbext_ct_MSForm Then
If frmName = fr.Name Then
Set frm = fr
formExists = True: Exit Function
End If
End If
Next
End Function
Sub UI_Window(frmCaption As String, frmName As String)
Set frm = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm) '3
With frm
.Properties("Caption") = frmCaption
.Properties("Width") = 500
.Properties("Height") = 200
.Properties("Name") = frmName
End With
End Sub
Sub addButton(form As Object, btName As String, btCaption As String)
Dim NewButton As MSForms.CommandButton
If buttonExists(btName) Then MsgBox "A button named """ & btName & """ already exists...": Exit Sub
Set NewButton = form.Designer.Controls.Add("Forms.commandbutton.1")
With NewButton
.Name = btName
.caption = btCaption
.top = 0
.left = 50
.width = 100
.height = 40
.Font.size = 14
.Font.Name = "Tahoma"
End With
' Should loop through code argument, line-by-line
form.CodeModule.InsertLines 8, "Private Sub " & btName & "_Click()"
form.CodeModule.InsertLines 9, " msgbox (""Button clicked!"")"
form.CodeModule.InsertLines 10, "End Sub"
End Sub
Function buttonExists(btName As String) As Boolean
Dim ctrl As Variant
For Each ctrl In frm.Designer.Controls
If ctrl.Name = btName Then buttonExists = True: Exit Function
Next
End Function
Sub removeForm(frmName As String)
Dim i As Long, strName As String
If Not formExists(frmName) Then Exit Sub
strName = "TestName"
tryAgain:
On Error Resume Next
frm.Name = strName
If err.Number = 75 Then 'a previously used name...
err.Clear 'clear the error
strName = strName & i: i = i + 1 'increment the new string
frm.Name = strName: GoTo tryAgain 'test the new name again
End If
On Error GoTo 0
ThisWorkbook.VBProject.VBComponents.Remove frm
End Sub
If you will try running the code for the second time, you cannot create a button with the same name. The code check if the name exists and warn. It can be adapted to propose another name (adding an incremented number), but it needs also to set other positioning, making the code more complicated and this does not make the object of the question, I would say...
Please, run/test it and send some feedback.
I am trying to dynamically add images to a form in a grid like fashion. The images are from a folder for now then, I'm trying to add a click function to each dynamically created images on the form to execute something but I'm stuck on that part. I am successful in importing the images to a form and showing it in a grid like fashion with the code below I came up with.
Option Explicit
Private Sub Pic2_Click()
'not working :(
MsgBox "worked!!"
End Sub
Private Sub UserForm_Initialize()
Dim img As Object
Dim picSheet As Worksheet
'Add Dynamic Image and assign it to object 'Img'
Dim i, h, t As Integer
' Set picSheet = ThisWorkbook.Worksheets("Themes")
' Dim pictureList As Object
' Dim pics As Shapes
' Dim pic As Shape
' Set pics = ThisWorkbook.Worksheets("Themes").Shapes
Dim picPath As String
t = 10
h = 10
picPath = Dir(Environ("USERPROFILE") & "\Pictures\*pic*") 'getting pictures from picpath folder image names are ranged from "pic1.jpg" to "pic12.jpg"
Do While Not Blank(picPath) ' blank determines if a string is empty (boolean value)
i = i + 1
If i > 1 Then h = h + 90
Set img = Me.Controls.Add("Forms.image.1", picPath, True)
If i Mod 4 = 1 And i > 1 Then 'new row after first 4 images to create grid
t = t + 100
h = 10
End If
With img
.Picture = LoadPicture(Environ("USERPROFILE") & "\Pictures\" & picPath)
.PictureSizeMode = fmPictureSizeModeStretch
.Left = h
.Top = t
.name = Split(picPath, ".")(0)
Debug.Print "name is: " & .name
End With
picPath = Dir
Loop
End Sub
This is my entire solution and it worked for me. I changed a few things by using buttons instead that had the images embedded in them.
Option Explicit
Dim ColTB As Collection
Private Sub UserForm_Initialize()
Dim picPath, path As String
Dim i, h, t As Integer
Dim button As Object
Dim fso As New FileSystemObject
t = 10
h = 10
Set ColTB = New Collection
picPath = Dir(Environ("USERPROFILE") & "\OneDrive\Pictures\Themes\" & "*.jpg")
Do While Not Blank(picPath)
i = i + 1
If i > 1 Then h = h + 120
If i Mod 4 = 1 And i > 1 Then
t = t + 100
h = 10
End If
Set button = Me.Controls.Add("Forms.CommandButton.1", picPath, True)
With button
.Font.Bold = True
.Left = h
.Top = t
.Picture = LoadPicture(Environ("USERPROFILE") & "\OneDrive\Pictures\Themes\" & picPath)
.Height = 72
.Width = 100
End With
ColTB.Add EventObj(button)
picPath = Dir
Loop
End Sub
Function EventObj(obj As MSForms.CommandButton) As Class1
Dim o As New Class1
Set o.buttonClickEvent = obj
Set EventObj = o
End Function
Class1 module
Option Explicit
Public WithEvents buttonClickEvent As MSForms.CommandButton
Private Sub buttonClickEvent_Click()
Dim name, imgpath, sheetName As String
Dim answer
Dim ac As Worksheet
Set ac = ThisWorkbook.ActiveSheet
name = buttonClickEvent.name
answer = MsgBox("You want to apply the " & Split(name, ".")(0) & " theme now?", vbQuestion + vbYesNo + vbDefaultButton2, "Apply Theme")
If answer = vbYes Then
imgpath = Environ("USERPROFILE") & "\OneDrive\Pictures\Themes\" & name
ac.SetBackgroundPicture Filename:=imgpath
End If
End Sub
I'm trying to insert pictures into Excel files from entering the serial number in a cell.
I get a syntax error where it is trying to insert the pictures. Specifically where it says .Shapes.AddPicture.
Sub picture_insert()
Dim picBild As Picture
Dim blnAvailable As Boolean
Dim link As String
Dim Pattern As String
Dim Serial As String
Dim t As String
Dim P1 As String
Dim P2 As String
link = "\\chimera\home\hillerbr\My Documents\Index project\"
Pattern = Range("A14")
Serial = Range("B14")
t = ".jpg"
P1 = Range("C14")
P2 = Range("D14")
With Worksheets("Data Breakdown")
For Each picBild In .Pictures
If picBild.Name = "280.1" Then
'The picture already exists
blnVorhanden = True
Exit For
End If
Next picBild
'only execute if picture does not yet exist
If blnVorhanden = False Then
With .Shapes.AddPicture Filename := link & Pattern & Serial & P1 & t
.Name = Range("C14")
.ShapeRange.LockAspectRatio = msoFalse
.Width = 450
.Height = 500
.Left = Worksheets("Data Breakdown").Range("A10").Left
.Top = Worksheets("Data Breakdown").Range("G20").Top
End With
With .Shapes.AddPicture Filename := link & Pattern & Serial & P1 & t
.Name = Range("D14")
.ShapeRange.LockAspectRatio = msoFalse
.Width = 450
.Height = 500
.Left = Worksheets("Data Breakdown").Range("E10").Left
.Top = Worksheets("Data Breakdown").Range("G20").Top
End With
End If
End With
End Sub
Sub Image_Remove()
Dim picBild As Picture
With Worksheets("Data Breakdown")
For Each picBild In .Pictures
If picBild.Name = Range("C14") Then
picBild.Delete
Exit For
End If
Next picBild
For Each picBild In .Pictures
If picBild.Name = Range("D14") Then
picBild.Delete
Exit For
End If
Next picBild
End With
End Sub
Providing your variables point to a valid image I found the below code works.
Sub Test()
Dim sht As Worksheet
Set sht = Worksheets("Data Breakdown")
With sht
With .Shapes.AddPicture(Filename:=link & Pattern & Serial & P1 & t, _
LinkToFile:=True, SaveWithDocument:=True, _
Left:=.Range("A10").Left, Top:=.Range("G20").Top, Width:=450, Height:=500)
.Name = "ABC"
.LockAspectRatio = True
End With
End With
End Sub
The Help page for AddPicture says there's 7 required parameters.
My problem is when I press the command button it show the image but when I press it again the command button duplicates the image being displayed.
Private Sub CommandButton1_Click()
Dim pictureNameColumn As String 'column where picture name is found
Dim picturePasteColumn As String 'column where picture is to be pasted
Dim pictureName As String 'picture name
Dim lastPictureRow As Long 'last row in use where picture names are
Dim pictureRow As Long 'current picture row to be processed
Dim pathForPicture As String 'path of pictures
pictureNameColumn = "A"
picturePasteColumn = "E"
pictureRow = 2 'starts from this row
'error handler
On Error GoTo Err_Handler
'find row of the last cell in use in the column where picture names are
lastPictureRow = Cells(Rows.Count, pictureNameColumn).End(xlUp).Row
'stop screen updates while macro is running
Application.ScreenUpdating = False
pathForPicture = "C:\Users\drawing\Desktop\pic\"
'loop till last row
Do While (pictureRow <= lastPictureRow)
pictureName = Cells(pictureRow, "A") 'This is the picture name
'if picture name is not blank then
If (pictureName <> vbNullString) Then
'check if pic is present
'Start If block with .JPG
If (Dir(pathForPicture & pictureName & ".jpg") <> vbNullString) Then
Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".jpg").Select 'Path to where pictures are stored
With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With
'End If block with .JPG
'Start ElseIf block with .PNG
ElseIf (Dir(pathForPicture & pictureName & ".png") <> vbNullString) Then
Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".png").Select 'Path to where pictures are stored
With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With
'End ElseIf block with .PNG
'Start ElseIf block with .BMP
ElseIf (Dir(pathForPicture & pictureName & ".bmp") <> vbNullString) Then
Cells(pictureRow, picturePasteColumn).Select 'This is where picture will be inserted
ActiveSheet.Pictures.Insert(pathForPicture & pictureName & ".bmp").Select 'Path to where pictures are stored
With Selection
.Left = Cells(pictureRow, picturePasteColumn).Left
.Top = Cells(pictureRow, picturePasteColumn).Top
.ShapeRange.LockAspectRatio = msoFalse
.ShapeRange.Height = 100#
.ShapeRange.Width = 130#
.ShapeRange.Rotation = 0#
End With
'End ElseIf block with .BMP
Else
'picture name was there, but no such picture
Cells(pictureRow, picturePasteColumn) = "No Picture Found"
End If
Else
'picture name cell was blank
End If
'increment row count
pictureRow = pictureRow + 1
Loop
Exit_Sub:
Range("A10").Select
Application.ScreenUpdating = True
Exit Sub
Err_Handler:
MsgBox "Error encountered. " & Err.Description, vbCritical, "Error"
GoTo Exit_Sub
End Sub
What I want is when I press the button again the previous image will just be replaced by the new image base on the column A.
You need to locate the existing picture based on its position, then delete it, before inserting the next picture.
Loop over all the pictures in the sheet and check their position - when you find one which matches where you want to insert the new picture, delete it.
Sub tester()
DeletePicFromCell Range("I3")
End Sub
Sub DeletePicFromCell(c As Range)
Const MARGIN As Long = 10 '<< how far the picture can be out of place
Dim shp
For Each shp In c.Parent.Shapes
If Abs(shp.Left - c.Left) < MARGIN And _
Abs(shp.Top - c.Top) < MARGIN Then
shp.Delete
Exit For '<< done checking
End If
Next shp
End Sub
BTW you don't need all those blocks checking for different extensions: assuming all the potential matches are images you can do something like
Dim fName
fName = Dir(pathForPicture & pictureName & ".*") '<< match any extension
If Len(fName)>0 Then
'Have a match
'Insert image from pathForPicture & fName
End If
EDIT: your original code reworked
Private Sub CommandButton1_Click()
Const COL_PIC_NAME As Long = 1 'column where picture name is found
Const COL_PIC_PASTE As Long = 5 'column where picture is to be pasted
Const PIC_PATH As String = "C:\Users\drawing\Desktop\pic\"
Dim pictureName As String 'picture name
Dim pictureFile As String 'picture file
Dim pictureRow As Long 'current picture row to be processed
Dim sht As Worksheet
Dim picCell As Range
Set sht = ActiveSheet
For pictureRow = 2 To sht.Cells(sht.Rows.Count, COL_PIC_NAME).End(xlUp).Row
pictureName = sht.Cells(pictureRow, COL_PIC_NAME) 'This is the picture name
If Len(pictureName) > 0 Then
pictureFile = Dir(PIC_PATH & pictureName & ".*", vbNormal) 'is there a matching file?
If Len(pictureFile) > 0 Then
Set picCell = sht.Cells(pictureRow, COL_PIC_PASTE)
DeletePicFromCell picCell 'delete any previous picture
With sht.Pictures.Insert(PIC_PATH & pictureFile)
.Left = picCell.Left
.Top = picCell.Top
.ShapeRange.LockAspectRatio = msoFalse
.Height = 100
.Width = 130
End With
End If 'have picture
End If 'have picname
Next pictureRow
End Sub
I am looking for assistance in getting Excel to ask the user what workbook should be selected to work with. I have a Workbook that has buttons linked to macros to perform tasks but each month I need to import updated data. I would like to have the two workbooks open at the same time and then allow the user to be prompted which workbook should be utilized for importing updated data. Currently I have code that allows the user to select which sheet should be used but only from the document in which the Macro is run from. The monthly workbooks don't have a standard naming convention.
Sub Macro6()
'
' Macro6 Macro
'
'
Const ColItems As Long = 20
Const LetterWidth As Long = 20
Const HeightRowz As Long = 18
Const SheetID As String = "__SheetSelection"
Dim i%, TopPos%, iSet%, optCols%, intLetters%, optMaxChars%, optLeft%
Dim wsDlg As DialogSheet, objOpt As OptionButton, optCaption$, objSheet As
Object
optCaption = "": i = 0
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
ActiveWorkbook.DialogSheets(SheetID).Delete
Application.DisplayAlerts = True
Err.Clear
Set wsDlg = ActiveWorkbook.DialogSheets.Add
With wsDlg
.Name = SheetID
.Visible = xlSheetHidden
iSet = 0: optCols = 0: optMaxChars = 0: optLeft = 78: TopPos = 40
For Each objSheet In ActiveWorkbook.Sheets
If objSheet.Visible = xlSheetVisible Then
i = i + 1
If i Mod ColItems = 1 Then
optCols = optCols + 1
TopPos = 40
optLeft = optLeft + (optMaxChars * LetterWidth)
optMaxChars = 0
End If
intLetters = Len(objSheet.Name)
If intLetters > optMaxChars Then optMaxChars = intLetters
iSet = iSet + 1
.OptionButtons.Add optLeft, TopPos, intLetters * LetterWidth, 16.5
.OptionButtons(iSet).Text = objSheet.Name
TopPos = TopPos + 13
End If
Next objSheet
If i > 0 Then
.Buttons.Left = optLeft + (optMaxChars * LetterWidth) + 24
With .DialogFrame
.Height = Application.Max(68, WorksheetFunction.Min(iSet, ColItems) *
HeightRowz + 10)
.Width = optLeft + (optMaxChars * LetterWidth) + 24
.Caption = "Select sheet to go to"
End With
.Buttons("Button 2").BringToFront
.Buttons("Button 3").BringToFront
Application.ScreenUpdating = True
If .Show = True Then
For Each objOpt In wsDlg.OptionButtons
If objOpt.Value = xlOn Then
optCaption = objOpt.Caption
Exit For
End If
Next objOpt
End If
If optCaption = "" Then
MsgBox "You did not select a worksheet.", 48, "Cannot continue"
Exit Sub
Else
Sheets(optCaption).Activate
End If
End If
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
End Sub
If you want a workbook, just use an Application.Inputbox with type:=8 (i.e. select range). This will allow them to select any cell in any worksheet in any open workbook.
The worksheet is the parent of the cell and the workbook is the parent of the worksheet.
dim rng as range, wb as workbook
set rng = application.inputbox("select a cell on the workbook you want.", type:=8)
debug.print rng.address(0,0)
debug.print rng.address(0,0, external:=true)
debug.print rng.parent.name
debug.print rng.parent.codename
debug.print rng.parent.parent.name
debug.print rng.parent.parent.fullname
set wb = rng.parent.parent
debug.print wb.name
debug.print wb.worksheets(1).name