http://qs321.pair.com?node_id=619553


in reply to Easy way to get the location of Outlook PSTs into my perl script?

Below is a more or less literal translation of the VBS code linked to in the OP (identical subroutine structure; similar variable names).

That code does the right thing on 2 WinXP machines with messaging installed. But I learnt during testing that the path to follow to get the PST names was different on both, so I assume there are different versions of Windows Messaging involved here, and probably there are even more variants where the code will fail ;-).

use strict; use warnings; use Win32::TieRegistry (Delimiter => '/'); use Encode; use Data::Dumper; my %r = ( PSTGuidLocation => '01023d00', MasterConfig => '01023d0e', PSTCheckFile => '00033009', PSTFile => '001f6700', PSTFile1 => '001e6700', keyMaster => '9207f3e0a3b11019908b08002b2a56c2', ProfilesRoot => 'CUser/Software/Microsoft/Windows NT/CurrentVersion/ +Windows Messaging Subsystem/Profiles/', DefaultProfileString => '/DefaultProfile', ); my $MessagingRoot = $Registry->{$r{ProfilesRoot}} # points to the Prof +iles reg path of the current user or die "Windows Messaging not installed here!?\n"; my $DefaultProfileName = $MessagingRoot->{$r{DefaultProfileString}} or die "There are no messaging profiles for this user on this machin +e.\n"; my %Out = ("DefaultProfile" => $DefaultProfileName, Profiles => {}); my @Profiles = grep {s/\/$//} keys %{$MessagingRoot}; for my $profileName (@Profiles) { $Out{Profiles}{$profileName} = [ GetPSTsForProfile($profileName) ]; } print Dumper(\%Out); sub GetPSTsForProfile { my $profileName = shift; my $regProfile = $MessagingRoot->{"$profileName/"}; my $strValue = $MessagingRoot->{"$profileName/$r{keyMaster}//$r{Mast +erConfig}"}; my $fmt = '%02x' x 16; my @PSTFileNames; for my $strPSTGuid (map {sprintf $fmt, unpack('C16', $_)} $strValue +=~ /.{16}/g) { my $PSTGuid2 = PSTlocation($regProfile->{"$strPSTGuid/"}) or next; push @PSTFileNames, PSTFileName($regProfile->{$PSTGuid2}) if IsAPST($regProfile->{"$strPSTGuid/"}); } return @PSTFileNames; } sub IsAPST { my $PSTGuid = shift or return; my $PSTGuildValue = $PSTGuid->{"/$r{PSTCheckFile}"} or return; unpack('L', $PSTGuildValue) == 0x20; } sub PSTlocation { my $PSTGuid = shift or return; my $PSTGuildValue = $PSTGuid->{"/$r{PSTGuidLocation}"} or return; my $len = length($PSTGuildValue); my @PSTGuildValue = unpack("C$len",$PSTGuildValue); my $fmt = '%02x' x $len; sprintf($fmt, @PSTGuildValue); } sub PSTFileName { my $PSTGuid = shift or return; my $PSTName = $PSTGuid->{$r{PSTFile}}; defined $PSTName ? decode('UCS2-LE', $PSTName) : $PSTGuid->{$r{PSTFi +le1}}; }
  • Comment on Re: Easy way to get the location of Outlook PSTs into my perl script?
  • Download Code

Replies are listed 'Best First'.
Re^2: Easy way to get the location of Outlook PSTs into my perl script?
by rsilvergun (Acolyte) on Jun 10, 2007 at 00:53 UTC
    Wow, thanks :). That's amazing that you could do that. Wish I'd checked back sooner, since I just re-wrote it myself too :) lol. I haven't written code in ages, so your version is much nicer (and probably less prone to exploading :) ). I know from the link NetWallah posted that different versions will do different things though (thanks, NetWallah, btw :) ). At anyrate, here's the ( pretty ugly ) I came up with:
    use Win32::TieRegistry; $PSTGuidLocation = "01023d00"; $MasterConfig = "01023d0e"; $PSTCheckFile = "00033009"; $PSTFile = "001f6700"; $keyMaster = "9207f3e0a3b11019908b08002b2a56c2"; $ProfilesRoot = "Software\\Microsoft\\Windows NT\\CurrentVersion\\Wind +ows Messaging Subsystem\\Profiles"; $DefaultOutlookProfile = "Software\Microsoft\Windows NT\CurrentVersion +\Windows Messaging Subsystem\Profiles"; $DefaultProfileString = "DefaultProfile"; $defaultProfile = $Registry->{"CUser\\$ProfilesRoot\\$DefaultProfileString"}; print "\nDefault Profile: $defaultProfile\n\n"; $profileName = $Registry->{"CUser\\$ProfilesRoot\\$defaultProfile\\"}; $" = "\n"; @thePSTList = GetPSTsForProfile(); print "@thePSTList"; sub GetPSTsForProfile{ #This will fetch the $MasterConfig key where the location of pstfi +les is stored. my @valueNames = $Registry->{"CUser\\$ProfilesRoot\\$defaultProfil +e\\$keyMaster"}->GetValue($MasterConfig); #get the data out of the list the above line returned. $strValue = @valueNames[0]; #this line of code does a lot -> # 1. The call to unpack use's the H* Template to turn everything i +n $strValue into a large Hex String. # 2. The call to split breaks it up into an array of 3 strings, bu +t leaves some entries that are just # white space. # 3. The call to grep prunes out the whitespace and anything that +isn't 16 binary digits # by matching array elements that are 32 characters long (since + each character is a # binary digit. # 4. All done, we now have the contents of the '01023d0e' registry + value in a convient List my @hex = grep ( /.{32}?/, split(/(.{32,}?)/, unpack('H*', "$strVa +lue") ) ); foreach $pstLocString (@hex) { #If IsAPST(r_ProfilesRoot & "\" & p_profileName & "\" & strPST +Guid) Then #if it's not a PST, skip it. if ( !IsAPST($ProfilesRoot . "\\" . "$defaultProfile" . "\\" . + $pstLocString) ){ next; }#end if. $curPSTLocation = PSTLocation("$ProfilesRoot\\$defaultProfile\ +\$pstLocString"); push(@pstPathList, PSTFileName("$ProfilesRoot\\$defaultProfile +\\$curPSTLocation") ); }#end foreach return @pstPathList; }#end sub GetPSTsForProfile. sub IsAPST { #copy the function parameter into a scalar for readability. $PSTGuid = $_[0]; #Get the key from the registry that indicates whether this is a ps +t or not. my @valueNames = $Registry->{"CUser\\$PSTGuid"}->GetValue($PSTChec +kFile); # Just like before in the main GetPSTsForProfile function, this do +es a lot... # 1. The call to unpack use's the H* Template to turn everything i +n $strValue into a large Hex String. # 2. The call to split breaks everything up into binary digits # i.e. it makes a list with every two characters from the Hex S +tring as an element. # 3. The call to grep discards any elements that are just blank sp +ace. @PSTGuildValue = grep ( /./, split( /(.{2,}?)/, unpack( 'H*', @val +ueNames[0] ) ) ); # Finally, if the first element of @PSTGuildValue equals 20, it's +TRUE that this is a PST, otherwise it's false. # return accordingly. return @PSTGuildValue[0] == "20"; }#end sub IsAPST sub PSTLocation { #copy the function parameter into a scalar for readability. $PSTGuid = $_[0]; my @valueNames = $Registry->{"CUser\\$PSTGuid"}->GetValue($PSTGuid +Location); $PSTlocation = unpack( 'H*', @valueNames[0] ); return "$PSTlocation"; }#end sub PSTLocation sub PSTFileName { $pstLocationString = ""; #oReg.GetBinaryValue HKEY_CURRENT_USER,p_PSTGuid,r_PSTFile,P_PSTNa +me #copy the function parameter into a scalar for readability. $PSTGuid = $_[0]; #This fetches the file name data out of the registry and stores it + into @valueNames. my @valueNames = $Registry->{"CUser\\$PSTGuid"}->GetValue($PSTFile +); # @valueNames[0] has the path, but there are extra spaces between +every character that are added # into the registry. Ths splits the @valueNames string into the + @pstChars list, so we now have # a list with every character of the path (and each of those ex +tra spaces) as an element. @pstChars = split(//, @valueNames[0] ) ; #This for loop selects every other item in the @pstChars array, si +nce every other item is a valid character # and the items in between are worthless spaces added into the +registry. # each element is stored in $pstLocationString. for ($i = 0; $i < (@pstChars - 1); $i += 2){ $pstLocationString .= $pstChars[$i] }#end for loop #for the sake of completeness, removing any trailing spaces. $pstLocationString =~ s/\W+$//; return $pstLocationString; }#end sub PSTFileName #this is a debugging function, it prints the keys of a hash, and gets +used for printing the hash returned by calls to # $Registry->... sub printRegKey{ foreach $myKey (keys %{ $_[0] } ){ print "$myKey\n"; }#end for Each. }#end sub printRegKey