Author Topic: VBA Image control  (Read 6872 times)

0 Members and 1 Guest are viewing this topic.

CmdrDuh

  • Automatic Duh Generator
  • King Gator
  • Posts: 4039
VBA Image control
« 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
Everyone has a photographic memory, Some just don't have film.
They say money can't buy happiness, but it can buy Bacon and that's a close second

Bob Wahr

  • Guest
Re: VBA Image control
« Reply #1 on: March 15, 2006, 12:16:00 PM »
Are you wanting to rename the tif file or just the tif reference name in the drawing?

CmdrDuh

  • Automatic Duh Generator
  • King Gator
  • Posts: 4039
Re: VBA Image control
« Reply #2 on: March 15, 2006, 12:22:07 PM »
rename if possible
Everyone has a photographic memory, Some just don't have film.
They say money can't buy happiness, but it can buy Bacon and that's a close second

Bob Wahr

  • Guest
Re: VBA Image control
« Reply #3 on: March 15, 2006, 01:16:10 PM »
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?

CmdrDuh

  • Automatic Duh Generator
  • King Gator
  • Posts: 4039
Re: VBA Image control
« Reply #4 on: March 15, 2006, 01:18:04 PM »
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
« Last Edit: March 15, 2006, 02:02:19 PM by CmdrDuh »
Everyone has a photographic memory, Some just don't have film.
They say money can't buy happiness, but it can buy Bacon and that's a close second

Bob Wahr

  • Guest
Re: VBA Image control
« Reply #5 on: March 15, 2006, 02:08:40 PM »
try this
Code: [Select]
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

CmdrDuh

  • Automatic Duh Generator
  • King Gator
  • Posts: 4039
Re: VBA Image control
« Reply #6 on: March 15, 2006, 02:15:41 PM »
it crashes on Rename???
Everyone has a photographic memory, Some just don't have film.
They say money can't buy happiness, but it can buy Bacon and that's a close second

Bob Wahr

  • Guest
Re: VBA Image control
« Reply #7 on: March 15, 2006, 02:17:45 PM »
doh, sorry, remove that line.

CmdrDuh

  • Automatic Duh Generator
  • King Gator
  • Posts: 4039
Re: VBA Image control
« Reply #8 on: March 15, 2006, 02:22:43 PM »
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%  ?
Everyone has a photographic memory, Some just don't have film.
They say money can't buy happiness, but it can buy Bacon and that's a close second

CmdrDuh

  • Automatic Duh Generator
  • King Gator
  • Posts: 4039
Re: VBA Image control
« Reply #9 on: March 15, 2006, 02:23:13 PM »
scale of 1.0 changes to 0.7531
Everyone has a photographic memory, Some just don't have film.
They say money can't buy happiness, but it can buy Bacon and that's a close second

Bob Wahr

  • Guest
Re: VBA Image control
« Reply #10 on: March 15, 2006, 02:57:09 PM »
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.

CmdrDuh

  • Automatic Duh Generator
  • King Gator
  • Posts: 4039
Re: VBA Image control
« Reply #11 on: March 15, 2006, 02:58:46 PM »
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
Everyone has a photographic memory, Some just don't have film.
They say money can't buy happiness, but it can buy Bacon and that's a close second

Bob Wahr

  • Guest
Re: VBA Image control
« Reply #12 on: March 15, 2006, 03:02:03 PM »
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.

CmdrDuh

  • Automatic Duh Generator
  • King Gator
  • Posts: 4039
Re: VBA Image control
« Reply #13 on: March 15, 2006, 03:20:49 PM »
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
Everyone has a photographic memory, Some just don't have film.
They say money can't buy happiness, but it can buy Bacon and that's a close second

Bob Wahr

  • Guest
Re: VBA Image control
« Reply #14 on: March 15, 2006, 03:23:45 PM »
Odd, my SF of one is changing to an SF of .1328

Works if you reset it afterwards though
Code: [Select]
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
  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