社区 › VB › VBA中的图像另存为

Jeff_M 发表于 2006-12-13 15:52:50

VBA中的图像另存为

有人知道访问图像另存为的方法吗&nbsp；我使用的是光栅设计07，但我想我没有任何参考集（我接下来会检查）；我正在尝试将jpg文件转换为二进制tif文件

Jeff_M 发表于 2006-12-14 17:10:36

嗯，我添加了对任何看起来像光栅的引用，但我仍然不知道如何获得saveas&nbsp；不过，我找到了2位tif文件的设置

Jeff_M 发表于 2006-12-14 18:11:15

我不知道&#039；没有ARD2007，但ARD2006有一个ActiveX帮助文件。It#039；这并没有多大帮助，但是有一些关于SaveAs和Export的例子。这里是#039；s保存为：
Sub Example_SaveAs()

' This example searches through all images in the Current Space and will prompt the
' user to save all images of the RLC type. This routine then uses a Save As call
' to save the image using the appropriate image file type. To test this routine,
' insert at least one RLC image.

' This calls a procedure to load Cad Overlay. All procedures that use Cad Overlay
' objects must ensure that Cad Overlay is currently loaded.

EXLoadCadOverlay.Example_EXLoadCadOverlay

' Declare the necessary variables.
Dim imID As Long ' The Object ID of the images.
Dim imCurName As String ' The currently saved path and name of the image.
Dim imNewName As String ' The new path and name for the image.
Dim I, J As Integer ' For counting.

' Declare objects to utilize their respective classes.
Dim coList As AecImageObjectList
Dim coWrite As AecImageWrite
Dim coFileName As AecCoImageInfo

' Set the objects to their respective classes.
Set coList = ThisDrawing.Application.GetInterfaceObject("CADOverlay.AecImageObjectList")
Set coWrite = ThisDrawing.Application.GetInterfaceObject("CADOverlay.AecImageWrite")
Set coFileName = ThisDrawing.Application.GetInterfaceObject("CADOverlay.AecCoImageInfo")

' Search all images in the current space to determine if they are of type RLC. If they
' are, prompt the user to save that particular image. CurrentSpaceCount is 0 based; set
' I = 0 to CurrentSpaceCount -1. The Image Object ID is passed to the AecCoImageInfo
' object to retrieve the File Name and passed to the AecImageWrite object to write out
' the file with the Save As method.

For I = 0 To coList.CurrentSpaceCount - 1
imID = coList.CurrentSpaceObjectID(I)
coWrite.ImageObjectID = imID
coFileName.ImageObjectID = imID
imCurName = coFileName.SavedImageFilePath
If Right(coFileName.SavedImageFilePath, 3) = "rlc" Then
J = J + 1
If MsgBox("Save This Image?", vbYesNo, imCurName) = vbYes Then
coWrite.Format = coRLC
imNewName = "c:\Temp" & J & ".rlc"
coWrite.SaveAs (imNewName)
End If
End If
Next

' Formats supported for Save, Save As, and Export are BMP, RLE, DIB, CAL, GP4, RST, MIL,
' CG4, FLC, FLI, JPG, PCX, PNG, RLC (with IST header), TGA, TIF.

End Sub

并且帮助确实记录了只需要一个参考：

Jeff_M 发表于 2006-12-15 11:12:47

嗯，我越来越近了，现在我只需要找出如何反转图像

Jeff_M 发表于 2006-12-15 12:38:00

好吧，这太难看了，因为我不得不使用sendcommand三次（是的，我知道），所以如果有人能找到改进它的方法，我很乐意接受建议
Option Explicit
Public Sub ImgConvert()
    Dim currentline As String, objimg As AcadRasterImage
    Dim inspt(2) As Double
    inspt(0) = 0: inspt(1) = 0: inspt(2) = 0
    Open "c:\jpgconvert.dat" For Input As 1
    While Not EOF(1)
      Line Input #1, currentline
      Set objimg = ThisDrawing.ModelSpace.AddRaster(currentline, inspt, 1, 0)
      ThisDrawing.Regen acAllViewports
      ZoomExtents
      ConvertJPG
      imgdet
    Wend
    Close 1
End Sub
Private Sub imgdet()
    ThisDrawing.SendCommand "-image" & vbCr & "D" & vbCr & "*" & vbCr
End Sub
Private Sub ConvertJPG()
    Dim imgPath As String
    Dim objimg As AcadRasterImage
    Dim imID As Long    ' The Object ID of the images.
    Dim imCurName As String    ' The currently saved path and name of the image.
    Dim imNewName As String    ' The new path and name for the image.
    Dim I, J As Integer    ' For counting.
    ' Declare objects to utilize their respective classes.
    Dim coList As AecImageObjectList
    Dim coFileName As AecCoImageInfo
    Dim coWrite As AecImageWrite
    ' Set the objects to their respective classes.
    Set coList = ThisDrawing.Application.GetInterfaceObject("CADOverlay.AecImageObjectList")
    Set coFileName = ThisDrawing.Application.GetInterfaceObject("CADOverlay.AecCoImageInfo")
    Set coWrite = ThisDrawing.Application.GetInterfaceObject("CADOverlay.AecImageWrite")
    For I = 0 To coList.CurrentSpaceCount - 1
      imID = coList.CurrentSpaceObjectID(I)
      coFileName.ImageObjectID = imID
      coWrite.ImageObjectID = imID
      imCurName = coFileName.SavedImageFilePath
      'imgPath=imCurName
      If Right(imCurName, 3) = "jpg" Then
            J = J + 1
            'If MsgBox("Export This Image?", vbYesNo, imCurName) = vbYes Then
            ' Format each image as a TIFF, add a World File (*.tfw), use an uncompressed
            ' encoding method, Stripped data organization type and Maintain the drawing
            ' link.
            Call imgin
            Call smashitdown
            coWrite.Format = "Tagged Image File Format"
            coWrite.EncodingMethod = "CCITT (Fax) Group 4"
            imNewName = Left(imCurName, Len(imCurName) - 4) & ".tif"
            coWrite.Export (imNewName)
            'End If
      End If
    Next
End Sub
Private Sub imgin()
    ThisDrawing.SendCommand "iinvert" & vbCr
End Sub
Private Sub smashitdown()
    ThisDrawing.SendCommand "_IDEPTH" & vbCr & "B" & vbCr
End Sub

Jeff_M 发表于 2006-12-15 12:51:56

顺便说一句，光栅必须在运行之前初始化，否则它会很难崩溃

Jeff_M 发表于 2006-12-20 16:50:41

什么，没有接受者？

Jeff_M 发表于 2006-12-20 17:36:58

对不起，我查看了一下，在对象模型中找不到任何可以消除sendCommand的内容。我以为我贴了，但显然我没有#039；不要走那么远
我知道你可以通过弄乱图像字典来删除Imagedefs，因为我写了一个Lisp来分离无效/未引用的图像。但是倒置&amp；深度超出了我对图像的了解。

Jeff_M 发表于 2006-12-21 10:14:54

谢谢杰夫&nbsp；我也找不到任何可以摆脱SendCommands的东西&nbsp；我真的很失望，这是我第一次使用sendcommand。

查看完整版本: VBA中的图像另存为