Help with VBA code to Copy / Paste Visio sheet to another Visio fi

[Dennis]

Using Visio 2003

I have pieced together some VBA code from prior postings in Visio.general
newsgroup. Apparantly, I should have questioned the VBA in this newsgroup.

When it comes to VBA especially related to Visio, I am very dangerous and
fankly incompetent.

The VBA code below was developed by Al Edlund and he was kind enough to
share it in 2005 and 2003 with many who would like to have a Copy / Past
Utility approximating what is available in Excel (copy tab or "sheets").

When Al shared the code he was clear that the code was excerpted. That
said, I would like to be able to use it if possible.

In his code shared in May 2005, two functions were absent,
funcReplaceStr() and
funcGetTokens.

I was advised to change funcReplaceStr(), with apparently, a generic
Replace() function.

Wen I did that the following line it fails with a ByRef type mismatch error:
tgtPage.Name = Left(funcGetTokens (strDocName, "Guideline", 1), 23) &
curPageIndx & "Exmpl"

That line is fed with the code above:
strDocName = funcReplaceStr(srcDoc.Name, " ", "", 1)
-which was-
strDocName = Replace(srcDoc.Name, " ", "", 1)

My guess is that Replace() may not provide what funcGetTokens wants to see.

Can anyone help me get this code to function?

Dennis


*****************************************************

' Al Edlund copy/paste process as posted 5/23/2005

Sub myCopyPaste() 'This line was added by me
' Process the pages
strCurStep = "start process other files"
Set pagsObj = srcDoc.Pages
' iterate through the collection
For curPageIndx = 1 To pagsObj.Count
' retrieve the page object at the current index
Set srcPage = pagsObj.Item(curPageIndx)

' Check whether the current page is a background page
' Display the name of all the foreground pages
If srcPage.Background = False Then
strCurStep = "work on foreground pages"
' take spaces out of the document name
strDocName = Replace(srcDoc.Name, " ", "", 1)

' create the new page
Set tgtPage = tgtDoc.Pages.Add
' the target page name is the source document and page number
tgtPage.Name = Left(funcGetTokens(strDocName, "Guideline", 1), 23) &
curPageIndx & "Exmpl"
tgtPage.BackPage = "Background General"
tgtPage.Background = False
blnResult = funcCopyPageFormat(tgtPage, srcPage)
If blnResult = False Then Debug.Print "Result Copy Page format";
failed; ""
strCurStep = "copy the page"
Visio.Application.ScreenUpdati­ng = False
blnResult = funcCopyPage(tgtPage, srcPage)
If blnResult = False Then Debug.Print "Result Copy Page failed"
Visio.Application.ScreenUpdati­ng = True
tgtWin.Activate
ActivePage.Name = tgtPage.Name
ActivePage.CenterDrawing
Else
' Process the background page or delete this section to ignore the
background pages
End If
Next curPageIndx
End Sub 'This line was added by me

Private Function funcCopyPage(tgtPage As Visio.Page, srcPage As Visio.Page)
As Boolean
Dim iObjCnt As Integer
Dim iConCtr As Integer
Dim iWinCtr As Integer
Dim strPageName As String
Dim curWin As Visio.Window
Dim strCurStep As String
On Error GoTo CopyPage_Err

' go to the source window
strCurStep = "activate source win"
srcWin.Activate
ActivePage.Name = srcPage.Name
' brute force method of copy
strCurStep = "Copy source"
ActiveWindow.SelectAll
ActiveWindow.Group
ActiveWindow.Copy

' now go and paste it
strCurStep = "activate target win"
tgtWin.Activate
strCurStep = "set target apctive page"
ActivePage.Name = tgtPage.Name
ActivePage.Paste

funcCopyPage = True

CopyPage_Exit:
DoEvents
Exit Function

CopyPage_Err:

Debug.Print "Error CopyPage Cur Step = "; strCurStep
Debug.Print "Error CopyPage " & Err.Number & ": " & Err.Description
funcCopyPage = False
Resume CopyPage_Exit

End Function

' We want to copy page formats to target pages for a number of reasons
' which include common looks as well as maintaining integrity of copied
' pages.

Private Function funcCopyPageFormat(tgtPage As Visio.Page, srcPage As
Visio.Page) As Boolean

Dim tgtPageSheet As Visio.Shape
Dim srcPageSheet As Visio.Shape

On Error GoTo CopyPageFormat_Err

Set tgtPageSheet = tgtPage.PageSheet
Set srcPageSheet = srcPage.PageSheet

'Debug.Print "change size type"
tgtPageSheet.Cells("DrawingSiz­eType").FormulaU =
srcPageSheet.Cells("DrawingSiz­eType").FormulaU
'Debug.Print "change scale type"
tgtPageSheet.Cells("DrawingSca­leType").FormulaU =
srcPageSheet.Cells("DrawingSca­leType").FormulaU
'Debug.Print " drawing scale"
tgtPageSheet.Cells("DrawingSca­le").FormulaU =
srcPageSheet.Cells("DrawingSca­le").FormulaU
'Debug.Print " page scale "
tgtPageSheet.Cells("PageScale­").FormulaU =
srcPageSheet.Cells("PageScale­").FormulaU
'Debug.Print "width"
tgtPageSheet.Cells("PageWidth­").FormulaU =
srcPageSheet.Cells("PageWidth­").FormulaU
'Debug.Print "height"
tgtPageSheet.Cells("PageHeight­").FormulaU =
srcPageSheet.Cells("PageHeight­").FormulaU
'Debug.Print "route"
tgtPageSheet.Cells("RouteStyle­").FormulaU =
srcPageSheet.Cells("RouteStyle­").FormulaU

funcCopyPageFormat = True

CopyPageFormat_Exit:
DoEvents
Exit Function

CopyPageFormat_Err:

Debug.Print "Error CopyPageFormat " & Err.Number & ": " &
Err.Description
funcCopyPageFormat = False
Resume CopyPageFormat_Exit

End Function

Public Function funcGetTokens(strTemp As String, strDelimiter As String,
lngIndex As Long) As String


' funcGetTokens is a general parser that the user supplies
' an input string, a delimiter (1 or more characters) and an index
' into the input string to get a subset of the string
' if csv we watch for parens (i.e. embedded lists)


Dim lngTokenCount As Long
Dim lngCount As Long
Dim lngTempPos As Long
Dim lngSPos As Long
Dim lngEPos As Long
Dim intLenDel As Integer
Dim boolEmbeddedList As Boolean
Dim intListStart As Integer
Dim intListStop As Integer
Dim boolCSV As Boolean


' is this a csv parse ?
If strDelimiter = "," Then
boolCSV = True
Else
boolCSV = False
End If


intListStart = InStr(1, strTemp, "(", vbBinaryCompare)
intListStop = InStr(1, strTemp, ")", vbBinaryCompare)
If intListStop > intListStart Then
boolEmbeddedList = True
Else
boolEmbeddedList = False
End If


lngTokenCount = funcCountTokens(strTemp, strDelimiter)
If lngIndex < 1 Or lngIndex > lngTokenCount Then
funcGetTokens = 0
Exit Function
End If


intLenDel = Len(strDelimiter)
lngCount = 1
lngSPos = 1


If lngIndex = 1 Then
If boolCSV = True And boolEmbeddedList = True Then
' recheck where the list is from this spot
intListStart = InStr(1, strTemp, "(", vbBinaryCompare)
intListStop = InStr(1, strTemp, ")", vbBinaryCompare)
lngEPos = InStr(1, strTemp, strDelimiter) - intLenDel
' don't point into a list
If lngEPos < intListStart Then
funcGetTokens = Mid(strTemp, 1, lngEPos - 1 + intLenDel)
Exit Function
End If
Else
lngEPos = InStr(1, strTemp, strDelimiter) - intLenDel
funcGetTokens = Mid(strTemp, 1, lngEPos - 1 + intLenDel)
Exit Function
End If
End If


For lngCount = 2 To lngIndex
If boolCSV = True And boolEmbeddedList = True Then
' recheck where the list is from this spot
intListStart = InStr(lngSPos, strTemp, "(", vbBinaryCompare)
intListStop = InStr(lngSPos, strTemp, ")", vbBinaryCompare)
lngTempPos = InStr(lngSPos, strTemp, strDelimiter, 0) -
intLenDel
' don't point into a list
If lngTempPos < intListStart Or lngTempPos > intListStop Then
lngSPos = lngTempPos
lngCount = lngCount + 1
End If
Else
lngSPos = InStr(lngSPos, strTemp, strDelimiter, 0) + intLenDel
DoEvents
End If
Next lngCount
DoEvents
lngEPos = InStr(lngSPos, strTemp, strDelimiter, 0) - intLenDel


If lngEPos <= 0 Then
lngEPos = Len(strTemp)
End If
funcGetTokens = Mid(strTemp, lngSPos, lngEPos - lngSPos + intLenDel)


End Function


Public Function funcCountTokens(strTemp As String, strDelimiter As
String) As Long
'
' Counts strings separated by input string delimter
' if the delimiter is a comma then check for embedded lists
'
Dim lngTokenCount As Long
Dim lngIndex As Long
Dim lngTempIndex As Long
Dim lngDelLen As Long
Dim lngInput As Long
Dim boolEmbeddedList As Boolean
Dim intListStart As Integer
Dim intListStop As Integer
Dim boolCSV As Boolean


' is this a csv parse ?
If strDelimiter = "," Then
boolCSV = True
Else
boolCSV = False
End If


intListStart = InStr(1, strTemp, "(", vbBinaryCompare)
intListStop = InStr(1, strTemp, ")", vbBinaryCompare)
If intListStop > intListStart Then
boolEmbeddedList = True
Else
boolEmbeddedList = False
End If


lngInput = Len(strTemp)
If VarType(strTemp) <> vbString Or Len(strTemp) = 0 Then
funcCountTokens = 0
Exit Function
End If


lngDelLen = Len(strDelimiter)


' first check to see if there is a delimter in the string
lngIndex = InStr(strTemp, strDelimiter)
lngTokenCount = 1


Do While ((lngIndex > 0) And (lngIndex <= lngInput))
' since we got here we must have found a token
If boolCSV = True And boolEmbeddedList = True Then
' recheck where the list is from this spot
intListStart = InStr(1, strTemp, "(", vbBinaryCompare)
intListStop = InStr(1, strTemp, ")", vbBinaryCompare)
lngTempIndex = InStr(lngIndex + lngDelLen, strTemp,
strDelimiter, 0)
If lngTempIndex > intListStart Or lngTempIndex < intListStop
Then
lngTokenCount = lngTokenCount + 1
lngIndex = lngTempIndex
Else
lngIndex = lngIndex + 1
End If
Else
lngTokenCount = lngTokenCount + 1
lngIndex = InStr(lngIndex + lngDelLen, strTemp,
strDelimiter, 0)
End If
DoEvents
Loop


' suspect I need some logic for what happens if no delimter found
funcCountTokens = lngTokenCount


End Function

 

[JuneTheSecond]

I am not sure if i can be a help for you, but first of,
you would like to add declarations for the arguments which rejected by
compiler as failure with a ByRef type mismatch error, such that "Dim
strDocName as Visio.Document". I hope you can go step by step editing this
code.

 

[JuneTheSecond]

I am not sure if I can be a help for you, but first of all, you would add
declarations for some arguments rejected by compiler as failure with a ByRef
type mismatch error, such as "Dim strDocName as Visio.Document". I hope you
can go step by step editing the code.

 

[Dennis]

Thank you for your time and knowledge.

Your thoughts helped but - other issues still remain.

I am relatively new to Visio. In the Excel, Access and Word NG's I have
been used to "helpers" and MVP's who will actually spend some time especially
when it involed their own code. We all learned from each other.

Well, it is not your code and there are many lines of it. More important,
the code may have gone through many changes over time. A function OK in 2003
may not mesh with the 2005
main-procedure.

Frankly, I believe that if all of the functions which were missing from the
"original" presentation were now available, that I would not have these
issues today.

I have seen many requests for a copy/paste "sheet" functionality similar to
Excel. Yet somthing is holding back those in the know from having the
solution on their website and/or at their fingertips. If it cannot be done,
then someone should have the fortitude to say that. At least then, we
newbies would not waste time better applied to more fruitful possibilities.

Enjoy the upcomming holiday if one is on your calendar.

Dennis
***************************************************

 

[Al Edlund]

Dennis,
this line of code just removes spaces from the string (i.e. replace a space
" " with a null "")

strDocName = funcReplaceStr(srcDoc.Name, " ", "", 1)


this line builds a new page name from the old document name

tgtPage.Name = Left(funcGetTokens (strDocName, "Guideline", 1), 23) &
curPageIndx & "Exmpl"

and the output looks like this "CampusExecutiveOverview1Exmpl"

al

 

[Dennis]

Al,

Why does the Replace() function result (which is strDocName), fail with a
"ByRef type mismatch error" when it is utilized by the following function?
tgtPage.Name = Left(funcGetTokens (strDocName, "Guideline", 1), 23) &
curPageIndx & "Exmpl"

TIA Dennis

 

[Al Edlund]

Dennis,

I apologize because I misspoke, in VBA it is substitute not replace. Replace
is used when you know where the text is in the string.

al


Replaces part of a text string with a different text string.

SUBSTITUTE (text, old_text, new_text[, start_num][,ignore_case_opt)

text The text or the reference to a cell containing text for which you
want to substitute characters.

old_text The text you want to replace.

new_text The text you want to replace old_text with.

start_num_opt Optional. Specifies which occurence of old_text to replace.
If you specify start_num_opt, only that occurrence of old_text is replaced.
Otherwise, every occurrence of old_text in text is changed to new_text.

ignore_case_opt Optional. FALSE if case-sensitive; otherwise, TRUE. The
default is FALSE.