Below you'll find the source for the Visual Basic 6 function asf_get_tag.
Attribute VB_Name = "modAsfGetTag"
' These functions are downloaded from:
' http://www.stefanthoolen.nl/archive/vb6-functions/
'
' You may freely distribute this file but please leave all comments, including this one, in it.
'
' @Author Stefan Thoolen <mail@stefanthoolen.nl>
Option Explicit
' For internal use, a structure to read the ASF_File_Properties_Object
Private Type ASF_File_Properties
fileid_guid As String * 16
filesize1 As Long ' QuadWORD
filesize2 As Long ' ^^^^^^^^
creation_date1 As Long ' QuadWORD
creation_date2 As Long ' ^^^^^^^^
data_packets1 As Long ' QuadWORD
data_packets2 As Long ' ^^^^^^^^
play_duration1 As Long ' QuadWORD
play_duration2 As Long ' ^^^^^^^^
send_duration1 As Long ' QuadWORD
send_duration2 As Long ' ^^^^^^^^
preroll1 As Long ' QuadWORD
preroll2 As Long ' ^^^^^^^^
flags_raw As Long ' DoubleWORD
min_packet_size As Long ' DoubleWORD
max_packet_size As Long ' DoubleWORD
max_bitrate As Long ' DoubleWORD
End Type
' Public type, will contain all fetched information
Public Type asf_tag
FP_Playtime As Long
FP_Filesize As Long
FP_Bitrate As Long
CD_Found As Boolean
CD_Title As String
CD_Author As String
CD_Copyright As String
CD_Description As String
CD_Rating As String
ECD_Found As Boolean
ECD_Genre As String
ECD_AlbumTitle As String
ECD_Track As Integer
ECD_TrackNumber As Integer
ECD_Year As String
ECD_Composer As String
End Type
' For internal use, a structure to read ContentDescription sizes
Private Type ASF_CD_Lengths
title_len As Integer
author_len As Integer
copyright_len As Integer
description_len As Integer
rating_len As Integer
End Type
''
' Combines two Long values to one variant (for QuadWORDs)
' @param long long1 The first value
' @param long long2 The second value
' @return Variant Both values combined
' @author Steven Don <www.shdon.com>
Public Function two_longs_to_variant(long1 As Long, long2 As Long) As Double
Dim ret As Double
Dim bit31 As Double, bit63 As Double
bit31 = &H8000
bit31 = bit31 * &H10000
bit63 = bit31 * bit31
bit63 = bit63 * 2
'Move long2 into upper 32 bits, excluding sign bit
ret = (long2 And &H7FFFFFFF)
ret = ret * &H10000
ret = ret * &H10000
'Move long1 into lower 31 bits
ret = ret + (long1 And &H7FFFFFFF)
'Take care of sign bits
If (long1 < 0) Then ret = ret + bit31
If (long2 < 0) Then ret = ret + bit63
two_longs_to_variant = ret
End Function
''
' Completes a string by adding zero characters to the front
' @param string value The input string
' @param integer length The length the return value must be
' @param string character Optional, the character that should be used for filling, default: "0"
' @author Stefan Thoolen <mail@stefanthoolen.nl>
Public Function zerofill(ByVal value As String, ByVal length As Integer, Optional ByVal character = "0") As String
If Len(value) >= length Then zerofill = value: Exit Function
Dim i As Integer
Do
value = character & value
Loop While Len(value) < length
zerofill = value
End Function
''
' Makes a binary string from an integer number
' Same syntax as the PHP function 'decbin'
' See also: http://www.php.net/manual/en/function.decbin.php
' @param Integer number The decimal value
' @return String A binary presentation of the number (ex.: 00100111)
' @author Stefan Thoolen <mail@stefanthoolen.nl>
Public Function decbin(ByVal number As Integer) As String
Dim retval As String
Do Until number = 0
If (number Mod 2) Then retval = "1" & retval Else retval = "0" & retval
number = number \ 2
Loop
decbin = retval
End Function
''
' Makes an integer number from a binary string
' Same syntax as the PHP function 'bindec'
' See also: http://www.php.net/manual/en/function.bindec.php
' @param String binary_string The binary string (ex.: 00100111)
' @return Integer A decimal presentation of the binary value
' @author Stefan Thoolen <mail@stefanthoolen.nl>
Public Function bindec(binary_string As String) As Long
Dim i As Integer, pos As Integer, ret As Long
For i = 1 To Len(binary_string)
pos = Len(binary_string) - i
If Mid(binary_string, pos + 1, 1) = "1" Then ret = ret + (2 ^ (i - 1))
Next i
bindec = ret
End Function
''
' When reading a binary file in another endian, this function can convert multiple bytes to a valid number
' @param string inp The bytes as string
' @return variant The actual number
' @author Stefan Thoolen <mail@stefanthoolen.nl>
Public Function change_endian(ByVal inp As String, Optional ByVal reverse As Boolean = False) As Variant
If Len(inp) = 0 Then change_endian = 0: Exit Function
Dim i As Integer, s As String
If reverse Then
For i = 1 To Len(inp)
s = s & zerofill(decbin(Asc(Mid(inp, i, 1))), 8)
Next i
Else
For i = Len(inp) To 1 Step -1
s = s & zerofill(decbin(Asc(Mid(inp, i, 1))), 8)
Next i
End If
change_endian = bindec(s)
End Function
''
' Converts a heximal string to a decimal integer
' Same syntax as the PHP function 'hexdec'
' See also: http://www.php.net/manual/en/function.hexdec.php
' @param String hex_string The heximal string
' @return Integer An integer value
' @author Stefan Thoolen <mail@stefanthoolen.nl>
Public Function hexdec(hex_string As String) As Integer
hexdec = Val("&h" & hex_string)
End Function
''
' Converts a String to a binary GUID
' @param string GUID The GUID, for example "{01234567-89AB-CDEF-0123-456789ABCDEF}"
' @return string A binary string, always 16 bytes
' @author Stefan Thoolen <mail@stefanthoolen.nl>
Public Function GUIDFromString(ByVal GUID As String) As String
' The return value will be built in here
Dim ret As String
' Multiple used variables
Dim s As String, i As Integer
' Removes some formatting characters
GUID = Replace(GUID, "-", "")
If Left(GUID, 1) = "{" And Right(GUID, 1) = "}" Then GUID = Mid(GUID, 2, Len(GUID) - 2)
' The first part
s = Left(GUID, 8)
For i = 7 To 1 Step -2
ret = ret & Chr(hexdec(Mid(s, i, 2)))
Next i
' The second part
s = Mid(GUID, 9, 4)
For i = 3 To 1 Step -2
ret = ret & Chr(hexdec(Mid(s, i, 2)))
Next i
' The third part
s = Mid(GUID, 13, 4)
For i = 3 To 1 Step -2
ret = ret & Chr(hexdec(Mid(s, i, 2)))
Next i
' The forth part
s = Right(GUID, 16)
For i = 1 To 15 Step 2
ret = ret & Chr(hexdec(Mid(s, i, 2)))
Next i
GUIDFromString = ret
End Function
''
' Reads an ASF (WMA) tag
' @param String FileName The filename of which we need the tags
' @return asf_tag The tag elements
' @author Stefan Thoolen <mail@stefanthoolen.nl>
Public Function asf_get_tag(filename As String) As asf_tag
' Variables with multiple uses
Dim s As String, gs As String * 16, i As Integer
' The return value
Dim ret As asf_tag
' AFS works with different GUIDs. I wrote them down like this:
Dim ASF_Header_Object As String * 16
Dim ASF_Content_Description_Object As String * 16
Dim ASF_Extended_Content_Description_Object As String * 16
Dim ASF_File_Properties_Object As String * 16
ASF_Header_Object = GUIDFromString("75B22630-668E-11CF-A6D9-00AA0062CE6C")
ASF_Content_Description_Object = GUIDFromString("75B22633-668E-11CF-A6D9-00AA0062CE6C")
ASF_Extended_Content_Description_Object = GUIDFromString("D2D0A440-E307-11D2-97F0-00A0C95EA850")
ASF_File_Properties_Object = GUIDFromString("8CABDCA1-A947-11CF-8EE4-00C00C205365")
Dim ff As Integer
ff = FreeFile
Open filename For Binary Access Read As #ff
Get #ff, 1, gs
If gs = ASF_Header_Object Then
Dim header_len As Long, header_objects As Long, object_len As Long
s = String(8, 0): Get #ff, , s: header_len = change_endian(s) ' Length of the header
s = String(4, 0): Get #ff, , s: header_objects = change_endian(s) ' Amount of objects
s = String(2, 0): Get #ff, , s ' Reserved1 & Reserved 2
' Loops through all header objects
Dim ho_i As Integer
For ho_i = 1 To header_objects
' Fetching next GUID
Get #ff, , gs
' Length of the object
s = String(8, 0): Get #ff, , s: object_len = change_endian(s)
If gs = ASF_Content_Description_Object Then
Dim cd_len As ASF_CD_Lengths
ret.CD_Found = True
Get #ff, , cd_len
s = String(cd_len.title_len, 0): Get #ff, , s: ret.CD_Title = Replace(s, Chr(0), "")
s = String(cd_len.author_len, 0): Get #ff, , s: ret.CD_Author = Replace(s, Chr(0), "")
s = String(cd_len.copyright_len, 0): Get #ff, , s: ret.CD_Copyright = Replace(s, Chr(0), "")
s = String(cd_len.description_len, 0): Get #ff, , s: ret.CD_Description = Replace(s, Chr(0), "")
s = String(cd_len.rating_len, 0): Get #ff, , s: ret.CD_Rating = Replace(s, Chr(0), "")
ElseIf gs = ASF_Extended_Content_Description_Object Then
Dim ecd_item_count As Integer
ret.ECD_Found = True
Get #ff, , ecd_item_count
For i = 1 To ecd_item_count
Dim ecd_namelen As Integer, ecd_name As String
Get #ff, , ecd_namelen
ecd_name = String(ecd_namelen, 0): Get #ff, , ecd_name
Dim ecd_valtype As Integer, ecd_vallen As Integer, ecd_value As String
Get #ff, , ecd_valtype
Get #ff, , ecd_vallen
ecd_value = String(ecd_vallen, 0): Get #ff, , ecd_value
ecd_name = Replace(ecd_name, Chr(0), "")
If ecd_valtype = 0 Or ecd_valtype = 1 Then
ecd_value = Replace(ecd_value, Chr(0), "")
Select Case LCase(ecd_name)
Case "wm/genre": ret.ECD_Genre = ecd_value
Case "wm/albumtitle": ret.ECD_AlbumTitle = ecd_value
Case "wm/year": ret.ECD_Year = ecd_value
Case "wm/composer": ret.ECD_Composer = ecd_value
Case Else: Rem MsgBox ecd_name & ": " & ecd_value
End Select
ElseIf ecd_valtype = 3 Then
Select Case LCase(ecd_name)
Case "wm/track": ret.ECD_Track = Asc(ecd_value)
Case "wm/tracknumber": ret.ECD_TrackNumber = Asc(ecd_value)
Case Else: Rem MsgBox ecd_name & ": " & Asc(ecd_value)
End Select
Else
Rem MsgBox ecd_valtype & ":" & ecd_name & ": " & Replace(ecd_value, Chr(0), "")
End If
Next i
ElseIf gs = ASF_File_Properties_Object Then
Dim fp As ASF_File_Properties, pt As Long
Get #ff, , fp
pt = (two_longs_to_variant(fp.play_duration1, fp.play_duration2) / 10000000) - (two_longs_to_variant(fp.preroll1, fp.preroll2) / 1000)
ret.FP_Playtime = pt
ret.FP_Filesize = two_longs_to_variant(fp.filesize1, fp.filesize2)
ret.FP_Bitrate = (ret.FP_Filesize * 8) / ret.FP_Playtime
Else
' Skips the data of this unknown block
' The length is minus 24, since the guid and length itself are also counted
s = String(object_len - 24, 0): Get #ff, , s
End If
Next ho_i
End If
Close #ff
asf_get_tag = ret
End Function