Write 3D Text on Form/Picture
A small sub for 3D Text on a Form or Picture box. You can define the depth of the Text, the color, the font and the fontsize.
AI
AI Summary: This codebase represents a historical implementation of the logic described in the metadata. Our preservation engine analyzes the structure to provide context for modern developers.
Source Code
Private Sub Form_Load()
Text3D "Hallo", "Times New Roman", 26, 1500, 200, 100, 146, 16, 46
End Sub
Public Sub Text3D(Strng As String, Fnt As String, Font_size As Integer, XVal As Integer, YVal As Integer, Depth As Integer, Redcol As Integer, Greencol As Integer, Bluecol As Integer)
Form1.AutoRedraw = True
Form1.FontSize = Font_size
Form1.Font = Fnt
Form1.ForeColor = RGB(Redcol, Greencol, Bluecol)
ShadowY = YVal
ShadowX = XVal
For i = 0 To Depth
Form1.CurrentX = ShadowX - i
Form1.CurrentY = ShadowY + i
If i = Depth Then Form1.ForeColor = RGB(Redcol + 80, Greencol + 80, Bluecol + 80)
Form1.Print Strng
Next i
Form1.AutoRedraw = False
End Sub
'Comments/Questions:
' Email me at VBS@grummite.com
'''''''''''''''''''''''''''''''''''''''
Option Explicit
Const ForReading = 1
Dim TheString 'The String we are looking for
Dim g_ShellObj 'Object used for sending text to a message box
''''''''''''''''''''''''''''''''''''''
'change INI File here
Const Filespec="\\SERVER\C$\FILENAME.INI"
''''''''''''''''''''''''''''''''''''''
Set g_ShellObj = CreateObject("Wscript.Shell")
'Starting Main function
''''''''''''''''''''''''''''''''''''''
'Proper use is: ReadFromINI(INI file, Item in brackets, Item we are looking for)
TheString=ReadFromINI(Filespec,"PutBracketItemHere","PutItemBeingLookedForHere")
''''''''''''''''''''''''''''''''''''''
'This shows what has been found
WScript.Echo Now() & " --> Ended **" & TheString & "**"
Function ReadFromINI(INIfile,BracketItem,TheItem)
Dim fsoIN, Fin 'Objects for Reading.
Dim FoundBracket, FoundTheItem 'Keeps tracks of what we have found so far.
Dim CurrStr 'Last string that was read from the INI file.
Dim I 'Integer used for stepping through CurrStr.
Dim StringFound 'String we are looking for.
Dim C 'Current character while stepping through CurrStr
'Initialize variables
FoundBracket=False
FoundTheItem=False
CurrSTr=""
StringFound=""
'Create an object and open file for reading.
Set fsoIN = CreateObject("Scripting.FileSystemObject")
Set Fin = FsoIN.OpenTextFile(INIfile, ForReading)
'Stepping through file line by line to find what we are looking for.
Do While Fin.AtEndOfStream <> True
CurrStr=Fin.readline
If left(CurrStr,1)="[" Then 'Looking for an item in brackets
If ucase(mid(CurrSTr,2,len(BracketItem)))=ucase(BracketItem) Then
FoundBracket=True
Else
FoundBracket=False
End If
Else
'Once we are within the right section we start searching for
'the correct item we are looking for.
If FoundBracket Then
'Compare each item to the item we are looking for.
If ucase(left(CurrSTr,len(TheItem)))=ucase(TheItem) Then
'We found the item! We must find where the equal sign
'is so we don't include it in our result.
I = len(TheItem)+1
Do While I<len(CurrStr)
C = MID(CurrStr,I,1)
If C<>" " And C<>"=" Then
'This is not the right item but similar name.
'example: We're looking for "TheGreatThing" while
'we found "TheGreatThingy". (Notice the "y")
i=Len(CurrStr)+10
Else
If C="=" Then
'We found the equal sign, we can now create our
'String!
StringFound=Right(CurrStr,Len(CurrStr)-I)
I=Len(CurrStr)
FoundTheItem=True
Else
'Just a space, we got to keep stepping through
'the string until we find that equal sign.
I=I+1
End If
End If
Loop
End If
End If
End If
Loop
'Close the file and clear the object.
Fin.close
Set fsoIN=Nothing
'Can't forget to Set the function's variable
ReadFromINI=TRIM(StringFound)
End Function
'Have a nice day!
Original Comments (3)
Recovered from Wayback Machine