VBA中的图像另存为

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

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