I'm investigating how to automatically update a visio file created with one mastershape (v1.0.vssx) to the next version of the mastershape (v1.1.vssx). When updating each master shape, use Master.Name as the key.
With the code below, I was able to open the vsdx file and vssx and open their respective Masters.
vssx_Master = vssxMaster
vsdx_shape.master = vssx_Master
I wondered if I could update the master shape with the code, but unfortunately vssxMaster is the same as vssxMaster.Name and its type is String.
Is there a way to replace the Master of one shape with another?
not work...
Sub Visio_Update(ByRef VISIOpath As String, ByRef except_sheets() As String, ByRef VSSXpath As String)
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim vsoApp As Visio.Application
Dim vsoDoc As Visio.Document
Dim vsoPage As Visio.Page
Dim vsoItemsCnt As Long
Dim vsoShape As Visio.Shape
Dim FileName As String
Dim FileText As String
FileName = Dir(VISIOpath)
FileName = Replace(FileName, ".vsdx", "")
ChDir ThisWorkbook.path
Set vsoApp = CreateObject("Visio.Application")
Call vsoApp.Documents.OpenEx(VISIOpath, visOpenRW)
Set vsoDoc = vsoApp.Documents.Item(1)
vsoItemsCnt = vsoApp.Documents.Count
Call vsoApp.Documents.OpenEx(VSSXpath, visOpenRW)
Set vssxDoc = vsoApp.Documents.Item(vsoItemsCnt + 1)
Set vssxMasters = vssxDoc.Masters
For Each vsoPage In vsoDoc.Pages
For Each vsoShape In vsoPage.Shapes
If Not (vsoShape.Master Is Nothing) Then
On Error Resume Next
mastername = vsoShape.Master.Name
vsoShape.ReplaceShape vssxMasters.Item(vsoShape.Master.Name)
If Err.Number = 0 Then
Debug.Print ("Masters.Item")
Debug.Print "updated succeeded : ", mastername
Err.Clear
Else
Debug.Print ("Masters.Item")
Debug.Print Err.Description
Err.Clear
End If
End If
Next
Next
vsoDoc.SaveAs ThisWorkbook.path & "\data\" & FileName & "_updated_.vsdx"
Application.ScreenUpdating = True
End Sub
Sub test()
choosed_path = "C:\Users\11665307\Desktop\data\vs1.vsdx"
Update_Template = "C:\Users\11665307\Documents\test.vssx"
Call Visio_Update(choosed_path, except_sheets, (Update_Template))
End Sub
I wondered if I could update the master shape with the code
You dont need iterate all masters into stencil :)
For Each vsoPage In doc.Pages
For Each vsoShape In vsoPage.Shapes
If Not (vsoShape.Master Is Nothing) Then
vsoShape.ReplaceShape vssxMasters.Item(vsoShape.Master.Name)
End If
Next
Next
You must iterate through all the shapes on the page. If the shape was created based on the master from stencil v.1.0, then replace it with the corresponding master v.1.1. using the ReplaceShape method
Sub ttt()
Dim sh As Shape
For Each sh In ActivePage.Shapes
If sh.Master.NameU = "Circle" Then sh.ReplaceShape Application.Documents.Item("BLOCK_M.vssx").Masters.ItemU("Diamond")
Next
End Sub
Related
I am looking in the Folder for specific file in .docx and want to open it. I put the Name of X into Inputbox, go to Sheet Y, look on the next right cell of X and open this as Word (next cell right is an file in word I want to open). It is working, but the Problem is that the target Word Doc may be in multiples subfolders. Is there any quick way to search in These subfolder?
Private Sub CommandButton1_Click()
On Error GoTo ErrorHandling
Application.ScreenUpdating = False
Dim AppWD As Object
Dim SearchX As String
Dim SearchArea As Range
Dim Y As String
Dim sPath As String
sPath = "C:\Users\VS\Desktop\test"
SearchRule = InputBox("X")
Set SearchArea = Sheets("Look").Range("A:A").Find(what:=SearchX, _
LookIn:=xlFormulas, lookat:=xlWhole)
ActiveWindow.Visible = True
Target = SearchArea.Offset(0, 1).Value
Set AppWD = CreateObject("Word.Application")
AppWD.Visible = True
AppWD.documents.Open (sPath & "\" & Target & "." & "docx")
ErrorHandling: Exit Sub
End Sub
My take on searching throught subfolders
Sub searchSub()
Dim fso As FileSystemObject, fFile As File, fFolder As Folder
Dim fSubFolder As Folder, fPath As String, FileToSearch As String
Set fso = New FileSystemObject
FileToSearch = "SomeDocument.docx"
fPath = ThisWorkbook.Path
Set fFolder = fso.GetFolder(fPath)
For Each fFolder In fFolder.SubFolders
Set fSubFolder = fso.GetFolder(fFolder.Path)
For Each fFile In fSubFolder.Files
If fFile.Name = FileToSearch Then
'do something with file
End If
Next fFile
Next fFolder
End Sub
I have the following working codes.
Column B has image names, this pulls images in the selected folder that match the names in column B and inserts them into Column A (please note, first two rows are used for my header). I've noticed that the code errors if the header in B2 is missing, then the code errors out. I would like to fix this so it will only try to find images if there is a name in Range("B3:B1002").
Option Explicit
Private Sub Add_Images_Click()
Const EXIT_TEXT As String = ""
Const NO_PICTURE_FOUND As String = "No picture found"
Dim picName As String
Dim picFullName As String
Dim rowIndex As Long
Dim lastRow As Long
Dim selectedFolder As String
Dim data() As Variant
Dim wks As Worksheet
Dim Cell As Range
Dim pic As Picture
On Error GoTo ErrorHandler
selectedFolder = GetFolder
If Len(selectedFolder) = 0 Then GoTo ExitRoutine
Application.ScreenUpdating = False
Set wks = ActiveSheet
lastRow = wks.Cells(2, "B").End(xlDown).Row
data = wks.Range(wks.Cells(1, "B"), wks.Cells(lastRow, "B")).Value2
For rowIndex = 3 To UBound(data, 1)
If StrComp(data(rowIndex, 1), EXIT_TEXT, vbTextCompare) = 0 Then GoTo ExitRoutine
picName = data(rowIndex, 1)
picFullName = selectedFolder & picName
If Len(Dir(picFullName)) > 0 Then
Set Cell = wks.Cells(rowIndex, "A")
Set pic = wks.Pictures.Insert(picFullName)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = Cell.Height
.Width = Cell.Width
.Top = Cell.Top
.Left = Cell.Left
.Placement = xlMoveAndSize
End With
Else
wks.Cells(rowIndex, "A").Value = NO_PICTURE_FOUND
End If
Next rowIndex
ExitRoutine:
Set wks = Nothing
Set pic = Nothing
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
MsgBox Prompt:="Unable to find photo", _
Title:="An error occured", _
Buttons:=vbExclamation
Resume ExitRoutine
End Sub
This is the Function that has the user select the folder that contains the images when the above sub is ran. I would like to modify this if possible to also work with an URL like an FTP site. So if the images are in a folder on the users pc, it will run like below, but if the images are located in a FTP location, it will still be able to pull the images.
Private Function GetFolder() As String
Dim selectedFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & "\"
.Title = "Select the folder containing the Image/PDF files."
.Show
If .SelectedItems.Count > 0 Then
selectedFolder = .SelectedItems(1)
If Right$(selectedFolder, 1) <> Application.PathSeparator Then _
selectedFolder = selectedFolder & Application.PathSeparator
End If
End With
GetFolder = selectedFolder
End Function
This Sub is meant to remove all images from column A. The problem is that this works too well. It is fine when used with a normal button, but when I try using a CommandButton to have my buttons on a user form, this Sub removes the CommandButton. It also removes all comments from the sheet. I would like to either limit this to only remove images, or to quarantine the code to only look at Range("A3:A1002").
Private Sub Remove_Images_Click()
'Remove Images
Dim wks As Worksheet
Dim shp As Shape
Dim picArray() As String
Dim index As Integer
On Error GoTo ErrorHandler
Columns(1).Replace What:="No Picture Found", Replacement:=vbNullString, LookAt:=xlPart
Set wks = ActiveSheet
index = 1
For Each shp In wks.Shapes
If shp.Type <> msoFormControl Then
ReDim Preserve picArray(1 To index)
picArray(index) = shp.Name
index = index + 1
End If
Next shp
wks.Shapes.Range(picArray).Delete
ExitRoutine:
Set wks = Nothing
Set shp = Nothing
Erase picArray
Exit Sub
ErrorHandler:
MsgBox Prompt:="Unable to find photo", _
Title:="An error occured", _
Buttons:=vbExclamation
Resume ExitRoutine
End Sub
I see three main questions, probably better to separate these into different questions but I'll give it a shot.
Ignore row 2 in the first code block.
Change 1 to 3 on this line: data = wks.Range(wks.Cells(3, "B"), wks.Cells(lastRow, "B")).Value2 This sets your data range starting at row 3 and ignores your two header rows.
FTP link
This is better suited for a separate question. Start by creating a new function that handles FTP links. Then identify which path is in the cell, i.e. does it start with http, c://, etc... Then call appropriate function and have it return the image to the main program.
Check if shape is in column A.
Use the TopLeftCell attribute and see if it intersects column A
For Each shp In wks.Shapes
If Not Intersect(shp.TopLeftCell, Columns(1)) Is Nothing Then '<-- New Line checks if in col A
If shp.Type <> msoFormControl Then
....
I currently have a list of files with the file path (C:/something.xlxs) in column B of a sheet. I want to write a Macro to read the value from the cell, open the file, and then move on to the next cell and open that file, etc.
I currently have this:
Sub openFiles()
Dim sFullName As String
Dim i As Integer
For i = 1 To 5
If Not IsEmpty(Cells(i, 2)) Then
sFullName = Cells(i, 2).Value
Workbooks.Open fileName:=Cells(i, 2).Value, UpdateLinks:=0
End If
Next i
End Sub
It is only opening the first file from the list and then stopping. It is probably a small error but I am having trouble spotting it.
Thanks
I would do it this way:
Sub openFiles()
Dim sFullName As String
Dim i As Integer
Dim wsh As Worksheet
On Error GoTo Err_openFiles
Set wsh = ThisWorkbook.Worksheets("Sheet1")
i = 1
Do While wsh.Range("B" & i)<>""
sFullName = wsh.Range("B" & i)
Application.Workbooks.Open sFullName, UpdateLinks:=False
i = i+1
Loop
Exit_openFiles:
On Error Resume Next
Set wsh = Nothing
Exit Sub
Err_openFiles:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_openFiles
End Sub
Above code works in context and provides a way to handle errors.
Try
Dim wb As Excel.Workbook
Set wb = Workbooks.Open(Filename:=sFullName)
I am attempting to log (1. what slide and 2. the time) to a spreadsheet each time a slide is viewed in presentation mode. I don't want to have the spreadsheet open when I do this and I want it to save automatically. I've been screwing around with it for a few hours now, and I've had varying success. I can't seem to get it to work as intended.
Here's the code I've crammed together so far:
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim strSheet As String
Dim strPath As String
Dim curentSlide As Integer
Dim timez As Date
Dim z As Integer
strSheet = "test.xlsx"
strPath = "C:\PPToutput\"
strSheet = strPath & strSheet
Dim counter As Integer
counter = 0
counter = counter + 1
currentslide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
timez = Now()
If Not IsNull(appExcel) And counter < 2 Then
Set appExcel = CreateObject("Excel.Application")
appExcel.Application.DisplayAlerts = False
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
End If
appExcel.Application.Visible = True
Range("A" & Rows.Count).End(xlUp).Offset(1).Value = "Slide " & currentslide
Range("B" & Rows.Count).End(xlUp).Offset(1).Value = timez
wks.Columns.AutoFit
wkb.SaveAs
Set appExcel = Nothing
appExcel.Workbooks.Close
appExcel.Quit
Set appExcel = Nothing
End Sub
I haven't tried the code out, but something I noticed is that this line:
appExcel.Application.Visible = False
comes after the excel program does stuff. I would imagine the workbook opening would be visible because that happens before this line.
Also, I don't see where you're telling the OnSlideShowPageChange sub anything about the workbook you created in the SlideShowBegin sub. You're telling it to do something with a range, which is not the one you declared earlier. So, it thinks you're talking about some range in the powerpoint. Do powerpoints even have ranges?
The other mistake is that you set all of your public declarations to nothing. Once you try to call them again, you're calling nothing. It's still a good idea to do that in your error handler, but not as a normal part of the process.
Look at the [untested] changes I made and see if they make sense:
Public appExcel As Excel.Application
Public wkb As Excel.Workbook
Public wks As Excel.Worksheet
Public rng As Excel.Range
Public strSheet As String
Public strPath As String
Public intRowCounter As Integer
Public intColumnCounter As Integer
Public itm As Object
Sub SlideShowBegin()
On Error GoTo ErrHandler
strSheet = "test.xlsx"
strPath = "C:\PPToutput\"
strSheet = strPath & strSheet
Debug.Print strSheet
'Select export folder
Dim curentSlide As Integer
Dim timez As Date
Dim z As Integer
Dim placeholder1 As String
Dim placeholder2 As String
currentslide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
timez = Now()
Set appExcel = CreateObject("Excel.Application")
appExcel.Application.Visible = False
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
wks.Range("A1").Value = "Current Slide"
wks.Range("B1").Value = "Time"
Exit Sub
ErrHandler:
If Err.Number = 1004 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, _
"Error"
Else
MsgBox Err.Number & "; Description: ", vbOKOnly, _
"Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
Dim curentSlide As Integer
Dim timez As Date
Dim z As Integer
Dim placeholder1 As String
Dim placeholder2 As String
currentslide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
timez = Now()
wks.Range("A" & Rows.Count).End(xlUp).Offset(1).Value = "Slide " & currentslide
wks.Range("B" & Rows.Count).End(xlUp).Offset(1).Value = timez
wks.Columns.AutoFit
wkb.Save
If SSW.View.CurrentShowPosition = _
SSW.Presentation.SlideShowSettings.EndingSlide Then
wkb.Save
wkb.Close
End If
End Sub
Sub SlideShowEnd()
wkb.Save
wkb.Close
End Sub
I rearranged your code a bit so that the initialization only occurs once during the slide show. I added another procedure to close Excel once the slide show has ended.
Private appExcel As Excel.Application
Private wkb As Excel.Workbook
Private wks As Excel.Worksheet
Private counter As Integer
Sub OnSlideShowPageChange(ByVal SSW As SlideShowWindow)
' initialization
Dim strSheet As String
Dim strPath As String
strSheet = "test.xlsx"
strPath = "C:\PPToutput\"
strSheet = strPath & strSheet
Debug.Print strSheet, appExcel Is Nothing
If appExcel Is Nothing Then
Set appExcel = CreateObject("Excel.Application")
appExcel.Application.DisplayAlerts = False
appExcel.WindowState = xlMinimized
appExcel.Visible = True
Set wkb = appExcel.Workbooks.Open(strSheet)
Set wks = wkb.Sheets(1)
counter = wks.UsedRange.Rows.Count - 1
End If
' make log entry
Dim currentSlide As Integer
currentSlide = ActivePresentation.SlideShowWindow.View.Slide.SlideIndex
counter = counter + 1
wks.Range("A" & counter).Value = "Slide " & currentSlide
wks.Range("B" & counter).Value = Now()
End Sub
Sub OnSlideShowTerminate(ByVal Wn As SlideShowWindow)
If Not appExcel Is Nothing Then
wks.Columns.AutoFit
appExcel.WindowState = xlNormal
wkb.Close True
appExcel.Quit
End If
Set appExcel = Nothing
End Sub
If it were my code, I'd also factor out the initialization code and put it in its own procedure so that the OnSlideShowPageChange procedure focused on the logging of the slide changes.
I have below Excel procedure I gather up and I am using it for couple of different calculations under different workbooks. So I was thinking instead changing the procedure for main and outcome files each time, I should be able to pick the file I want to carry out calculations in and the file path for outcomes files.
But I could not find anything for saving directory, I appreciate if you could help
Sub AsBuiltForm()
Dim SaveName As String
Dim mainBook As Workbook
a = InputBox("ENTER FIRST NUMBER ")
b = InputBox("ENTER LAST NUMBER ")
Workbooks.Open Filename:="C:\" 'main file can be browsed?
Set mainBook = Excel.Workbooks("CP.xlsx")
For i = a - 1 To b - 1
mainBook.Sheets(1).Range("bi1") = i + 1
SaveName = Sheets(1).Range("bi1").value & ".xlsx"
mainBook.SaveCopyAs "C:\" & SaveName 'save directory?
Workbooks.Open Filename:="C:\" & SaveName 'save directory?
With Excel.ActiveWorkbook
.Sheets("1 of 2").Range("A1:CT103").value = Sheets("1 of 2").Range("A1:CT103").value
.Sheets("2 of 2").Range("A1:CT103").value = Sheets("2 of 2").Range("A1:CT103").value
Excel.Application.DisplayAlerts = False
.Sheets("Sheet1").Delete
.Sheets("il oufall").Delete
.Sheets("1 of 2").Select
Columns("Bh:BZ").Select
Selection.Delete Shift:=xlToLeft
.Sheets("2 of 2").Select
Columns("Bn:BZ").Select
Selection.Delete Shift:=xlToLeft
.Close True
End With
Next
mainBook.Close False
Set mainBook = Nothing
End Sub
You can use Application.GetOpenFileName to pick files that you want to open at Run-Time.
You can use the function below to browse for a folder where you wish to save a file.
Sub FindFolder()
Dim myFolder as String
myFolder = BrowseFolder("Pick a Folder Where to Save")
End Sub
Function BrowseFolder(Optional Caption As String, Optional InitialFolder As String) As String
' based on Browse For Folder from:
' http://www.cpearson.com/excel/BrowseFolder.aspx
' this functions requires that the following Reference is active:
'Microsoft Shell Controls and Automation
Const BIF_RETURNONLYFSDIRS As Long = &H1
Dim wsh As Object
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Set wsh = CreateObject("Wscript.Shell")
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
If F = "Desktop" Then
BrowseFolder = wsh.Specialfolders(F)
Else
BrowseFolder = F.Items.Item.path
End If
End If
End Function
The following is not really an answer to your question, but a few tips to improve your code, and too long to add as a comment.
Workbooks.Open returns a Workbook object you can save the reference, so you don't have to rely on ActiveWorkbook:
Dim oWorkbook As Workbook
Set oWorkbook = Workbooks.Open(Filename:="C:\" & SaveName)
'***** Do something with oWorkbook
Debug.Print oWorkbook.FullName
Set oWorkbook = Nothing
A few other hints:
Use Option Explicit at the top of every module to force explicit declaration of all variables in order to find typos and other errors earlier.
Avoid selecting cells
Yes, browsing file works now; all the ins and outs aside, the problem i face with naming the file due to the variable "bi1" and saving as many loop as i asked for. I check several times before i bother you but i do not think i have the sufficient info to address "fn" as file in the use of Application.GetOpenFileName .
Option Explicit
Sub AsBuiltForm()
Dim fn
Dim myFolder As String
Dim SaveName As String, a As Integer, b As Integer, i As Integer
myFolder = BrowseFolder("Pick a Folder Where to Save")
MsgBox "Choose Calculation File "
fn = Application.GetOpenFilename
Workbooks.Open fn
a = InputBox("ENTER FIRST NUMBER ")
b = InputBox("ENTER LAST NUMBER ")
For i = a - 1 To b - 1 Step 1
Application.DisplayAlerts = False
Workbooks.Open Filename:=fn
Range("bi1") = i + 1
SaveName = ActiveWorkbook.Sheets(1).Range("bi1").value
Sheets(1).Range("A1:CT103").value = Sheets(1).Range("A1:CT103").value
Sheets(2).Range("A1:CT103").value = Sheets(2).Range("A1:CT103").value
Application.ActiveWorkbook.SaveAs myFolder & SaveName
ActiveWorkbook.Close True
Next
End Sub
Function BrowseFolder(Optional Caption As String, Optional InitialFolder As String) As String
' based on Browse For Folder from:
' http://www.cpearson.com/excel/BrowseFolder.aspx
' this functions requires that the following Reference is active:
'Microsoft Shell Controls and Automation
Const BIF_RETURNONLYFSDIRS As Long = &H1
Dim wsh As Object
Dim SH As Shell32.Shell
Dim F As Shell32.Folder
Set wsh = CreateObject("Wscript.Shell")
Set SH = New Shell32.Shell
Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)
If Not F Is Nothing Then
If F = "Desktop" Then
BrowseFolder = wsh.Specialfolders(F)
Else
BrowseFolder = F.Items.Item.Path
End If
End If
End Function