Tech Haven Network

Only the first section, and this is only for those who are intrested in the code itself. pretty simple program for setting up the RPOS colour ( i know the .ini isnt the right one. that will be set later )

Code: Select all

Dim colour As String
Dim red As String
Dim blue As String
Dim green As String
Dim allcolour As String

Private Sub cmd_rposexit_Click()
frm_rpos.Visible = False
frm_main.Visible = True
End Sub

Private Sub cmd_rposreset_Click()
SHP_colour.BackColor = RGB(0, 0, 0)
HSB_Red.Value = 0
HSB_Green.Value = 0
HSB_Blue.Value = 0
End Sub

Private Sub cmd_write_Click()
Dim x            As Long
Dim sSection     As String
Dim sEntry       As String
Dim sString      As String
Dim sFileName    As String

allcolour = red$ & " " & green$ & " " & blue$ & " " & 255

sSection$ = "DEFAULT"
sEntry$ = colour$
sString$ = allcolour$
sFileName$ = "c:\sample.ini"


x = WritePrivateProfileString(sSection$, sEntry$, sString$, sFileName$)

If x Then
     MsgBox "Setting has been saved"
Else
     MsgBox "Error saving setting"
End If

End Sub

Private Sub Form_Load()
frm_rpos.Top = 0
frm_rpos.Left = 0
End Sub

Private Sub HSB_Blue_Change()
SHP_colour.BackColor = RGB(HSB_Red.Value, HSB_Green.Value, HSB_Blue.Value)
red$ = HSB_Red.Value
green$ = HSB_Green.Value
blue$ = HSB_Blue.Value
End Sub

Private Sub HSB_Green_Change()
SHP_colour.BackColor = RGB(HSB_Red.Value, HSB_Green.Value, HSB_Blue.Value)
red$ = HSB_Red.Value
green$ = HSB_Green.Value
blue$ = HSB_Blue.Value
End Sub

Private Sub HSB_Red_Change()
SHP_colour.BackColor = RGB(HSB_Red.Value, HSB_Green.Value, HSB_Blue.Value)
red$ = HSB_Red.Value
green$ = HSB_Green.Value
blue$ = HSB_Blue.Value
End Sub

Private Sub opt_rpos_Click(Index As Integer)
Select Case Index

Case 0
colour$ = "Default"
Case 1
colour$ = "DefaultText"
Case 2
colour$ = "DefaultTextEffect"
Case 3
colour$ = "SysMessages"
Case 4
colour$ = "GameMessages"
Case 5
colour$ = "LocalChat"
Case 6
colour$ = "GlobalChat"
Case 7
colour$ = "TeamChat"
Case 8
colour$ = "DirectChat"
Case 9
colour$ = "Player"
Case 10
colour$ = "PlayerNoPK"
Case 11
colour$ = "CharSysWarning"
Case 12
colour$ = "CharSysBonus"
Case 13
colour$ = "CharSysCritical"
Case 14
colour$ = "ContextActive"
Case 15
colour$ = "ContextNoActive"
Case 16
colour$ = "ContextDisabled"
Case 17
colour$ = "HighlightText"
Case 18
colour$ = "HighlightBackground"
Case 19
colour$ = "Item"
Case 20
colour$ = "ItemDisabled"
Case 21
colour$ = "ItemNotUsable"
Case 22
colour$ = "GoodSoullight"
Case 23
colour$ = "NeutralSoullight"
Case 24
colour$ = "BadSoullight"
Case 25
colour$ = "Damage"
Case 26
colour$ = "Heal"

End Select
End Sub


I'm not sure what programing language your using to build this code... almost looks like your implementing it into neocron itself....

VB code, any chance we could get the App?

Now that I understand what you are doing...

1. Put all the colours into an array...eg

Dim sColours as string()

sColour(0) = "Default"
sColour(1) = "DefaultText"

...etc

And to get the colour replace all those case statements.

colour=sColour(Index)

Also why are youn using the $ at the end of variables? You dont need it in VB.

VB? arg fuck that, sorry not gonna bother then (NFI) decided a long time ago I'd never wanted anything to do with that piece of crap script language (again NFI to you)

Perhaps you can move into something more appropiate ?
Java would be nice, could run it as web app then to.

don't bother with code shit use applescrpts ::cheers::

Well i have a level 3 in visual basic. so it will be written in visual basic, the app will be ready soon. this is basically just for me to learn.

Brammers wrote:Also why are youn using the $ at the end of variables? You dont need it in VB.

Its a good coding convention for VB, if your not using polish notation (eg. strColorText or sColorText). Although after looking it appears half of it is in polish notation and the rest isn't.

Also throw in an "option explicit".

Your right about the case statement. Not nice way to do it. Personally I'd put the number code and text out to an ini file as well. That way someone else could localise the program without having to edit the code.

Well theres a module or infact two stuck on the side of that here is the full code. not working just yet fully due to a bug in my code. just i have no reason to fix it right now.

MODULE 1

Code: Select all

' The following module uses API functions available in kernel32
' to interact with specified files

Public Declare Function GetPrivateProfileSection Lib "Kernel32" _
    Alias "GetPrivateProfileSectionA" (ByVal lpAppName As String, _
    ByVal lpReturnedString As String, ByVal nSize As Long, _
    ByVal lpFileName As String) As Long
    ' Get the section from the INI file
    ' lpAppName refers to the section in the INI file
    ' lpReturnedString refers to the retrieved string
    ' nSize refers to the size of retrieved string
    ' lpFileName refers to the INI file

Public Declare Function GetPrivateProfileString Lib "Kernel32" _
   Alias "GetPrivateProfileStringA" (ByVal lpApplicationName _
   As String, ByVal lpKeyName As Any, ByVal lpDefault As String, _
    ByVal lpReturnedString As String, ByVal nSize As Long, _
    ByVal lpFileName As String) As Long
    ' Gets the settings from INI file
    ' lpApplicationName refers to the section in the INI file
    ' lpKeyName refers to the key we wish to change
    ' lpDefault refers to the value the key takes if no value is entered for it
    ' lpReturnedString refers to the retrieved string
    ' nSize refers to the size of retrieved string
    ' lpFileName refers to the INI file

Public Declare Function WritePrivateProfileSection Lib "Kernel32" _
    Alias "WritePrivateProfileSectionA" (ByVal lpAppName As String, _
    ByVal lpString As String, ByVal lpFileName As String) As Long
    ' Writes the section to the INI file
    ' lpAppName refers to the section in the INI file
    ' lpString refers to the string being written
    ' lpFileName refers to the INI file
   
Public Declare Function WritePrivateProfileString Lib "Kernel32" _
    Alias "WritePrivateProfileStringA" (ByVal lpApplicationName _
    As String, ByVal lpKeyName As Any, ByVal lpString As Any, _
    ByVal lpFileName As String) As Long
    ' Writes the settings to the INI file
    ' lpApplicationName refers to the section in the INI file
    ' lpKeyName refers to the Key being written to
    ' lpString refers to the value being written to the specified Key
    ' lpFileName refers to the INI file
   
    'Public gstrKeyValue As String * 256

Public path As String


MODULE 2

Code: Select all

Option Explicit

Private Type BrowseInfo
    lngHwnd        As Long
    pIDLRoot       As Long
    pszDisplayName As Long
    lpszTitle      As Long
    ulFlags        As Long
    lpfnCallback   As Long
    lParam         As Long
    iImage         As Long
End Type

Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260

Private Declare Sub CoTaskMemFree Lib "ole32.dll" _
    (ByVal hMem As Long)

Private Declare Function lstrcat Lib "Kernel32" _
   Alias "lstrcatA" (ByVal lpString1 As String, _
   ByVal lpString2 As String) As Long
   
Private Declare Function SHBrowseForFolder Lib "shell32" _
   (lpbi As BrowseInfo) As Long
   
Private Declare Function SHGetPathFromIDList Lib "shell32" _
   (ByVal pidList As Long, ByVal lpBuffer As String) As Long


Public Function BrowseForFolder(ByVal lngHwnd As Long, ByVal strPrompt As String) As String

    On Error GoTo ehBrowseForFolder 'Trap for errors

    Dim intNull As Integer
    Dim lngIDList As Long, lngResult As Long
    Dim strpath As String
    Dim udtBI As BrowseInfo

    'Set API properties (housed in a UDT)
    With udtBI
        .lngHwnd = lngHwnd
        .lpszTitle = lstrcat(strPrompt, "")
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With

    'Display the browse folder...
    lngIDList = SHBrowseForFolder(udtBI)

    If lngIDList <> 0 Then
        'Create string of nulls so it will fill in with the path
        strpath = String(MAX_PATH, 0)

        'Retrieves the path selected, places in the null
         'character filled string
        lngResult = SHGetPathFromIDList(lngIDList, strpath)

        'Frees memory
        Call CoTaskMemFree(lngIDList)

        'Find the first instance of a null character,
         'so we can get just the path
        intNull = InStr(strpath, vbNullChar)
        'Greater than 0 means the path exists...
        If intNull > 0 Then
            'Set the value
            strpath = Left(strpath, intNull - 1)
        End If
    End If

    'Return the path name
    BrowseForFolder = strpath
    Exit Function 'Abort

ehBrowseForFolder:

    'Return no value
    BrowseForFolder = Empty

End Function


frm_main

Code: Select all

Private Sub cmd_options_Click()
frm_options.Visible = True
frm_main.Visible = False
End Sub

Private Sub cmd_quit_Click()

End

End Sub

Private Sub cmd_rpos_Click()

frm_rpos.Visible = True
frm_main.Visible = False

End Sub


frm_rpos

Code: Select all

Dim colour As String
Dim red As String
Dim blue As String
Dim green As String
Dim allcolour As String
Dim inipath As String

Private Sub cmd_rposexit_Click()
frm_rpos.Visible = False
frm_main.Visible = True
End Sub

Private Sub cmd_rposreset_Click()
SHP_colour.BackColor = RGB(0, 0, 0)
HSB_Red.Value = 0
HSB_Green.Value = 0
HSB_Blue.Value = 0
End Sub

Private Sub cmd_write_Click()
Dim x            As Long
Dim sSection     As String
Dim sEntry       As String
Dim sString      As String
Dim sFileName    As String

allcolour = red$ & " " & green$ & " " & blue$ & " " & 255
inipath = strpath$ & "\ ini \ rposcolor.ini"
sSection$ = "DEFAULT"
sEntry$ = colour$
sString$ = allcolour$
sFileName$ = inipath


x = WritePrivateProfileString(sSection$, sEntry$, sString$, sFileName$)

If x Then
     MsgBox "Setting has been saved"
Else
     MsgBox "Error saving setting"
End If

End Sub

Private Sub Form_Load()
frm_rpos.Top = 0
frm_rpos.Left = 0
End Sub

Private Sub HSB_Blue_Change()
SHP_colour.BackColor = RGB(HSB_Red.Value, HSB_Green.Value, HSB_Blue.Value)
red$ = HSB_Red.Value
green$ = HSB_Green.Value
blue$ = HSB_Blue.Value
End Sub

Private Sub HSB_Green_Change()
SHP_colour.BackColor = RGB(HSB_Red.Value, HSB_Green.Value, HSB_Blue.Value)
red$ = HSB_Red.Value
green$ = HSB_Green.Value
blue$ = HSB_Blue.Value
End Sub

Private Sub HSB_Red_Change()
SHP_colour.BackColor = RGB(HSB_Red.Value, HSB_Green.Value, HSB_Blue.Value)
red$ = HSB_Red.Value
green$ = HSB_Green.Value
blue$ = HSB_Blue.Value
End Sub

Private Sub opt_rpos_Click(Index As Integer)
Select Case Index

Case 0
colour$ = "Default"
Case 1
colour$ = "DefaultText"
Case 2
colour$ = "DefaultTextEffect"
Case 3
colour$ = "SysMessages"
Case 4
colour$ = "GameMessages"
Case 5
colour$ = "LocalChat"
Case 6
colour$ = "GlobalChat"
Case 7
colour$ = "TeamChat"
Case 8
colour$ = "DirectChat"
Case 9
colour$ = "Player"
Case 10
colour$ = "PlayerNoPK"
Case 11
colour$ = "CharSysWarning"
Case 12
colour$ = "CharSysBonus"
Case 13
colour$ = "CharSysCritical"
Case 14
colour$ = "ContextActive"
Case 15
colour$ = "ContextNoActive"
Case 16
colour$ = "ContextDisabled"
Case 17
colour$ = "HighlightText"
Case 18
colour$ = "HighlightBackground"
Case 19
colour$ = "Item"
Case 20
colour$ = "ItemDisabled"
Case 21
colour$ = "ItemNotUsable"
Case 22
colour$ = "GoodSoullight"
Case 23
colour$ = "NeutralSoullight"
Case 24
colour$ = "BadSoullight"
Case 25
colour$ = "Damage"
Case 26
colour$ = "Heal"

End Select
End Sub


frm_options

Code: Select all

Public strpath As String
Private Sub cmd_browse_Click()
strpath = BrowseForFolder(Me.hWnd, "Locate Neocron Directory")
txt_path.Text = strpath
End Sub

Private Sub cmd_exit_Click()
frm_options.Visible = False
frm_main.Visible = True
End Sub

Private Sub Command1_Click()
Dim sSection     As String
Dim sEntry       As String
Dim sString      As String
Dim sFileName    As String

inipath = strpath$ & "/neocron.ini"
sSection$ = ""
sEntry$ = NOSPLASH
sString$ = "True"
sFileName$ = inipath

inipath = strpath$ & "/neocron.ini"
sSection$ = ""
sEntry$ = NOEXTRO
sString$ = "True"
sFileName$ = inipath

End Sub


love to get it working but as I said, I'm not touching vb(s)

anyone wanna do the honor? besides the language itself it looks intresting enough and since syn won't be returning to neocron (...with a pitty excuse I must add ) somebody else would need to get it done instead :/

like i said done for myself, for my own reasons there are about 5-6 already about. but thats not why i did it. and i still play neocron on another server under another name. with my true friends. but after all the bullshit i have no heart to carry on here.

I have abslutely no intrest in programming whatsoever. I pay peeps to do it for me. i'll just shut up.