TheSwamp
Code Red => VB(A) => Topic started by: David Hall on March 15, 2006, 11:25:59 AM
-
OK, im stuck! :-( I have a user that created about 150 dwgs with Raster images, but didn't change the image name before he inserted them. I cant find any way to do a image saveas through code. Does anyone know of a way?
ex: dwg name UE06-03-0012.dwg
img name nhv-1000a.tif
should be named UE06-03-0012.tif
-
Are you wanting to rename the tif file or just the tif reference name in the drawing?
-
rename if possible
-
A few particulars
1) Are the paths saved on the tifs
a) If yes, always, definitely?
b) If not are they in the drawing folder?
2) Is there more than one tif in the drawing ever?
3) Will the new tif name always be the drawing name?
4) Anything else you can think of?
-
A few particulars
1) Are the paths saved on the tifs
a) If yes, always, definitely?
b) If not are they in the drawing folder?
2) Is there more than one tif in the drawing ever?
3) Will the new tif name always be the drawing name?
4) Anything else you can think of?
1-yes, a
2- no
3 - yes
4- Im hungry
4- I need a nap
-
try this
Sub RastaRenameMon()
Dim objSelSets As AcadSelectionSets
Dim objSelSet As AcadSelectionSet
Dim intType(0) As Integer
Dim varData(0) As Variant
Dim objImg As AcadRasterImage
Dim objNewImg As AcadRasterImage
Dim strImgName As String
Dim strDwgName As String
Dim strImgExt As String
Dim strImgPath As String
Dim strNewName As String
strDwgName = Left(ThisDrawing.Name, Len(ThisDrawing.Name) - 4)
Set objSelSets = ThisDrawing.SelectionSets
For Each objSelSet In objSelSets
If objSelSet.Name = "Imagen" Then
objSelSets.Item("Imagen").Delete
Exit For
End If
Next
Set objSelSet = objSelSets.Add("Imagen")
intType(0) = 0
varData(0) = "IMAGE"
objSelSet.Select acSelectionSetAll, _
filtertype:=intType, filterdata:=varData
If objSelSet.Count > 0 Then
For Each objImg In objSelSet
strImgExt = Right(objImg.ImageFile, 4)
strImgName = objImg.Name
strImgPath = Left(objImg.ImageFile, Len(objImg.ImageFile) - Len(strImgName) - 4)
strNewName = strImgPath & strDwgName & strImgExt
FileCopy objImg.ImageFile, strNewName
Set objNewImg = PaperSpace.AddRaster(strNewName, objImg.Origin, objImg.ScaleFactor, objImg.Rotation)
DetachImage (strImgName)
Kill strImgPath & strImgName & strImgExt
Rename
Next objImg
End If
End Sub
Function DetachImage(ByVal strName As String)
'Function jacked then Bobbed from Luis Alberto who got it somewhere else http://groups.google.com/group/autodesk.autocad.customization.vba/browse_thread/thread/2a3de0506ce1ed32/4e8b16d28d05e7a2%234e8b16d28d05e7a2?sa=X&oi=groupsr&start=0&num=3
On Error GoTo NoPicYo
Dim objImgDic As AcadDictionary
Dim objImg As AcadObject
Set objImgDic = ThisDrawing.Dictionaries("ACAD_IMAGE_DICT")
Set objImg = objImgDic(strName)
objImg.Delete
Bounce:
Exit Function
NoPicYo:
Set objImgDic = Nothing
Set objImg = Nothing
End Function
-
it crashes on Rename???
-
doh, sorry, remove that line.
-
tried that, and it works pretty well.
Why would it not use the scale from the old image? I step throughthe code, it takes the old scale, but then scales down the image by roughly 25% ?
-
scale of 1.0 changes to 0.7531
-
odd, not sure. I'll play with it some in a few. That was quick and dirty, I'm having to bounce back and forth between the CPU and the tech setting up my new plotter.
-
i think it might have something to do with the units being set to feet in the dwg. Im on 2006, so I have to make sure the insert units are set correctly
Thanks for the code though, it works great cept for that, and thats a easy fix
-
It looked like it did a randomish name to the new image reference, which was what the rename started as before I decided to let you worry about that. Didn't even think about the insert units. It could be cleaner but I had it about half way done before I got your answers. Started making it a lot more general, then cut to the more specific at the end.
-
ive done some testing where insert units and receiving uunits and all units are in inches, still does it. Oh well, its a easy fix
-
Odd, my SF of one is changing to an SF of .1328
Works if you reset it afterwards thoughSub RastaRenameMon()
Dim objSelSets As AcadSelectionSets
Dim objSelSet As AcadSelectionSet
Dim intType(0) As Integer
Dim varData(0) As Variant
Dim objImg As AcadRasterImage
Dim objNewImg As AcadRasterImage
Dim strImgName As String
Dim strDwgName As String
Dim strImgExt As String
Dim strImgPath As String
Dim strNewName As String
Dim dblScale As Double
strDwgName = Left(ThisDrawing.Name, Len(ThisDrawing.Name) - 4)
Set objSelSets = ThisDrawing.SelectionSets
For Each objSelSet In objSelSets
If objSelSet.Name = "Imagen" Then
objSelSets.Item("Imagen").Delete
Exit For
End If
Next
Set objSelSet = objSelSets.Add("Imagen")
intType(0) = 0
varData(0) = "IMAGE"
objSelSet.Select acSelectionSetAll, _
filtertype:=intType, filterdata:=varData
If objSelSet.Count > 0 Then
For Each objImg In objSelSet
strImgExt = Right(objImg.ImageFile, 4)
strImgName = objImg.Name
strImgPath = Left(objImg.ImageFile, Len(objImg.ImageFile) - Len(strImgName) - 4)
strNewName = strImgPath & strDwgName & strImgExt
FileCopy objImg.ImageFile, strNewName
dblScale = objImg.ScaleFactor
Set objNewImg = PaperSpace.AddRaster(strNewName, objImg.Origin, dblScale, objImg.Rotation)
objNewImg.ScaleFactor = dblScale
DetachImage (strImgName)
Kill strImgPath & strImgName & strImgExt
Next objImg
End If
End Sub
-
thankss
-
No problem, gave me an excuse to play with some code, never enough time to do that anymore.
-
Wouldn't it be easier to just change the ImagePath and Name properties to match the new Image, rather than inserting a new one and deleteing the old one? Plus that way, if there is any Xdata attached to it, it won't be lost.
-
Mostly because that would make way too much sense. Thanks for the reality check Jeff.
Sub RastaRenameMon()
Dim objSelSets As AcadSelectionSets
Dim objSelSet As AcadSelectionSet
Dim intType(0) As Integer
Dim varData(0) As Variant
Dim objImg As AcadRasterImage
Dim strImgName As String
Dim strDwgName As String
Dim strImgExt As String
Dim strImgPath As String
Dim strNewName As String
strDwgName = Left(ThisDrawing.Name, Len(ThisDrawing.Name) - 4)
Set objSelSets = ThisDrawing.SelectionSets
For Each objSelSet In objSelSets
If objSelSet.Name = "Imagen" Then
objSelSets.Item("Imagen").Delete
Exit For
End If
Next
Set objSelSet = objSelSets.Add("Imagen")
intType(0) = 0
varData(0) = "IMAGE"
objSelSet.Select acSelectionSetAll, _
filtertype:=intType, filterdata:=varData
If objSelSet.Count > 0 Then
For Each objImg In objSelSet
strImgExt = Right(objImg.ImageFile, 4)
strImgName = objImg.Name
strImgPath = Left(objImg.ImageFile, Len(objImg.ImageFile) - Len(strImgName) - 4)
strNewName = strImgPath & strDwgName & strImgExt
FileCopy objImg.ImageFile, strNewName
objImg.ImageFile = strNewName
objImg.Name = strDwgName
Kill strImgPath & strImgName & strImgExt
Next objImg
End If
End Sub
-
Private Sub RenameImages()
Dim i As Integer, sImageName As String
Dim oImage As AcadRasterImage
Dim SS As AcadSelectionSet
Dim sName As String
Dim NewPath As String
Dim Fs As Object
'Dim F As Object
Dim F As File
Dim filespec As String
Set Fs = CreateObject("Scripting.FileSystemObject")
sName = "UE06-03-0012"
Set SS = sset(0, "Image")
If SS.Count > 0 Then
For Each oImage In SS
filespec = oImage.ImageFile
Set F = Fs.GetFile(filespec)
NewPath = Replace(filespec, oImage.Name, sName)
F.Copy NewPath
oImage.Name = sName
oImage.ImageFile = NewPath
Debug.Print F.Path
F.Delete
Next oImage
End If
SS.Delete
End Sub
-
I get "User-defined type not defined" on the line Dim F As File
-
For that matter, NewPath doesn't work. Is that VB or VBA?
-
i think a little of both. Add the Ms scripting reference i think
-
head pulled out, um yeh, makes sense.
-
Had to run so I posted without the function. Vba . Bob does the replace not work for you? acad2000?
Here's the sset function, I like the ease of use it has.
Public Function sset(FilterType, FilterData As Variant, Optional ssName As String = "SS") As AcadSelectionSet
Dim oSSets As AcadSelectionSets
Set oSSets = ThisDrawing.SelectionSets
For Each sset In oSSets
If sset.Name = ssName Then
sset.Delete
Exit For
End If
Next
Dim FType() As Integer
Dim FData() As Variant
Dim i As Integer
If IsArray(FilterType) = False Then
If IsArray(FilterData) = False Then
ReDim FType(0)
ReDim FData(0)
FType(0) = FilterType
FData(0) = FilterData
Else
Exit Function
End If
Else
If UBound(FilterType) <> UBound(FilterData) Then
Exit Function 'They must be pairs
End If
ReDim FType(UBound(FilterType))
ReDim FData(UBound(FilterType))
For i = 0 To UBound(FilterType)
FType(i) = FilterType(i)
FData(i) = FilterData(i)
Next
End If
Set sset = ThisDrawing.SelectionSets.Add(ssName)
sset.Select 5, FilterType:=FType, FilterData:=FData
'To use this function for single filter
'Set SS = SSet(0, "insert")
'For multiple filter
'Set SS = SSet(array(0,2),array("insert",oBlock.name)) 'must be pairs
End Function
-
With the sset function, and after referencing the Scripting, everything was swell.
-
Bob or CmdrDuh , you don't know where I could get a help file for scripting do you?
-
Im leaving town for a few days, Ill look on monday
-
There is some documentation of scripting objects in the help file for VBA. Just hit F1 while in the IDE, pick the Contents tab, and expand Objects. You will see things like Dictionary, File, Folder, and etc. that all come from the scripting library.
-
Thanks Chuck.