.

Se puede aun extraer mas informacion; como son los procesos, y sus parametros (con sus tipos de datos), Complementos  (OCX), Formularios, Modulos, mm bueno TODO... Este codigo solo se limita a la extraccion de las APIS de un Ejecutable en VB6

 
'
'   /////////////////////////////////////////////////////////////
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandecido //
'   // o achicado, si es en base a este codigo                 //
'   /////////////////////////////////////////////////////////////
 
Option Explicit
 
Private Const MAX_PATH                  As Long = 260
 
Public Type IMAGE_DOS_HEADER
   Magic                                As Integer
   NumBytesLastPage                     As Integer
   NumPages                             As Integer
   NumRelocates                         As Integer
   NumHeaderBlks                        As Integer
   NumMinBlks                           As Integer
   NumMaxBlks                           As Integer
   SSPointer                            As Integer
   SPPointer                            As Integer
   Checksum                             As Integer
   IPPointer                            As Integer
   CurrentSeg                           As Integer
   RelocTablePointer                    As Integer
   Overlay                              As Integer
   ReservedW1(3)                        As Integer
   OEMType                              As Integer
   OEMData                              As Integer
   ReservedW2(9)                        As Integer
   ExeHeaderPointer                     As Long
End Type
 
Public Type IMAGE_DATA_DIRECTORY
   DataRVA                              As Long
   DataSize                             As Long
End Type
 
Public Type IMAGE_OPTIONAL_HEADER
   Magic                                As Integer
   MajorLinkVer                         As Byte
   MinorLinkVer                         As Byte
   CodeSize                             As Long
   InitDataSize                         As Long
   unInitDataSize                       As Long
   EntryPoint                           As Long
   CodeBase                             As Long
   DataBase                             As Long
   ImageBase                            As Long
   SectionAlignment                     As Long
   FileAlignment                        As Long
   MajorOSVer                           As Integer
   MinorOSVer                           As Integer
   MajorImageVer                        As Integer
   MinorImageVer                        As Integer
   MajorSSVer                           As Integer
   MinorSSVer                           As Integer
   Win32Ver                             As Long
   ImageSize                            As Long
   HeaderSize                           As Long
   Checksum                             As Long
   Subsystem                            As Integer
   DLLChars                             As Integer
   StackRes                             As Long
   StackCommit                          As Long
   HeapReserve                          As Long
   HeapCommit                           As Long
   LoaderFlags                          As Long
   RVAsAndSizes                         As Long
   DataEntries(15)                      As IMAGE_DATA_DIRECTORY
End Type
 
Public Type VBStart_Header
    PushStartOpcode                     As Byte
    PushStartAddress                    As Double
    CallStartOpcode                     As Byte
    CallStartAddress                    As Double
End Type
 
Private Type VBHeader
    lSignature                          As Long
    iRuntimeBuild                       As Integer
    sLanguageDLLName(13)                As Byte
    sSecLangDLLName(13)                 As Byte
    iRuntimeDLLVersion                  As Integer
    lLanguageID                         As Long
    lSecLanguageID                      As Long
    aSubMain                            As Long
    aProjectInfo                        As Long
    fMDLIntObjs                         As Long
    fMDLIntObjs2                        As Long
    lThreadFlags                        As Long
    lThreadCount                        As Long
    iGUIObjectCount                     As Integer
    iComponentCount                     As Integer
    lThunkCount                         As Long
    aGUIObjectArray                     As Long
    aComponentArray                     As Long
    aCOMRegData                         As Long
    oProjectExename                     As Long
    oProjectTitle                       As Long
    oHelpFile                           As Long
    oProjectName                        As Long
End Type
 
Private Type tProjectInfo
  Signature                             As Long
  aObjectTable                          As Long
  Null1                                 As Long
  aStartOfCode                          As Long
  aEndOfCode                            As Long
  Flag1                                 As Long
  ThreadSpace                           As Long
  aVBAExceptionhandler                  As Long
  aNativeCode                           As Long
  oProjectLocation                      As Integer
  Flag2                                 As Integer
  Flag3                                 As Integer
  OriginalPathName(MAX_PATH * 2)        As Byte
  NullSpacer                            As Byte
  aExternalTable                        As Long
  ExternalCount                         As Long
End Type
 
Public Type tAPIList
    strLibraryName                      As String
    strFunctionName                     As String
End Type
 
Type ExternalTable
   flag                                 As Long
   aExternalLibrary                     As Long
End Type
 
Type ExternalLibrary
   aLibraryName                         As Long
   aLibraryFunction                     As Long
End Type
 
 
Private St_DosHeader                    As IMAGE_DOS_HEADER
Private St_OptHeader                    As IMAGE_OPTIONAL_HEADER
Private St_VBStHeader                   As VBStart_Header
Private St_VBHeader                     As VBHeader
Private St_PInfo                        As tProjectInfo
Private St_ETable                       As ExternalTable
Private St_ELibrary                     As ExternalLibrary
Private int_NTFile                      As Integer
 
Public Function ExtractApisEXEVB6(StrPath As String) As tAPIList()
On Error GoTo End_:
Dim Tmp_APIList()                       As tAPIList
Dim Strs                                As String * 1024
Dim lng_PosNull                         As Long
Dim Lng_index                           As Long
Dim Lng_CantApis                        As Long
Dim NBytes(1 To 10)                     As Byte
 
    If Dir(StrPath, vbArchive) = "" Then Exit Function
    int_NTFile = FreeFile
    Open StrPath For Binary As int_NTFile
        If LOF(int_NTFile) > 0 Then
            Get int_NTFile, , St_DosHeader
            Get int_NTFile, _
                St_DosHeader.ExeHeaderPointer + &H19, _
                St_OptHeader '   //  20  <-> LenB(Header) + 5 => &H19
            Get int_NTFile, St_OptHeader.EntryPoint + 1, NBytes
            With St_VBStHeader
                .PushStartOpcode = NBytes(1)
                .PushStartAddress = GetDWord(NBytes(2), NBytes(3), NBytes(4), NBytes(5))
                .CallStartOpcode = NBytes(6)
                .CallStartAddress = GetDWord(NBytes(7), NBytes(8), NBytes(9), NBytes(10))
            End With
            Get int_NTFile, _
                (St_VBStHeader.PushStartAddress - St_OptHeader.ImageBase + 1), _
                St_VBHeader
            Get int_NTFile, _
                St_VBHeader.aProjectInfo + 1 - St_OptHeader.ImageBase, _
                St_PInfo
            Lng_CantApis = 0
            With St_PInfo
                For Lng_index = 0 To .ExternalCount - 1
                     Get int_NTFile, _
                         .aExternalTable + 1 + (Lng_index * 8) - St_OptHeader.ImageBase, _
                         St_ETable
                     If .ExternalCount > 0 And St_ETable.flag <> 6 Then
                        With St_ETable
                            Get int_NTFile, _
                                .aExternalLibrary + 1 - St_OptHeader.ImageBase, _
                                St_ELibrary
                            With St_ELibrary
                                If .aLibraryFunction <> 0 Then
 
                                    ReDim Preserve Tmp_APIList(Lng_CantApis)
                                    Seek int_NTFile, .aLibraryFunction + 1 - St_OptHeader.ImageBase
                                    With Tmp_APIList(Lng_CantApis)
                                        Do
                                            Get int_NTFile, , Strs
                                            lng_PosNull = InStr(1, Strs, Chr(0), vbBinaryCompare) - 1
                                            .strFunctionName = .strFunctionName & Mid$(Strs, 1, lng_PosNull)
                                        Loop Until lng_PosNull > 0
                                    End With
 
                                    Seek int_NTFile, .aLibraryName + 1 - St_OptHeader.ImageBase
                                    With Tmp_APIList(Lng_CantApis)
                                        Do
                                            Get int_NTFile, , Strs
                                            lng_PosNull = InStr(1, Strs, Chr(0), vbBinaryCompare) - 1
                                            .strLibraryName = .strLibraryName & Mid$(Strs, 1, lng_PosNull)
                                        Loop Until lng_PosNull > 0
                                    End With
 
                                    Lng_CantApis = Lng_CantApis + 1
 
                                End If
                            End With
                        End With
                     End If
                 Next Lng_index
             End With
         End If
    Close 1
    ExtractApisEXEVB6 = Tmp_APIList
    Exit Function
End_:
    On Error GoTo 0
    Call Err.Clear
End Function
 
Private Function GetDWord(ByVal B1 As Byte, ByVal B2 As Byte, ByVal B3 As Byte, ByVal B4 As Byte) As Double
    GetDWord# = GetWord(B1, B2) + 65536# * GetWord(B3, B4)
End Function
 
Private Function GetWord(ByVal B1 As Byte, ByVal B2 As Byte) As Double
    GetWord# = B1 + 256# * B2
End Function
 
 

ejemplo:

 
Sub Main()
Dim St_APIList()                        As tAPIList
Dim Lng_index                           As Variant
    St_APIList = ExtractApisEXEVB6("c:\a.exe")
    If (Not St_APIList) = -1 Then Exit Sub
    Debug.Print "Funciones", "Librerias"
    For Lng_index = LBound(St_APIList) To UBound(St_APIList)
        With St_APIList(Lng_index)
            Debug.Print .strFunctionName, .strLibraryName
        End With
    Next
End Sub
 
 

Dulce Infierno Lunar!¡.

.

 
'
'   /////////////////////////////////////////////////////////////
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandecido //
'   // o achicado, si es en base a este codigo                 //
'   /////////////////////////////////////////////////////////////
 
Option Explicit
 
Private Declare Function lstrcmp Lib "kernel32" Alias "lstrcmpA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function FindFirstFile& Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName$, lpFindFileData As WIN32_FIND_DATA)
Private Declare Function FindNextFile& Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile&, lpFindFileData As WIN32_FIND_DATA)
Private Declare Function GetFileAttributes Lib "kernel32" Alias "GetFileAttributesA" (ByVal lpFileName As String) As Long
Private Declare Function FindClose& Lib "kernel32" (ByVal hFindFile&)
 
Const MAX_PATH                              As Integer = 260
Const MAXDWORD                              As Long = &HFFFF
Const INVALID_HANDLE_VALUE                  As Long = -1
 
Private Type FILETIME
    dwLowDateTime                           As Long
    dwHighDateTime                          As Long
End Type
 
Private Type WIN32_FIND_DATA
    dwFileAttributes                        As Long
    ftCreationTime                          As FILETIME
    ftLastAccessTime                        As FILETIME
    ftLastWriteTime                         As FILETIME
    nFileSizeHigh                           As Long
    nFileSizeLow                            As Long
    dwReserved0                             As Long
    dwReserved1                             As Long
    cFileName                               As String * MAX_PATH
    cAlternate                              As String * 14
End Type
 
Event Folder(ByRef PathFolder As String, ByVal Atrributes As VbFileAttribute)
Event File(ByRef NameFile As String, ByRef TypeOfFile As Long, ByVal Atrributes As VbFileAttribute)
Event Begin()
Event Finish()
 
Private Priv_StrDir$, Priv_StrCri$(), Priv_IncFolder As Boolean, Priv_Cancel As Boolean
Private Priv_CriFindInDir As VbFileAttribute, Priv_CriFindInFile  As VbFileAttribute
Private Hwnd_SearchF&(), LS_Index&(0 To 1), BytesNow_#
Private Bool_Run As Byte
 
Public AllowEvents                          As Boolean
 
Private Sub Class_Initialize()
    Priv_IncFolder = True
    AllowEvents = True
    Priv_CriFindInDir = vbDirectory
    Priv_CriFindInFile = vbArchive
End Sub
 
Public Property Get BytesNow#()
    BytesNow# = BytesNow_#
End Property
 
Public Property Get FindInPath() As String
    FindInPath = Priv_StrDir$
End Property
 
Public Property Let FindInPath(ByVal vData$)
    Call Stop_
    Call NormalizePath&(vData$)
    Priv_StrDir$ = vData$
End Property
 
 
 
Public Property Get CriterionFindDir() As VbFileAttribute
    CriterionFindDir = Priv_CriFindInDir
End Property
Public Property Let CriterionFindDir(ByVal vData As VbFileAttribute)
    Call Stop_
    Priv_CriFindInDir = vData Or vbDirectory
End Property
 
Public Property Get CriterionFindFile() As VbFileAttribute
    CriterionFindFile = Priv_CriFindInFile
End Property
Public Property Let CriterionFindFile(ByVal vData As VbFileAttribute)
    Call Stop_
    Priv_CriFindInFile = vData Or vbArchive
End Property
 
 
 
Public Property Get CriterionToFind() As Variant
    CriterionToFind = Priv_StrCri$
End Property
 
Public Property Let CriterionToFind(ByRef vData As Variant)
On Error GoTo Err_
Dim L_Index                             As Long
    Call Stop_
    Erase Priv_StrCri$
    LS_Index&(0) = INVALID_HANDLE_VALUE
    LS_Index&(1) = INVALID_HANDLE_VALUE
    If IsArray(vData) Then
        LS_Index&(0) = LBound(vData)
        LS_Index&(1) = UBound(vData)
        ReDim Priv_StrCri$(LS_Index&(0) To LS_Index&(1))
        For L_Index = LS_Index&(0) To LS_Index&(1)
            Priv_StrCri$(L_Index) = CStr(vData(L_Index))
        Next L_Index
    Else
        LS_Index&(0) = 0
        LS_Index&(1) = 0
        ReDim Priv_StrCri$(0)
        Priv_StrCri$(0) = vData
    End If
Exit Property
Err_:
    Err.Clear
End Property
 
Public Property Get IncludeSubFolders() As Boolean: IncludeSubFolders = Priv_IncFolder: End Property
Public Property Let IncludeSubFolders(ByVal vData As Boolean): Priv_IncFolder = vData: End Property
 
Public Property Get ItsRun() As Boolean:    ItsRun = Bool_Run = 1:      End Property
 
Public Sub Stop_():    Bool_Run = 0: Priv_Cancel = True: End Sub
 
Public Function Start_(Optional StrFindInPath As Variant = "", Optional StrCriterionToFind As Variant = Nothing) As Double
 
    Call Stop_
    BytesNow_# = 0
    If Not StrFindInPath = "" Then FindInPath = StrFindInPath
    If Not IsObject(StrCriterionToFind) Then CriterionToFind = StrCriterionToFind
    If Not (LS_Index&(0) = INVALID_HANDLE_VALUE And LS_Index&(0) = INVALID_HANDLE_VALUE) And Priv_StrDir$ <> "" And CStr(Dir(Priv_StrDir$, vbDirectory)) <> "" Then
        RaiseEvent Begin
        Bool_Run = 1
        Priv_Cancel = False
        Call FindFilesAPI#(Priv_StrDir$, Priv_StrCri$())
        Start_# = BytesNow_#
        Bool_Run = 0
        RaiseEvent Finish
    End If
 
End Function
 
Private Sub FindFilesAPI(ByVal StrPath$, ByRef StrSearch$())
Dim str_NameNow$
Dim Str_NameDir$()
Dim Lng_DirCant&
Dim Lng_DirCount&
Dim LF_Index&
'Dim Lng_Res&
Dim Hwnd_Search&
Dim WFD                                 As WIN32_FIND_DATA
 
    Lng_DirCount& = 0
    Hwnd_Search& = FindFirstFile&(StrPath$ & "*", WFD)
 
    If Hwnd_Search& <> INVALID_HANDLE_VALUE Then
        RaiseEvent Folder(StrPath$, WFD.dwFileAttributes)
        Do
            If AllowEvents Then DoEvents
            If Priv_Cancel Then Exit Sub
            With WFD
                str_NameNow$ = Left$(.cFileName, InStr(.cFileName, Chr(0)) - 1)
                If (((.dwFileAttributes Or Priv_CriFindInDir) = .dwFileAttributes) And ((.dwFileAttributes And vbDirectory) = vbDirectory)) Then
                    If (str_NameNow$ <> ".") And (str_NameNow$ <> "..") Then
                        ReDim Preserve Str_NameDir$(Lng_DirCount&)
                        Str_NameDir$(Lng_DirCount&) = str_NameNow$
                        Lng_DirCount& = Lng_DirCount& + 1
                    End If
                End If
            End With
        Loop While FindNextFile&(Hwnd_Search&, WFD)
 
        Call FindClose(Hwnd_Search&)
 
        For LF_Index& = LS_Index&(0) To LS_Index&(1)
            Hwnd_Search& = FindFirstFile&(StrPath$ & StrSearch$(LF_Index&), WFD)
            If Hwnd_Search& <> INVALID_HANDLE_VALUE Then
                Do
                    If AllowEvents Then DoEvents
                    If Priv_Cancel Then Exit Sub
                    With WFD
                        str_NameNow$ = Left$(.cFileName, InStr(.cFileName, Chr(0)) - 1)
                        If (((.dwFileAttributes Or Priv_CriFindInFile) = .dwFileAttributes) And ((.dwFileAttributes And vbArchive) = vbArchive)) Then
 
                            If (str_NameNow$ <> ".") And (str_NameNow$ <> "..") Then
                                BytesNow_# = BytesNow_# + ((.nFileSizeHigh& * MAXDWORD&) + .nFileSizeLow&) + 0
                                RaiseEvent File(str_NameNow$, LF_Index&, .dwFileAttributes)
                            End If
                        End If
                    End With
                Loop While FindNextFile&(Hwnd_Search&, WFD)
                Call FindClose(Hwnd_Search&)
            End If
        Next LF_Index
 
        If Lng_DirCount& > 0 And Priv_IncFolder Then
            For Lng_DirCant& = 0 To Lng_DirCount& - 1
                Call FindFilesAPI#(StrPath$ & Str_NameDir$(Lng_DirCant&) & "\", StrSearch$)
            Next
        End If
 
    End If
 
End Sub
 
'   Returns
'   //  0   =   NoPathValid
'   //  1   =   Ok
'   //  2   =   Fixed/Ok
Public Function NormalizePath&(ByRef sData$)
 
    If Strings.Len(sData$) > 1 Then
        sData$ = Strings.Replace(sData$, "/", "\")
        If Not Strings.Right$(sData$, 1) = "\" Then
            sData$ = sData$ & "\"
            NormalizePath& = 2
        Else
            NormalizePath& = 1
        End If
    Else
        NormalizePath& = 0
    End If
 
End Function
 
 

Modo de declaración...

 
Private WithEvents ClsScanDisk          As Cls_Files
 
' // Proceso X
    If ClsScanDisk Is Nothing Then Set ClsScanDisk = New Cls_Files
    With ClsScanDisk
        If .ItsRun Then Call .Stop_
        .CriterionToFind = Split("*.mp3,*.wma,*.mid,*.midi", ",")
        '   //  ó tambien...
        .CriterionToFind = "*.mp3"
        .FindInPath = "c:\"
        Call .Start_
    End With
' // Fin Proceso X
 
 

Eventos:

 
Event Folder(ByRef PathFolder As String, ByVal Atrributes As VbFileAttribute)
Event File(ByRef NameFile As String, ByRef TypeOfFile As Long, ByVal Atrributes As VbFileAttribute)
Event Begin()
Event Finish()
 
 

 
Option Explicit
 
Private WithEvents ClsScanDisk          As cls_files
Private ThisPath$
Private CountFiles&
 
Private Sub ClsScanDisk_Begin()
    ThisPath$ = ClsScanDisk.FindInPath
    CountFiles& = 0
    Caption = "ScanDisk ha Encontrado: "
End Sub
 
Private Sub ClsScanDisk_File(NameFile As String, TypeOfFile As Long, ByVal Atrributes As Long)
    CountFiles& = CountFiles& + 1
    Caption = "ScanDisk ha Encontrado: " & CountFiles&
    Debug.Print ThisPath$ & NameFile
    Debug.Print vbTab & "Criterio:"; ClsScanDisk.CriterionToFind(TypeOfFile),
    Debug.Print "Atributos:"; Atrributes
End Sub
 
Private Sub ClsScanDisk_Finish()
    Caption = "ScanDisk ha Encontrado: " & CountFiles& & " -> Finalizado."
End Sub
 
Private Sub ClsScanDisk_Folder(PathFolder As String, ByVal Atrributes As Long)
    ThisPath$ = PathFolder
End Sub
 
 
Private Sub Form_Load()
    If ClsScanDisk Is Nothing Then Set ClsScanDisk = New cls_files
    With ClsScanDisk
        If .ItsRun Then .Stop_
        .CriterionToFind = Split("*.mp3,*.wma,*.avi,*.mid,*.mid", ",")
        '.CriterionFindDir = vbReadOnly                  '   //  Solo directorios de Solo lectura.
        '.CriterionFindFile = vbHidden Or vbReadOnly     '  //  Solo archivos ocultos.
        .FindInPath = "c:\"
        .AllowEvents = True
        Call .Start_
    End With
End Sub
 
 

Dulce Infierno Lunar!¡.

.
Alquien sabe como solucionar esto?...

Me da el error 10: La matriz está fija o temporalmente bloqueada

 
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
        (Destination As Any, Source As Any, ByVal Length As Long)
Private Const InvalidValueArray = -1
 
Private Sub Form_Load()
Dim arr()          As Long
    redim arr(0 to 5)
    arr(0) = 12
    arr(1) = 13
    arr(2) = 14
    arr(3) = 15
    arr(4) = 16
    arr(5) = 17
    RemoveInArrayLong 4, arr
End Sub
 
Private Function RemoveInArrayLong(ByVal Index&, ByRef ThisArray() As Long) As Boolean
Dim LenArray        As Long
Dim tArray()        As Long
 
    If Not (Not ThisArray) = InvalidValueArray Then
        LenArray = UBound(ThisArray) - LBound(ThisArray)
        If LenArray - 1 >= 0 Then
            If LenArray = Index& Then
                ReDim Preserve ThisArray(LBound(ThisArray) To (UBound(ThisArray) - 1))
            Else
                ReDim tArray(LenArray - 1)
                If Index > 0 Then
                    Call CopyMemory(ByVal VarPtr(tArray(LBound(tArray))), ByVal VarPtr(ThisArray(LBound(ThisArray))), 4 * Index&)
                End If
                Call CopyMemory(ByVal VarPtr(tArray(Index)), ByVal VarPtr(ThisArray(Index& + 1)), 4 * (LenArray - Index&))
                ReDim ThisArray&(LenArray - 1)
                Call CopyMemory(ByVal VarPtr(ThisArray(LBound(ThisArray))), (tArray(LBound(tArray))), 4 * LenArray)
                Erase tArray
            End If
            RemoveInArrayLong = True
        Else
            Erase ThisArray
            RemoveInArrayLong = False
        End If
    End If
End Function
 
 

Edito

---

.
Ojo tiene que ser via parametro el Array...

Dulces Lunas!¡.

Bueno esta clase la estuve haciendo para realizar un trabajo en mi Institución, (y para saltarme algunas cuestiones), se las dejo por si alguien la desea usar para lo que desees..

Si tiene errores favor de reportarmelos...

Se puede optener el resultado por o la:

 * Normal
 * por el Complemento de la Base... ( Sin Signo )

Falta optimizar algunas cosas... el CODIGO ESTA FUNCIONAL...

(Esto solo fue una chapusada...) Permiti las funciones tales como en la sintasys de las operaciones Aritmeticas...:

• sin()  --> Seno
• kos() --> Coseno
• tan() --> Tangente
• log() --> Logaritmo
• sqr() --> Raiz
• sgn() --> Devuelve un entero que indica el signo de un número

Cls_InfraExp.cls

 
'
'   /////////////////////////////////////////////////////////////
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   // Autor:   Agradesimientos a Raul y Spyke (ExpReg)        //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandesido //
'   // o achicado, si es en base a este codigo es requerido    //
'   // el agradacimiento al autor.                             //
'   /////////////////////////////////////////////////////////////
'   /////////////////////////////////////////////////////////////
'   /////////////////////////////////////////////////////////////
 
Option Explicit
Option Base 0
Option Compare Text
 
Public Enum Bases
    base16 = &H10
    base10 = &HA
    base8 = &H8
    base2 = &H2
End Enum
 
Public Enum ReturnType
    SinSigno = &H0
    ConSigno
End Enum
 
Private Const cError                As String = "<-Error->"
Private Const Str_Artimetica        As String = "\/*-+^()"
Private Const Str_IndexBases        As String = "0123456789abcdef"
Private Const Str_Funciones         As String = "sinkostanlogsqrsgn"
Private Obj_RunExpr                 As Object
Private Obj_ExpRegular              As Object
 
Public Property Get StrError() As String: StrError = cError: End Property
 
Private Function ParseExpresion(ByRef InExpresion As String, ByRef InBaseNow As Bases) As Boolean
Dim lng_Pos(1)          As Long
Dim lng_index           As Long
Dim Str_ToValidate      As String
 
    Str_ToValidate$ = Replace$(InExpresion, " ", "", 1, , vbTextCompare)
    For lng_index& = 1 To Len(Str_Funciones) Step 3
        Str_ToValidate$ = Replace$(Str_ToValidate$, Mid$(Str_Funciones, lng_index&, 3), "", 1, , vbTextCompare)
    Next
    For lng_index& = 1 To Len(Str_Artimetica)
        Str_ToValidate$ = Replace$(Str_ToValidate$, Mid$(Str_Artimetica, lng_index&, 1), "", 1, , vbTextCompare)
    Next
    If Not VerificFormat(Str_ToValidate$, InBaseNow) Then
        InExpresion = cError
        Exit Function
    End If
 
    InExpresion = " " & Replace$(InExpresion, " ", "", 1, , vbTextCompare) & " "
    For lng_index = 1 To Len(Str_Artimetica$)
        InExpresion = Replace$(InExpresion, Mid$(Str_Artimetica$, lng_index, 1), " " & Mid$(Str_Artimetica$, lng_index, 1) & " ", 1, , vbTextCompare)
    Next
    InExpresion = Replace$(InExpresion, "  ", "", 1, , vbTextCompare)
 
    If Not InBaseNow = base10 Then
        For lng_index = 1 To Len(Str_IndexBases)
            lng_Pos&(0) = InStr(lng_Pos&(1) + 1, InExpresion, " " & Mid$(Str_IndexBases$, lng_index, 1), vbTextCompare)
            If lng_Pos&(0) > 0 Then
                lng_Pos&(1) = InStr(lng_Pos&(0) + 1, InExpresion, " ", vbTextCompare)
                If lng_Pos&(1) - lng_Pos&(0) + 1 > 0 Then
                    InExpresion = Mid$(InExpresion, 1, lng_Pos&(0) - 1) & "(ConvSystem(" & Chr(34) & Mid$(InExpresion, lng_Pos&(0) + 1, lng_Pos&(1) - lng_Pos&(0) - 1) & Chr(34) & "," & InBaseNow & ",10)+0)" & Mid$(InExpresion, lng_Pos&(1))
                    lng_index = lng_index - 1
                End If
                lng_Pos&(1) = 0
            End If
        Next
    End If
 
    ParseExpresion = True
 
End Function
 
 
Public Function ConvSystem(ByVal vDataIn$, ByVal inFrom As Bases, ByVal inDest As Bases, Optional ByRef Opciones As ReturnType = ConSigno) As Variant
Dim isNegative          As Boolean
    If Not (inFrom = inDest And inFrom = base10) Then
        '   //  Puedo usar unas cuantas Obviaciones Directas.. aun que mejor usare la conversion larga...
        If inFrom = base10 Then
            ConvSystem = Dec2Base(Val(vDataIn$), inDest, Opciones)
        Else
            isNegative = Val(vDataIn$) < 0
            If Not isNegative Then
                ConvSystem = Dec2Base(Base2Dec(vDataIn$, inFrom), inDest, Opciones)
            Else
                If inFrom = base16 Then
                    ConvSystem = Dec2Base(Base2Dec(vDataIn$, inFrom) * -1, inDest, Opciones)
                Else
                    ConvSystem = Dec2Base(Base2Dec(Val(vDataIn$), inFrom) * -1, inDest, Opciones)
                End If
            End If
        End If
    Else
        ConvSystem = vDataIn$
    End If
End Function
 
Public Function GetAritmeticExpresion(ByVal Expresion As String, ByRef InBase As Bases, Optional ByVal Opciones As ReturnType = ConSigno) As String
    If Obj_RunExpr Is Nothing Then Exit Function
    If ParseExpresion(Expresion, InBase) Then
        Expresion = Replace$(Expresion, "kos", "cos", 1, , vbTextCompare)
        With Obj_RunExpr
            If Not (InBase = base10 And Opciones = SinSigno) Then
                If InBase = base10 Then
                    GetAritmeticExpresion = Dec2Base(.Eval(Expresion$), InBase, Opciones)
                Else
                    GetAritmeticExpresion = Dec2Base(CLng(.Eval(Expresion$)), InBase, Opciones)
                End If
            Else
                If InBase = base10 Then
                    GetAritmeticExpresion = .Eval(Expresion)
                Else
                    GetAritmeticExpresion = CLng(.Eval(Expresion))
                End If
            End If
        End With
    Else
        GetAritmeticExpresion = cError
    End If
End Function
 
Public Function GetMaxBase(ByRef ThisBase As Bases) As String
    Select Case ThisBase
        Case base16:    GetMaxBase = "F"
        Case Else:      GetMaxBase = CStr(ThisBase - 1)
    End Select
End Function
 
Public Function Dec2Base(ByVal inval As Double, ByRef InBase As Bases, Optional ByRef Opciones As ReturnType = ConSigno) As String
Dim isNegative          As Boolean
Dim Lng_LeninVal          As Long
    isNegative = inval < 0
    Dec2Base = inval
    If isNegative Then
        Dec2Base = (inval * -1)
        If Not InBase = base10 Then Dec2Base = pDec2Base(Val(Dec2Base), InBase)
        If Opciones = SinSigno Then
            Lng_LeninVal = Len(Dec2Base)
            Dec2Base = pDec2Base(Base2Dec(String(Lng_LeninVal, GetMaxBase(InBase)), InBase) - (inval * -1) + 1, InBase)
            Dec2Base = String$(10, GetMaxBase(InBase)) & String$(Lng_LeninVal - Len(Dec2Base), "0") & Dec2Base
            If InBase = base8 Then Dec2Base = "1" & Dec2Base
        End If
    Else
        If Not InBase = base10 Then Dec2Base = pDec2Base(inval, InBase)
    End If
End Function
 
Private Function pDec2Base(ByRef inval As Double, ByRef InBase As Bases) As String
Dim lng_Aux#(1)
    lng_Aux#(0) = (inval# \ InBase)
    lng_Aux#(1) = (inval# Mod InBase)
    If inval < InBase Then
        If InBase = base16 Then
            pDec2Base = Hex(lng_Aux#(1))
        Else
            pDec2Base = lng_Aux#(1)
        End If
    Else
        If InBase = base16 Then
            pDec2Base = pDec2Base(lng_Aux#(0), InBase) & Hex(lng_Aux#(1))
        Else
            pDec2Base = pDec2Base(lng_Aux#(0), InBase) & lng_Aux#(1)
        End If
    End If
End Function
 
'   //  Hex no afecta a bases inferiores por ello lo dejo.
Private Function Base2Dec(ByRef inval As String, ByRef InBase As Bases) As Double
Dim lng_lenStr&
Dim lng_Pointer&
Dim lng_Potencia&
    lng_lenStr& = Len(inval)
    lng_Potencia& = 0
    For lng_Pointer& = lng_lenStr& To InStr(1, inval, "-") + 1 Step -1
       Base2Dec = Base2Dec + CLng("&H" & Mid$(inval, lng_Pointer, 1)) * InBase ^ lng_Potencia&
        lng_Potencia& = lng_Potencia& + 1
    Next lng_Pointer&
End Function
 
Public Function VerificFormat(ByVal InStrData As String, InBase As Bases) As Boolean
    If Obj_ExpRegular Is Nothing Then Exit Function
    With Obj_ExpRegular
        Select Case InBase
            Case base16:    .Pattern = "^[0-9a-fA-F]+$"
            Case base10:    .Pattern = "^[0-9]+$"
            Case base8:     .Pattern = "^[0-7]+$"
            Case base2:     .Pattern = "^[0-1]+$"
        End Select
        VerificFormat = .test(InStrData)
    End With
End Function
 
Private Sub Class_Initialize()
    Set Obj_RunExpr = CreateObject("ScriptControl")
    Set Obj_ExpRegular = CreateObject("VBScript.RegExp")
    With Obj_RunExpr
        .Language = "vbscript"
        Call .AddObject("InfraClass", Me, True)
    End With
End Sub
 
Private Sub Class_Terminate()
    Set Obj_RunExpr = Nothing
    Set Obj_ExpRegular = Nothing
End Sub
 
 

Ejemplo en Uso:

 
Private Sub Form_Load()
Dim c As New Cls_InfraExp
Const Operacion As String = "11-1111*(111/111*111)"
    With c
        MsgBox "Operacion Hexadecimal" & vbCrLf & _
               "Operacion Sin Signo --> " & .GetAritmeticExpresion(Operacion, base16, ConSigno) & vbCrLf & _
               "Operacion Con Signo --> " & .GetAritmeticExpresion(Operacion, base16, SinSigno)
        MsgBox "Operacion Decimal" & vbCrLf & _
               "Operacion Sin Signo --> " & .GetAritmeticExpresion(Operacion, base10, ConSigno) & vbCrLf & _
               "Operacion Con Signo --> " & .GetAritmeticExpresion(Operacion, base10, SinSigno)
        MsgBox "Operacion Octal" & vbCrLf & _
               "Operacion Sin Signo --> " & .GetAritmeticExpresion(Operacion, base8, ConSigno) & vbCrLf & _
               "Operacion Con Signo --> " & .GetAritmeticExpresion(Operacion, base8, SinSigno)
        MsgBox "Operacion Binaria" & vbCrLf & _
               "Operacion Sin Signo --> " & .GetAritmeticExpresion(Operacion, base2, ConSigno) & vbCrLf & _
               "Operacion Con Signo --> " & .GetAritmeticExpresion(Operacion, base2, SinSigno)
    End With
End Sub
 
 

Dulce Infierno Lunar!¡.

Es un Modulod e Clase que sirve para leer el Tag de los archivos de Musica, y extraer toda la informacion posible del mismo...

Saca los bytes del Cover del M4A incluyendo su formato... JPEG / PNG.
Saca el texto "liryc" del M4A (Si existe...)

y toda la informacion posible y de forma existencial!¡.

 * Esta la es la primera version, asi que si tiene errores favor de comunicarlos en este mismo hilo.
 * Deshacer este formato para obtener la información me a costa asi que disfrutenlo!¡.

NOTA: No saca informacion comprimida... para ello usar la Zlib...


Aqui hay varios archivos M4A... xP  --->  http://infrangelux.sytes.net/FileX/index.php?dir=/Musica/Slipknot

FormatM4A.cls

 
 
'
'   /////////////////////////////////////////////////////////////
'   // Autor:   BlackZeroX ( Ortega Avila Miguel Angel )       //
'   //                                                         //
'   // Web:     http://InfrAngeluX.Sytes.Net/                  //
'   //                                                         //
'   //    |-> Pueden Distribuir Este Codigo siempre y cuando   //
'   // no se eliminen los creditos originales de este codigo   //
'   // No importando que sea modificado/editado o engrandesido //
'   // o achicado, si es en base a este codigo es requerido    //
'   // el agradacimiento al autor.                             //
'   /////////////////////////////////////////////////////////////
'   //////////////////////Lector Formato M4A/////////////////////
'   /////////////////////////////////////////////////////////////
'   //  1ra Version...                                         //
'   //      --> Verificación de Formato.                       //
'   //      --> Solo Lectura de Datos (Tag).                   //
'   /////////////////////////////////////////////////////////////
 
Option Explicit
Option Base 0
Option Compare Text
 
Private Str_Album                       As String
Private Str_Artist                      As String
Private Str_AlbumArtist                 As String
Private Str_Comment                     As String
Private Str_Year                        As String
Private Str_Title                       As String
Private Str_Genre                       As String
Private Str_TrackNumber                 As String
Private Str_DiskNumber                  As String
Private Str_Composer                    As String
Private Str_Encoder                     As String
Private Str_BPM                         As String
Private Str_Copyright                   As String
Private Str_Compilation                 As String
Private Arr_Artwork()                   As Byte
Private Str_ArtworkFormat               As String
Private Str_RatingAdvisory              As String
Private Str_Grouping                    As String
Private Str_qq_stik                     As String
Private Str_Podcast                     As String
Private Str_Category                    As String
Private Str_Keyword                     As String
Private Str_PodcastURL                  As String
Private Str_EpisodeGlobalUniqueID       As String
Private Str_Description                 As String
Private Str_Lyrics                      As String
Private Str_TVNetworkName               As String
Private Str_TVShowName                  As String
Private Str_TVEpisodeNumber             As String
Private Str_TVSeason                    As String
Private Str_TVEpisode                   As String
Private Str_PurchaseDate                As String
Private Str_GaplessPlayback             As String
 
Private Const lng_lAtom                 As Long = &H4
Private Const Str_Format                As String = "ftyp"
Private Const cContData                 As String = "udta"
Private Const cMetaData                 As String = "meta"
Private Const ChdlrData                 As String = "hdlr"
 
Private Const cAlbum                    As String = "©alb"
Private Const cArtist                   As String = "©art"
Private Const cAlbumArtist              As String = "aART"
Private Const cComment                  As String = "©cmt"
Private Const cYear                     As String = "©day"
Private Const cTitle                    As String = "©nam"
Private Const cGenre                    As String = "©gen|gnre"
Private Const cTrackNumber              As String = "trkn"
Private Const cDiskNumber               As String = "disk"
Private Const cComposer                 As String = "©wrt"
Private Const cEncoder                  As String = "©too"
Private Const cBPM                      As String = "tmpo"
Private Const cCopyright                As String = "cprt"
Private Const cCompilation              As String = "cpil"
Private Const cArtwork                  As String = "covr"
Private Const cRatingAdvisory           As String = "rtng"
Private Const cGrouping                 As String = "©grp"
Private Const cqq_stik                  As String = "stik"
Private Const cPodcast                  As String = "pcst"
Private Const cCategory                 As String = "catg"
Private Const cKeyword                  As String = "keyw"
Private Const cPodcastURL               As String = "purl"
Private Const cEpisodeGlobalUniqueID    As String = "egid"
Private Const cDescription              As String = "desc"
Private Const cStr_Lyrics               As String = "©lyr"
Private Const cTVNetworkName            As String = "tvnn"
Private Const cTVShowName               As String = "tvsh"
Private Const cTVEpisodeNumber          As String = "tven"
Private Const cTVSeason                 As String = "tvsn"
Private Const cTVEpisode                As String = "tves"
Private Const cPurchaseDate             As String = "purd"
Private Const cGaplessPlayback          As String = "pgap"
 
Private Str_File                        As String
Private Priv_ItsOkFormat                As Boolean
 
Private Function StringToLong(ByVal Str_Data As String) As Long
Dim TMP$, i&
Dim Byte_Str()      As Byte
    TMP$ = String$(Len(Str_Data) * 2 + 2, "0")
    Mid$(TMP$, 1, 2) = "&H"
    Byte_Str = StrConv(Str_Data$, vbFromUnicode)
    For i = LBound(Byte_Str) To UBound(Byte_Str)
        If Byte_Str(i) > 15 Then
            Mid$(TMP$, 3 + i * 2, 2) = Hex(Byte_Str(i))
        Else
            Mid$(TMP$, 3 + i * 2, 2) = "0" & Hex(Byte_Str(i))
        End If
    Next i
    StringToLong& = CLng(TMP$)
End Function
 
Private Function GetStrFromNumFile(ByVal IDFile As Integer, ByVal LngPos As Long, ByRef StrOut As String) As Long
    Get IDFile%, LngPos, StrOut$
    GetStrFromNumFile = LngPos + Len(StrOut$)
End Function
 
Public Property Let This_File(ByVal StrFilePath As String)
Dim Str_PointerStr      As String * lng_lAtom
Dim Str_CatNow          As String * lng_lAtom
Dim Str_DataPos         As String * lng_lAtom
Dim Str_CatData         As String
Dim lng_Pos             As Long
Dim int_FF              As Integer
 
 
    Str_Album$ = ""
    Str_Artist$ = ""
    Str_AlbumArtist$ = ""
    Str_Comment$ = ""
    Str_Year$ = ""
    Str_Title$ = ""
    Str_Genre$ = ""
    Str_TrackNumber$ = ""
    Str_DiskNumber$ = ""
    Str_Composer$ = ""
    Str_Encoder$ = ""
    Str_BPM$ = ""
    Str_Copyright$ = ""
    Str_Compilation$ = ""
    Erase Arr_Artwork
    Str_RatingAdvisory$ = ""
    Str_Grouping$ = ""
    Str_qq_stik$ = ""
    Str_Podcast$ = ""
    Str_Category$ = ""
    Str_Keyword$ = ""
    Str_PodcastURL$ = ""
    Str_EpisodeGlobalUniqueID$ = ""
    Str_Description$ = ""
    Str_Lyrics$ = ""
    Str_TVNetworkName$ = ""
    Str_TVShowName$ = ""
    Str_TVEpisodeNumber$ = ""
    Str_TVSeason$ = ""
    Str_TVEpisode$ = ""
    Str_PurchaseDate$ = ""
    Str_GaplessPlayback$ = ""
 
 
    Str_CatData$ = Space$(lng_lAtom&)
    Priv_ItsOkFormat = False
    Str_File$ = StrFilePath$
    int_FF% = FreeFile%
 
    Open Str_File$ For Binary As int_FF%
 
    If LOF(int_FF%) > 8 Then
 
        Get int_FF%, 5, Str_CatNow$
 
        If StrComp(Str_CatNow$, Str_Format$, vbBinaryCompare) = 0 Then
            'lng_Pos& = 148 '   //  Se puede Obviar, pero mejor comprovamos el formato...
            lng_Pos& = GetStrFromNumFile&(int_FF%, lng_Pos& + 1, Str_DataPos$) - (lng_lAtom& - 1)
            lng_Pos& = GetStrFromNumFile&(int_FF%, StringToLong&(Str_DataPos$) + ((lng_lAtom& * 2) + 1), Str_DataPos$) + StringToLong&(Str_DataPos$) - lng_lAtom& - 1
            lng_Pos& = GetStrFromNumFile&(int_FF%, lng_Pos& + 1, Str_DataPos$) + StringToLong&(Str_DataPos$)
            lng_Pos& = GetStrFromNumFile&(int_FF%, lng_Pos&, Str_CatNow$)
 
            If StrComp(Str_CatNow$, cContData$, vbTextCompare) = 0 Then
                lng_Pos& = GetStrFromNumFile&(int_FF%, lng_Pos& + lng_lAtom&, Str_DataPos$)
                If StrComp(Str_DataPos$, cMetaData$, vbTextCompare) = 0 Then
                    lng_Pos& = GetStrFromNumFile&(int_FF%, lng_Pos& + lng_lAtom&, Str_CatData$)
                    lng_Pos& = lng_Pos& + StringToLong&(Str_CatData$) + lng_lAtom&
                    Do
                        lng_Pos& = GetStrFromNumFile&(int_FF%, lng_Pos& + lng_lAtom&, Str_CatNow$)
                        If StrComp(Str_CatNow$, "free", vbTextCompare) = 0 Or StrComp(Str_CatNow$, "name", vbTextCompare) = 0 Then Exit Do
                        Call GetStrFromNumFile&(int_FF%, lng_Pos& + lng_lAtom&, Str_DataPos$)
                        If StrComp(Str_DataPos$, "data", vbTextCompare) = 0 Then '   //  Atom Legible? (Sin Compresion o espesificaciones del Formato...)
                            lng_Pos& = GetStrFromNumFile&(int_FF%, lng_Pos&, Str_PointerStr$)
                            Str_CatData$ = Space$(StringToLong&(Str_PointerStr$) - (lng_lAtom& * 4))
                            If StrComp(Str_CatNow$, cArtwork$, vbTextCompare) = 0 Then
                                GetStrFromNumFile& int_FF%, lng_Pos& + lng_lAtom&, Str_PointerStr$
                                Select Case StringToLong&(Str_PointerStr$)
                                    Case 13
                                        Str_ArtworkFormat$ = "jpeg"
                                    Case 14
                                        Str_ArtworkFormat$ = "png"
                                End Select
                            End If
                            lng_Pos& = GetStrFromNumFile&(int_FF%, lng_Pos& + (lng_lAtom * 3), Str_CatData)
                            If Not StrComp(Str_CatNow$, "", vbTextCompare) = 0 Then
                                Select Case Str_CatNow$
                                    Case cAlbum$
                                        Str_Album$ = Str_CatData$
                                    Case cArtist$
                                        Str_Artist$ = Str_CatData$
                                    Case cAlbumArtist$
                                        Str_AlbumArtist$ = Str_CatData$
                                    Case cComment$
                                        Str_Comment$ = Str_CatData$
                                    Case cYear$
                                        Str_Year$ = Str_CatData$
                                    Case cTitle$
                                        Str_Title$ = Str_CatData$
                                    Case Split(cGenre$, "|")(0), Split(cGenre$, "|")(1)                 '  //  "©gen|gnre"
                                        Str_Genre$ = Str_CatData$
                                    Case cTrackNumber$
                                        Str_TrackNumber$ = Str_CatData$
                                    Case cDiskNumber$
                                        Str_DiskNumber$ = Str_CatData$
                                    Case cComposer$
                                        Str_Composer$ = Str_CatData$
                                    Case cEncoder$
                                        Str_Encoder$ = Str_CatData$
                                    Case cBPM$
                                        Str_BPM$ = Str_CatData$
                                    Case cCopyright$
                                        Str_Copyright$ = Str_CatData$
                                    Case cCompilation$
                                        Str_Compilation$ = Str_CatData$
                                    Case cArtwork$
                                        Arr_Artwork = StrConv(Str_CatData$, vbFromUnicode)
                                    Case cRatingAdvisory$
                                        Str_RatingAdvisory$ = Str_CatData$
                                    Case cGrouping$
                                        Str_Grouping$ = Str_CatData$
                                    Case cqq_stik$
                                        Str_qq_stik$ = Str_CatData$
                                    Case cPodcast$
                                        Str_Podcast$ = Str_CatData$
                                    Case cCategory$
                                        Str_Category$ = Str_CatData$
                                    Case cKeyword$
                                        Str_Keyword$ = Str_CatData$
                                    Case cPodcastURL$
                                        Str_PodcastURL$ = Str_CatData$
                                    Case cEpisodeGlobalUniqueID$
                                        Str_EpisodeGlobalUniqueID$ = Str_CatData$
                                    Case cDescription$
                                        Str_Description$ = Str_CatData$
                                    Case cStr_Lyrics$
                                        Str_Lyrics$ = Str_CatData$
                                    Case cTVNetworkName$
                                        Str_TVNetworkName$ = Str_CatData$
                                    Case cTVShowName$
                                        Str_TVShowName$ = Str_CatData$
                                    Case cTVEpisodeNumber$
                                        Str_TVEpisodeNumber$ = Str_CatData$
                                    Case cTVSeason$
                                        Str_TVSeason$ = Str_CatData$
                                    Case cTVEpisode$
                                        Str_TVEpisode$ = Str_CatData$
                                    Case cPurchaseDate$
                                        Str_PurchaseDate$ = Str_CatData$
                                    Case cGaplessPlayback$
                                        Str_GaplessPlayback$ = Str_CatData$
                                End Select
                            End If
                        ElseIf Str_CatNow$ = "----" Then
                            lng_Pos& = GetStrFromNumFile&(int_FF%, lng_Pos& - 8, Str_DataPos$)
                            lng_Pos& = lng_Pos& + StringToLong&(Str_DataPos$) - lng_lAtom&
                        End If
                    Loop
                    Priv_ItsOkFormat = True
                End If
            End If
        End If
    End If
    Close int_FF%
End Property
 
Public Property Get ItsOkFormat() As Boolean
    ItsOkFormat = Priv_ItsOkFormat
End Property
 
Public Property Get This_File() As String
    This_File = Str_File$
End Property
 
Public Property Get Album() As String
    Album = Str_Album
End Property
Public Property Get Artist() As String
    Artist = Str_Artist
End Property
Public Property Get AlbumArtist() As String
    AlbumArtist = Str_AlbumArtist
End Property
Public Property Get Comment() As String
    Comment = Str_Comment
End Property
Public Property Get Year() As String
    Year = Str_Year
End Property
Public Property Get Title() As String
    Title = Str_Title
End Property
Public Property Get Genre() As String
    Genre = Str_Genre
End Property
Public Property Get TrackNumber() As String
    TrackNumber = Str_TrackNumber
End Property
Public Property Get DiskNumber() As String
    DiskNumber = Str_DiskNumber
End Property
Public Property Get Composer() As String
    Composer = Str_Composer
End Property
Public Property Get Encoder() As String
    Encoder = Str_Encoder
End Property
Public Property Get BPM() As String
    BPM = Str_BPM
End Property
Public Property Get Copyright() As String
    Copyright = Str_Copyright
End Property
Public Property Get Compilation() As String
    Compilation = Str_Compilation
End Property
Public Property Get Artwork() As Byte()
    Artwork = Arr_Artwork
End Property
Public Property Get ArtworkFormat() As String
    ArtworkFormat = Str_ArtworkFormat
End Property
Public Property Get RatingAdvisory() As String
    RatingAdvisory = Str_RatingAdvisory
End Property
Public Property Get Grouping() As String
    Grouping = Str_Grouping
End Property
Public Property Get qq_stik() As String
    qq_stik = Str_qq_stik
End Property
Public Property Get Podcast() As String
    Podcast = Str_Podcast
End Property
Public Property Get Category() As String
    Category = Str_Category
End Property
Public Property Get Keyword() As String
    Keyword = Str_Keyword
End Property
Public Property Get PodcastURL() As String
    PodcastURL = Str_PodcastURL
End Property
Public Property Get EpisodeGlobalUniqueID() As String
    EpisodeGlobalUniqueID = Str_EpisodeGlobalUniqueID
End Property
Public Property Get Description() As String
    Description = Str_Description
End Property
Public Property Get Lyrics() As String
    Lyrics = Str_Lyrics
End Property
Public Property Get TVNetworkName() As String
    TVNetworkName = Str_TVNetworkName
End Property
Public Property Get TVShowName() As String
    TVShowName = Str_TVShowName
End Property
Public Property Get TVEpisodeNumber() As String
    TVEpisodeNumber = Str_TVEpisodeNumber
End Property
Public Property Get TVSeason() As String
    TVSeason = Str_TVSeason
End Property
Public Property Get TVEpisode() As String
    TVEpisode = Str_TVEpisode
End Property
Public Property Get PurchaseDate() As String
    PurchaseDate = Str_PurchaseDate
End Property
Public Property Get GaplessPlayback() As String
    GaplessPlayback = Str_GaplessPlayback
End Property
 
 
'Public Property Let Album(ByVal vData As String)
'Public Property Let Artist(ByVal vData As String)
'Public Property Let AlbumArtist(ByVal vData As String)
'Public Property Let Comment(ByVal vData As String)
'Public Property Let Year(ByVal vData As String)
'Public Property Let Title(ByVal vData As String)
'Public Property Let Genre(ByVal vData As Integer)
'Public Property Let TrackNumber(ByVal vData As Integer)
'Public Property Let DiskNumber(ByVal vData As Integer)
'Public Property Let Composer(ByVal vData As String)
'Public Property Let Encoder(ByVal vData As String)
'Public Property Let BPM(ByVal vData As Integer)
'Public Property Let Copyright(ByVal vData As String)
'Public Property Let Compilation(ByVal vData As Integer)
'Public Property Let Artwork(ByRef vData() As Byte)
'   //  Public Property Let ArtworkFormat(ByRef vData As String)
'Public Property Let RatingAdvisory(ByVal vData As Integer)
'Public Property Let Grouping(ByVal vData As String)
'Public Property Let qq_stik(ByVal vData As Integer)
'Public Property Let Podcast(ByVal vData As Integer)
'Public Property Let Category(ByVal vData As String)
'Public Property Let Keyword(ByVal vData As String)
'Public Property Let PodcastURL(ByVal vData As Integer)
'Public Property Let EpisodeGlobalUniqueID(ByVal vData As Integer)
'Public Property Let Description(ByVal vData As String)
'Public Property Let Lyrics(ByVal vData As String)
'Public Property Let TVNetworkName(ByVal vData As String)
'Public Property Let TVShowName(ByVal vData As String)
'Public Property Let TVEpisodeNumber(ByVal vData As String)
'Public Property Let TVSeason(ByVal vData As Integer)
'Public Property Let TVEpisode(ByVal vData As Integer)
'Public Property Let PurchaseDate(ByVal vData As String)
'Public Property Let GaplessPlayback(ByVal vData As Integer)
 
 

Ejemplo de uso:

 
 
Option Explicit
Option Base 0
 
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long
 
Sub main()
Dim clsFM4A         As Cls_FormatM4A
Dim StrDir          As String
Dim int_FF          As Integer
 
    Set clsFM4A = New Cls_FormatM4A
    With clsFM4A
 
        .This_File = App.Path & "\SCGJ.m4a"
 
        If .ItsOkFormat Then
 
            StrDir$ = Replace$("c:\Musica\" & .Artist & "\" & .Year & "-" & .Album & "\", "\\", "\")
            Call MakeSureDirectoryPathExists(StrDir$)
 
            '   //  extraemos la Imagen Cover
            int_FF% = FileSystem.FreeFile%
            Open StrDir & .Artist & " - " & .Title & "." & .ArtworkFormat For Binary As int_FF%
                Put int_FF%, , .Artwork
            Close int_FF%
 
            '   //  Extraemos la lirica del archivo
            int_FF% = FileSystem.FreeFile%
            Open StrDir & .Artist & " - " & .Title & ".txt" For Binary As int_FF%
                Put int_FF%, , .Lyrics
            Close int_FF%
 
        End If
    End With
    Set clsFM4A = Nothing
 
End Sub
 
 

Dulce Infierno Lunar!¡.

.
Lo vi por Aquí(Enlace) y me parecio buena idea publicarlo aquí y ver que otras maneras hay de hacer esto...

Generar un cuadrado numerico que se le ingrese un numero por ejemplo

 * La funcion final debera devolver un Array tipo Long.
 * Despues se leera dicho array y se creara un String que devuelva el contenido (En el Formato Propuesto).

Se ingresa 10 y se construye el siguiente cuadrado numerico


Se ingrese 20 y da como resultado



Edito:

Estos Son mis Dos Codigos (Con una Sola Matriz Unidimensional xD):

 * Sin Calculo de Espacio...
Mod_Main Generate Rentangle.bas

 * Implementando Espacio Implementado...
Mod_Main Generate Rentangle V2.bas

Dulces Lunas!¡.

.
Buenas alguien me podria decir que Constante hay que pasarle a CreateWindowsEx o con SetWindowLong al Handle de una Ventana X.

Dulces Lunas!¡.

Esto me allegado hoy a mi correo!¡.

y pues como lo ando sirculando ya sabran mi opinion al respecto!¡.

No deseo armar polemica, solo es para compartir!¡.





SÍ ESTÁS DE ACUERDO, CIRCÚLALA


Este 15 de Sep. No va a haber grito, va a haber silencio, por
México.
 
Hagamos algo con verdadero valor para México, algo que de verdad demuestre que estamos unidos, y en desacuerdo con la manera de combatir la inseguridad.
 
Este 15 y 16 de septiembre démosle la espalda a nuestros gobernantes.
 
Dejemos que ellos solo celebren las fiestas patrias, ellos sí tienen que festejar.
 
Que por primera vez en la historia de este país, el grito de
independencia y libertad sea un gran silencio de inconformidad y disgusto.
 
Que sientan los principales líderes y mandatarios de este país que nosotros también podemos darles la espalda.
 
Esto es lo que mueve, esto es lo que hace reaccionar, esto es saber que es tener a un país secuestrado, vivimos a la zozobra, entre rejas en nuestros hogares y comercios, con blindajes de todo tipo.
 
No estamos en tiempos de decir VIVA MÉXICO, ni de festejar nada, ni de ir aplaudirle al Ejercito, ni a al Mandatario, Gobernante en turno, que no han podido controlar ni darnos bienestar. Ni mucho menos seguridad que es lo mínimo que deben hacer, para eso se funda el estado.
   
Así que propongo que este 15 de Septiembre no haya grito sino un gran silencio de enojo y reclamo.
 
Dejemos solos a los gobernadores, al (los) mandatario (s) en sus respectivas plazas, que le den su grito al aire y a su familia y equipo de trabajo, que se lo crean ellos, no nos han servido absolutamente para nada, si se fijan sólo han aprobado las reformas que a ellos convienen ya sea para recibir más apoyos y/o votos.
 
Únete de verdad a este movimiento histórico por el bien de tu familia, de tu comunidad, de tu estado, de tu vida y del país en que vivimos todos.
   
Este 15 de Sep. No va a haber grito, va a haber silencio, por
México.
Demos el grito y festejemos (si hay algo que festejar) en nuestras casas con amigos y familiares y al desfile ni pararnos por ahí, los reconocimientos que hemos recibido últimamente son un par de medallas olímpicas y el primer lugar en secuestros ¡que lo festejen ellos!
 
LAS DIZQUE AUTORIDADES DEBERÍAN DE TENER MIEDO AL PUEBLO,NO EL PUEBLO A UNA BOLA DE RATAS, CORRUPTOS QUE SOLO VELAN POR SUS INTERESES 'HAY QUE APOYAR, ES MOMENTO DE HACER ALGO'.
 
¡VIVA MÉXICO!, sólo que sin las farsas de los gobernantes y su grito de independencia en las diferentes plazas cívicas de todo el país.




Dulce Infierno Lunar!¡.

.
Por hay me encontre esto...

Descargar Source

Nota: Esta en Delphi

Dulces Lunas!¡.

.
Bueno me acabe de reinstalar este juego pues la verdad quisiera jugar, alguien se anima?

OJO:-> La version 1.0!¡.

VPN por ---> Hamachi

Dulces Lunas!¡.