Jump to content

Ficheiro Corrrupto

Recommended Posts


Boa Tarde

Tenho este código que vai copiar todos os objectos que existem na folha.

Option Explicit
Private Declare Function _
CloseClipboard& Lib "user32" ()
Private Declare Function _
OpenClipboard& Lib "user32" (ByVal hWnd&)
Private Declare Function _
EmptyClipboard& Lib "user32" ()
Private Declare Function _
GetClipboardData& Lib "user32" (ByVal wFormat&)
Private Declare Function _
GlobalSize& Lib "kernel32" (ByVal hMem&)
Private Declare Function _
GlobalLock& Lib "kernel32" (ByVal hMem&)
Private Declare Function _
GlobalUnlock& Lib "kernel32" (ByVal hMem&)
Private Declare Sub CopyMem Lib "kernel32" Alias _
"RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length&)

Sub copia()
Dim Sh As Shape, B() As Byte, Pos&, F&
For Each Sh In ActiveSheet.Shapes
If InStr(1, Sh.Name, "Object", 1) Then
  Sh.Copy     ' (49156 = Native format)
  If Not GetData(49156, B) Then Exit Sub
  Dim Buffer$, FileName$, Extension$
  Buffer = StrConv(B, vbUnicode)
  FileName = "Embedded"
  Extension = ".emb"
  Pos = InStr(3, Buffer, ".", 1)
  If Pos Then
    FileName = Mid$(Buffer, 3, Pos - 3)
    Extension = Mid$(Buffer, Pos, 4)
  End If
  FileName = "c:\" & FileName & Extension
  If Len(Dir(FileName)) Then Kill FileName
  F = FreeFile
  Open FileName For Binary As #F
  Put #F, , B
  Close #F
    End If
Next Sh

End Sub

Private Function GetData(ByVal Format&, abData() As Byte) As Boolean
Dim hWnd&, Size&, Ptr&
If OpenClipboard(0&) Then
' Get memory handle to the data
hWnd = GetClipboardData(Format)
' Get size of this memory block
If hWnd Then Size = GlobalSize(hWnd)
' Get pointer to the locked memory
If Size Then Ptr = GlobalLock(hWnd)
If Ptr Then
  ' Resize the byte array to hold the data
  ReDim abData(0 To Size - 1) As Byte
  ' Copy from the pointer into the array
  CopyMem abData(0), ByVal Ptr, Size
  ' Unlock the memory
  Call GlobalUnlock(hWnd)
  GetData = True
End If
End If
End Function

O meu problema, é que ele cria os objectos corruptos. E depois ao tentar descompactar com este código, ele não me faz nada.

Sub descomprime()
   Dim FSO As Object
   Dim oApp As Object
   Dim Fname As Variant
   Dim FileNameFolder As Variant
   Dim DefPath As String
   Dim strDate As String

 Fname = Application.GetOpenFilename(filefilter:="Zip Files (*.zip), *.zip", MultiSelect:=False)

   If Fname = False Then
       'Do nothing
  On Error Resume Next
       'Root folder for the new folder.
       'You can also use DefPath = "C:\Users\Ron\test\"
       DefPath = "C:\teste"
       If Right(DefPath, 1) <> "\" Then
           DefPath = DefPath & "\"
       End If

       'Create the folder name
       strDate = Format(Now, " dd-mm-yy h-mm-ss")
       FileNameFolder = DefPath

       'Make the normal folder in DefPath
      MkDir FileNameFolder

       'Extract the files into the newly created folder
       Set oApp = CreateObject("Shell.Application")

       oApp.Namespace(FileNameFolder).CopyHere oApp.Namespace(Fname).items

        MsgBox "You find the files here: " & FileNameFolder

       On Error Resume Next
       Set FSO = CreateObject("scripting.filesystemobject")
       FSO.deletefolder Environ("Temp") & "\Temporary Directory*", True
End If
End Sub

A informática chegou para resolver problemas que antes não existiam

Quem ri por último é porque está conectado a 52 Kbs.

Share this post

Link to post
Share on other sites

Create an account or sign in to comment

You need to be a member in order to leave a comment

Create an account

Sign up for a new account in our community. It's easy!

Register a new account

Sign in

Already have an account? Sign in here.

Sign In Now

  • Create New...

Important Information

By using this site you accept our Terms of Use and Privacy Policy. We have placed cookies on your device to help make this website better. You can adjust your cookie settings, otherwise we'll assume you're okay to continue.