Malicious Office (OLE) — malware analysis report

Attribute VB_Name = "runGAMS"

Option Explicit
' ------------------------------
'
' Description:
'   VB 4.0 code for running gams (version 2.25.089 or later) under Windows 95 or
'     Windows 3.1
'
'   This code is generic and does not change from application to application
'      to start it up use GAMSRUN as function as in spplication module
'
' ' Gams Specific Procedures/Function
'
'   GamsErrorString       - Function returns descriptive text about process object
'
' General Procedures/Function
'
'   ShowWait              - change cursor
' -------------------------------
'
' Public GAMS Constants
Public Const GAMS_STILL_ACTIVE = 258
' -----------------
' BEGIN API DECLARATIONS (API)
#If Win64 Then
Public Declare PtrSafe Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Any, ByVal lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Any, ByVal lpCurrentDriectory As Any, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Public Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare PtrSafe Function WaitForInputIdle Lib "user32" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long
Public Declare PtrSafe Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Public Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Public Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Public Declare PtrSafe Function GetTopWindow Lib "user32" (ByVal hWnd As Long) As Long
Public Declare PtrSafe Function IsWindowEnabled Lib "user32" (ByVal hWnd As Long) As Long
Public Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare PtrSafe Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Public Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare PtrSafe Function GetLastError Lib "kernel32" () As Long
Private Declare PtrSafe 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
#Else
Public Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Any, ByVal lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Any, ByVal lpCurrentDriectory As Any, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Function WaitForInputIdle Lib "user32" (ByVal hProcess As Long, ByVal dwMilliseconds As Long) As Long
Public Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Public Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Public Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Public Declare Function GetTopWindow Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function IsWindowEnabled Lib "user32" (ByVal hWnd As Long) As Long
Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function GetLastError Lib "kernel32" () As Long
Private 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
#End If
'
' Constants used with CreateProcess
Public Const SW_SHOWMINNOACTIVE = 7
Public Const STARTF_USESHOWWINDOW = &H1
Public Const STARTF_USEPOSITION = &H4
Public Const STARTF_USESIZE = &H2
Public Const NORMAL_PRIORITY_CLASS = &H20
Public Const WM_CLOSE = &H10
Public Const STILL_ACTIVE = 259

' Constants used with GetWindowLong
Public Const GWL_STYLE = (-16)
'
' Constants used with GetWindow
Public Const GW_HWNDNEXT = 2
'
' Structures used with CreateProcess
Public Type STARTUPINFO
   cb As Long
   lpReserved As String
   lpDesktop As String
   lpTitle As String
   dwX As Long
   dwY As Long
   dwXSize As Long
   dwYSize As Long
   dwXCountChars As Long
   dwYCountChars As Long
   dwFillAttribute As Long
   dwFlags As Long
   wShowWindow As Integer
   cbReserved2 As Integer
   lpReserved2 As Long      'LPBYTE
   hStdInput As Long
   hStdOutput As Long
   hStdError As Long
End Type

Public Type PROCESS_INFORMATION
   hProcess As Long
   hThread As Long
   dwProcessId As Long
   dwThreadId As Long
End Type
' END API DECLARATIONS  (/API)
'-----------------------------


' run gams and return gams return code
Public Function GAMSrun(params As String, sGAMSFl As String) As Long
    Dim sError As String, sText As String, bOK As Boolean
    Dim sappfl As String
    Dim command As String
    Dim hWnd As Long, lSecs As Long
    Dim lCreateFlag As Long
    Dim StartUp As STARTUPINFO, udtProcess As PROCESS_INFORMATION
    Dim lRetAPI As Long, lRetProcess As Long, lRetWait As Long, lRetExit As Long, lRetErr As Long
    Dim sTitle As String, lRetWT As Long, lLength As Long, sFinished As String
    Dim strBuffer As String
    Dim lenstr As Long
    Dim i As Long
    Dim substring As String
    Dim s As String
    ShowWait True
    
    'look for the path to the gams executable from the registry
    Dim gamsDir As String
    gamsDir = ""
    
    gamsDir = GetGamsSysDir()
        
    If gamsDir = "" Then
      MsgBox ("No GAMS Directory found")
    End If
    
    strBuffer = Space(1024)
    strBuffer = gamsDir & "\gams.exe"
    'Altenatively, you can set the gams path manually
    'strBuffer = "C:\GAMS\win64\23.8\gams.exe"
    lenstr = Len(strBuffer)
    
    'find e at end of gams.exe
    For i = Len(strBuffer) To 1 Step -1
      If Mid(strBuffer, i, 1) = "e" Then
            Exit For
       End If
    Next
    
    'take just non blank part of name for gams executable
    sappfl = Mid(strBuffer, 1, i)

    'form gams call for dos
    command = Chr(34) & sappfl & Chr(34) & " " & Chr(34) & sGAMSFl & Chr(34) & " " & params
    
    sFinished = "FINISHED"
    lLength = Len(sFinished) + 1

    ' wait in milliseconds for process completion
    lSecs = 1000
   
    ' set default return value
    lRetProcess = -1
    StartUp.lpTitle = "VB GAMS"
    StartUp.dwFlags = STARTF_USESHOWWINDOW
    StartUp.wShowWindow = SW_SHOWMINNOACTIVE
    StartUp.dwFlags = StartUp.dwFlags + STARTF_USEPOSITION + STARTF_USESIZE
    StartUp.dwXSize = 800
    StartUp.dwYSize = 600
    StartUp.cb = Len(StartUp)
    lCreateFlag = NORMAL_PRIORITY_CLASS
    
    ' Call CreateProcess to actually run GAMS
    '
    If CreateProcess(vbNullString, command, 0&, 0&, 1, lCreateFlag, 0&, 0&, StartUp, udtProcess) Then
        ' WaitForInputIdle call necessary to allow process to initialize itself.
        '  After call, it is possible to ascertain the window handle from the process handle.
        lRetWait = WaitForInputIdle(udtProcess.hProcess, lSecs)
     
        ' Get the window handle of the process
        hWnd = ProcToWnd32(udtProcess.dwProcessId)
     
        ' loop until process completed
        Do
            lRetAPI = WaitForSingleObject(udtProcess.hProcess, lSecs)
            If lRetAPI = GAMS_STILL_ACTIVE Then
                ' If the process is still running and there is a valid window handle,
                '   check the window's title to see if sFinished appears in the first
                '   lLength characters of the title.  If it does, then close window.
                ' This is necessary when the calling process doesn't have a console and
                '   the spawned job "hangs" untill the user closes the window.
                '   This "hanging" occurs when batch files call other batch files or
                '   executables.
                If IsWindowEnabled(hWnd) Then
                    sTitle = String(lLength, " ")
                    lRetWT = GetWindowText(hWnd, sTitle, lLength)
                    If InStr(UCase(sTitle), sFinished) Then
                        Call PostMessage(hWnd, WM_CLOSE, 0, 0)
                    End If
                End If
            Else   ' get the exit code of the spawned process
                lRetExit = GetExitCodeProcess(udtProcess.hProcess, lRetProcess)
            End If
        Loop While lRetAPI = GAMS_STILL_ACTIVE
        
        If lRetProcess = STILL_ACTIVE Then
            lRetProcess = -1
        End If

        ' Close process and thread handles.  Otherwise, memory leaks will occur.
        Call CloseHandle(udtProcess.hProcess)
        Call CloseHandle(udtProcess.hThread)
    Else
        lRetProcess = -1
'        lRetErr = Err.LastDllError
        lRetErr = 1
    End If
    GAMSrun = lRetProcess
    ShowWait False
End Function

' --------
' GamsErrorString returns a message describing kind of error encountered
'   returned from vbGams
' vbGams returns
'   1000 - missing input string
'   cmexRC + 100 * vbgamsRC
Public Function GamsErrorString(lGamsRC As Long) As String
Attribute GamsErrorString.VB_ProcData.VB_Invoke_Func = " \n14"
Dim nCmexRC As Integer, nVB_GamsRC As Integer
Dim sError As String
    If lGamsRC = 0 Then
        sError = "Gams completed successfully."
    ElseIf lGamsRC = 1000 Then
        sError = "Gams call missing input string."
    ElseIf lGamsRC = 2000 Then
        sError = "Error shelling out to Gams."
    Else
        sError = ""
        nCmexRC = lGamsRC Mod 100
        nVB_GamsRC = Int(lGamsRC / 100)
        If nCmexRC < 0 Then
            sError = "GAMS is probably not in path or your path does not point to GAMS"
        End If
        If nCmexRC > 0 Then
            Select Case nCmexRC
                Case 1
                    sError = "Solve is next (should not happen)."
                Case 2
                    sError = "compilation error"
                Case 3
                    sError = "execution error"
                Case 4
                    sError = "system limits"
                Case 5
                    sError = "file error"
                Case 6
                    sError = "parameter error"
                Case 7
                    sError = "licensing error"
                Case 8
                    sError = "GAMS system error"
                Case 9
                    sError = "GAMS could not be started"
            End Select
        End If
        If nVB_GamsRC > 0 Then
            If nCmexRC > 0 Then
                sError = sError & vbCrLf
            End If
            Select Case nVB_GamsRC
                Case 1
                    sError = sError & "could not create process dir"
                Case 2
                    sError = sError & "could not run gamsparm script"
                Case 3
                    sError = sError & "could not append user input to parameter scratch file"
                Case 4
                    sError = sError & "could not spawn gamscmex.exe"
                Case 5
                    sError = sError & "could not shell off 'gamsnext' script"
                Case 6
                    sError = sError & "could not delete process directory"
                    
            End Select
        End If
    End If
    
    GamsErrorString = sError
End Function

Function optstatus() As String
    Dim oResults As Range, oX As Range, nj As Integer, stat As Integer
    Set oResults = Worksheets("Results").Range("A1").CurrentRegion
     ' for each production center, update the results
    stat = 0
    For nj = 2 To oResults.Rows.Count
       If Trim(UCase(oResults.Cells(nj, 1))) = "MODELSTAT" Then
          stat = oResults.Cells(nj, 2)
       End If
    Next
    optstatus = "Unknown I cant find model stat"
    If stat > 0 Then
          Select Case stat
                Case 1
                     optstatus = "Optimal"
                Case 2
                     optstatus = "Optimal"
                Case 3
                     optstatus = "Unbounded"
                Case 4
                     optstatus = "Infeasible"
                Case Else
                     optstatus = "Bad Result from GAMS"
            End Select
    End If
End Function

' ------
' Sub ShowWait
'   Set cursor shape depending on Wait parameter
Public Sub ShowWait(ByVal Wait As Boolean)
Attribute ShowWait.VB_ProcData.VB_Invoke_Func = " \n14"
  If Wait Then
'    Screen.MousePointer = 11   ' hourglas
  Else
'    Screen.MousePointer = 0    ' default
  End If
End Sub
' -----
' ProcToWnd32
'    Given a process handle, the function checks each active
'    windows to see if is associated with the process.
'    If the process window has a title, function return a handle to it.
Private Function ProcToWnd32(hProcess As Long) As Long
Dim hWndNext As Long, sTitle As String, hWndProc As Long, lRet As Long, nCnt As Integer
Dim lChars As Long, lLength As Integer, lProcess As Long, nCntMatch As Integer
Dim lRet_gwl As Long

    lLength = 0
    lChars = 20
    hWndNext = GetTopWindow(0&)
    nCnt = 1
    nCntMatch = 0
    Do While True And nCnt < 300
        sTitle = ""
        hWndProc = GetWindowThreadProcessId(hWndNext, lProcess)
        If lProcess = hProcess Then ' Or hWndProc = dwProcess Then
            nCntMatch = nCntMatch + 1
            lRet_gwl = GetWindowLong(hWndNext, GWL_STYLE)
            lLength = GetWindowTextLength(hWndNext)

            If lLength > 0 Then
                lLength = lLength + 1   ' allow for null terminating char
                sTitle = String(lLength, " ")
                lRet = GetWindowText(hWndNext, sTitle, lLength)
                sTitle = Left(sTitle, InStr(sTitle, Chr$(0)) - 1)

                ProcToWnd32 = hWndNext
                Exit Do
            End If
            
        End If
        hWndNext = GetWindow(hWndNext, GW_HWNDNEXT)
        If IsNull(hWndNext) Then
            Exit Do
        End If
        If hWndNext = 0 Then
            Exit Do
        End If
        
        nCnt = nCnt + 1
    Loop

End Function





Attribute VB_Name = "Sheet8"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "trancode"

Option Explicit
' ------------------------------
'
' Description:
'   Application code for running a model through GAMS and Excel
'
'   There are four visual basic modules that are used in this application.
'   If you'd like to have a look at them, Select Macros from the Tool Menu, and
'   click on visual basic editor. In the project box click on modules and there they will be
'
'   The code which runs the transport application is in
'     trancode
'   Some base macros for starting up and managing the menu are in
'     basemacro
'   The code for running the GAMS job is included in
'     runGAMS
'   The code for managing file transfers between GAMS and Excel is in
'     utilities.
' ------------------------------
Public vbNullString As String    ' leave this variable null
Public vbCrLf As String

' main procedure for McCarl Transport model
Sub applicationMain()
Attribute applicationMain.VB_ProcData.VB_Invoke_Func = " \n14"
Dim sDir As String, sGAMSFile As String, sMsgText As String, lGAMSRet As Long, sGAMSErrorText As String
Dim sDrive As String, sGAMSListing As String, nI As Integer, sDirChar As String
Dim bOK As Boolean, sWorksheet As String, sRange As String, sOutFile As String
Dim params As String, errname As String
Dim bDelim As Boolean, mess As String


    ' clear out current results
    sDirChar = Application.PathSeparator   ' "\"
    vbCrLf = Chr(13) & Chr(10)
    ' set the path where the model is to run
    sDir = ActiveWorkbook.path
    sDrive = Mid(sDir, 1, 1)
    ' start in the workbook/model directory
    If sDrive <> sDirChar Then
        ChDrive sDrive
    End If
    ChDir sDir
    
    ' define gams model file name and listing file name
    sGAMSFile = sDir & sDirChar & "trnsxcll.gms"
    sGAMSListing = sDir & sDirChar & "trnsxcll.lst"
    Application.ScreenUpdating = False
    
    ' write files to be included
    
    'set up to write demand place names to file demand.tbl
    'here demanddat is the range of data containing the demand data from the inputs sheet
    'here filefordemandtbl is the name of the file to include with the demand data
    '      as defined in the model text sheet and equals demand.tbl
     sWorksheet = "Inputs"
     sRange = "Demandset"
     sOutFile = sDir & sDirChar & Trim(Range("filefordemandset")) ' "market.set"
     bDelim = True
     bOK = XL2Txt(sWorksheet, sRange, sOutFile, bDelim)
    
        'set up to write supply place names to file demand.tbl
        'here demanddat is the range of data containing the demand data from the inputs sheet
        'here filefordemandtbl is the name of the file to include with the demand data
        '      as defined in the model text sheet and equals demand.tbl
         sWorksheet = "Inputs"
         sRange = "supplyset"
         sOutFile = sDir & sDirChar & Trim(Range("fileforsupplyset"))
         bDelim = True
         bOK = XL2Txt(sWorksheet, sRange, sOutFile, bDelim)

        'set up to write demand quantity to file demand.tbl
        'here demanddat is the range of data containing the demand data from the inputs sheet
        'here filefordemandtbl is the name of the file to include with the demand data
        '      as defined in the model text sheet and equals demand.tbl
         sWorksheet = "Inputs"
         sRange = "demanddat"
         sOutFile = sDir & sDirChar & Trim(Range("filefordemandtbl"))
         bDelim = True
         bOK = XL2Txt(sWorksheet, sRange, sOutFile, bDelim)

        'set up to write supply quantity to file supply.tbl
        'here supplydat is the range of data containing the supply data from the inputs sheet
        'here fileforsupplytbl is the name of the file to include with the supply data
        '      as defined in the model text sheet and equals supply.tbl
         sWorksheet = "Inputs"
         sRange = "supplydat"
         sOutFile = sDir & sDirChar & Trim(Range("fileforsupplytbl"))
         bDelim = True
         bOK = XL2Txt(sWorksheet, sRange, sOutFile, bDelim)

        'set up to write distances to file distance.tbl
        'here distancedat is the range of data containing the supply data from the inputs sheet
        'here filefordistancetbl is the name of the file to include with the supply data
        '      as defined in the model text sheet and equals distance.tbl
         sWorksheet = "Inputs"
         sRange = "distancedat"
         sOutFile = sDir & sDirChar & Trim(Range("filefordistancetbl"))   ' "distance.tbl"
         bDelim = True
         bOK = XL2Txt(sWorksheet, sRange, sOutFile, bDelim)

        'set up to write transport rates to file tranrate.tbl
        'here distancedat is the range of data containing the supply data from the inputs sheet
        'here filefordistancetbl is the name of the file to include with the supply data
        '      as defined in the model text sheet and equals distance.tbl
         sWorksheet = "Inputs"
         sRange = " trandat"
         sOutFile = sDir & sDirChar & Trim(Range("filefortranratetbl"))   ' "tranrate.tbl"
         bDelim = True
         bOK = XL2Txt(sWorksheet, sRange, sOutFile, bDelim)

    
    
    
    ' define model outputs - files must have csv extension so default import
    '   of file works correctly
    sWorksheet = "Results"              ' target worksheet
    sRange = "A1"                       ' target range / defined range
    sOutFile = sDir & sDirChar & Trim(Range("fileforoutput"))  ' "output.csv"
    If Len(Dir(sOutFile)) > 0 Then
       Kill sOutFile
    End If
    Application.ScreenUpdating = True
    
    ' run the GAMS job
     Call ClearResults
     
     'define additional parameters to attach to GAMS call
     params = ""
     
     'now run gams
     
     lGAMSRet = GAMSrun(params, sGAMSFile)
     
     'check for errors
     If lGAMSRet = 0 Then
        ' GAMS was successful, import the GAMS output files as generated by the model
         If Len(Dir(sOutFile)) = 0 Then
            MsgBox "GAMS Output file not found: " & sOutFile
         Else
            Application.ScreenUpdating = False
            bOK = Txt2XLDump(sWorksheet, sRange, sOutFile)
            Application.ScreenUpdating = True
         End If
         sMsgText = "GAMS completed successfully."
      ' check optimality / feasibility status here
        mess = optstatus()
        If Not mess = "Optimal" Then
            sMsgText = "Bad Model Result when running GAMS." & vbCrLf & vbCrLf & mess & "."
            MsgBox sMsgText, vbOKOnly + vbCritical, "GAMS"
            If MsgBox("Do you want to look at the listings file?", vbYesNoCancel + vbDefaultButton2 + vbQuestion) = vbYes Then
               Shell "Notepad.exe " & sGAMSListing, 1
            End If
         Else
            MsgBox sMsgText, vbOKOnly, "GAMS"
         End If
      Else
      'GAMS terminated improperly
         sGAMSErrorText = GamsErrorString(lGAMSRet)
         ActiveWorkbook.Worksheets("MapSheet").TextBoxes("text box 31").Text = "Errors running GAMS."
         sMsgText = "Errors encountered when running GAMS." & vbCrLf & vbCrLf & "Error Code " & lGAMSRet & ": " & sGAMSErrorText & "."
         MsgBox sMsgText, vbOKOnly + vbCritical, "GAMS"
         If MsgBox("Do you want to look at the listings file?", vbYesNoCancel + vbDefaultButton2 + vbQuestion) = vbYes Then
              Shell "Notepad.exe " & sGAMSListing, 1
         End If
   End If
    
eof_gamsMain:

End Sub

    

    


' wipe out results stored on Results sheet
Sub ClearResults()
Dim oProdCenters As Range, nProdCnt As Integer, nI As Integer
Dim sProd As String
    ActiveWorkbook.Worksheets("MapSheet").TextBoxes("text box 31").Text = ""
    Worksheets("Results").Range("A2:f200").Clear
End Sub

' go to specific state sheet from the main control form - MapSheet
'   called when user clicks on state
' note you can add states by right clicking on the map object and
'    assigning the goto state macro then crating a sheet with the name
'    of the map object
'    ie to add wyoming create a new sheet called wyoming then right
'       click on wyoming and assign the go to state macro
'       you can also set properties on the drawing object to color it in
Sub MapSheetGotoState()
Dim sState As String
    sState = Application.Caller
    On Error GoTo err_mapsheetgotostate
    ActiveWorkbook.Worksheets(sState).Activate
err_mapsheetgotostate:
    On Error GoTo 0
End Sub

' go to the main control form - MapSheet
Sub GoToMapSheet()
    ActiveWorkbook.Worksheets("MapSheet").Activate
End Sub

' go to the transport rate form - trancost
Sub gototranrate()
    Sheets("Trancost").Select
End Sub

' open up the visual basic of the transport model
Sub viewvbmodule()
    Application.GoTo Reference:="applicationMain"
End Sub


    

Attribute VB_Name = "Sheet9"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "utilities"

Option Explicit
' ------------------------------
' Module Name: utilities
'
' Description:
'   VB 4.0 code for linking Excel 97 data to GAMS data - input & output
'
'   This code is generic and does not change from application to application
'      It contains
'        Txt2XLDump  -   Imports a string delimited table to an excel range
'        XL2Txt      -   Saves an excel range to a file
'                           the file can be either string delimited or
'                                                  space delimited.
'
' ------------------------------
'
' Function Txt2XLDump
'
'   Imports a CSV delimited table into an excel range.  This Function is called Dump
'   because the entire range is replaced the new data.  No precautions are done
'   to make sure previous data is preserved and all removed.   The range specified
'   is cleared out but that does not necessarily correspond to size of
'   imported file.  If that whole area is to be cleared out that should be done
'   in the spreadsheet or calling macro.
'
' Parameters
'   sSheet      String      Name of sheet into which to place data
'   sRange      String      Sheet address in which to put data either in the form of a
'                            Range Name or explicit reference (e.g. A1)
'                            Note only upper right hand corner matters
'   sInFile     String      Ascii file from which CSV data will be loaded into
'                           the active workbook.  Must have txt or csv extension.
'
' Returns
'   True/False  Depending on successful completion of function.
' -------

Function Txt2XLDump(sSheet As String, sRange As String, sInFile As String) As Boolean
Attribute Txt2XLDump.VB_ProcData.VB_Invoke_Func = " \n14"
Dim bOK As Boolean, oTarget As Range, oSource As Range, sWorkbook As String
    
    'open the csv file
    bOK = True
    sWorkbook = StripPath(sInFile)
    
    ' set and clear the target region
    Set oTarget = Application.ActiveWorkbook.Worksheets(sSheet).Range(sRange)
    oTarget.CurrentRegion.Clear
    
    ' open up the CSV delimited file as a new workbook
    Application.Workbooks.OpenText sInFile, xlMSDOS
    Set oSource = Application.Workbooks(sWorkbook).Worksheets(1).Range("A1").CurrentRegion
    
    ' copy the range from the source csv file to the target range
    oSource.Copy oTarget.Range("A1")
    
    ' close the csv file
    Application.Workbooks(sWorkbook).Close
    Txt2XLDump = bOK
End Function

' --------
' Function XL2Txt
'   Exports data in excel range to a file, either in string or space form.
'
' Parameters
'   sSheet      String      Name of Worksheet from which data are to be exported
'   sRange      String      Address of data to be exported in form of either Range Name
'                           or explicit reference (e.g. A1:C3)
'   sOutFile    String      Ascii file into which data will be placed.
'   bDelimFlag  Boolean     True if Output file is string delimited.
'
' Returns
'   True/False  Depending on successful completion of function.
' -------

Function XL2Txt(sSheet As String, sRange As String, sOutFile As String, bDelimFlag As Boolean) As Boolean
Attribute XL2Txt.VB_ProcData.VB_Invoke_Func = " \n14"
Dim oSheetAlias As Range, oTarget As Worksheet, bOK As Boolean, oSource As Worksheet, nI As Integer
Dim lColor As Long, lPattern As Long, nVarType As Integer, nColCnt As Integer

    bOK = True
    Set oSource = Application.ActiveWorkbook.Worksheets(sSheet)
    Set oSheetAlias = Application.ActiveWorkbook.Worksheets(sSheet).Range(sRange)
    With oSheetAlias.Interior
        lColor = .ColorIndex
        lPattern = .Pattern
        .ColorIndex = 3
        .Pattern = xlSolid
    End With
    With oSheetAlias.Interior
        .ColorIndex = lColor
        .Pattern = lPattern
    End With
    ' create temporary worksheet
    Set oTarget = Application.Workbooks.Add.Worksheets(1)
    'copy data to be exported
    oSheetAlias.Copy oTarget.Range("A1")
    oTarget.Range("A1").CurrentRegion.ClearFormats
    
    ' if this is to be a csv file Put something in the first cells,
    ' ie. upper-left blank cell of table so gams can import it.
    ' Otherwise, GAMS will have compile errors.
    If bDelimFlag Then
        nColCnt = oTarget.Range("A1").CurrentRegion.Columns.Count
        For nI = 1 To nColCnt
            nVarType = VarType(oTarget.Cells(1, nI).Value)
            If nVarType = vbNull Or nVarType = vbEmpty Or (nVarType = vbString And oTarget.Cells(1, 1).Value = "") Then
                oTarget.Cells(1, nI).Value = "X" & Trim(Str(nI))
            End If
        Next
    End If
    'wipe out target file if it exists
    If Len(Dir(sOutFile)) > 0 Then
        Kill sOutFile
    End If
    ' save the data to the target file
    If bDelimFlag Then
        oTarget.SaveAs sOutFile, xlCSV    ' string delimited
    Else
        oTarget.SaveAs sOutFile, xlTextPrinter  ' space delimited
    End If
    ' delete objects
    oTarget.Parent.Close False
    Set oTarget = Nothing
    Set oSheetAlias = Nothing
    ' check for sOutFile existence
    If Dir(sOutFile) = "" Then
        GoTo Error_file
    End If
    GoTo cleanup
Error_file:
    bOK = False
    MsgBox "Error creating text file: " & sOutFile, _
           vbOKOnly + vbCritical, "DAO Link Error"
    GoTo cleanup
ErrorRangeDef:
    bOK = False
    MsgBox "Excel OLE error.", _
           vbOKOnly + vbCritical, "DAO Link Error"
cleanup:
    Set oSource = Nothing
    On Error GoTo 0
    XL2Txt = bOK
End Function

'------------------------------------------------------------
'this function strips the path from a path\file string
'------------------------------------------------------------
Function StripPath(rsFileName As String) As String
  On Error Resume Next
  Dim i As Integer

  For i = Len(rsFileName) To 1 Step -1
    If Mid(rsFileName, i, 1) = "\" Then
      Exit For
    End If
  Next

  StripPath = Mid(rsFileName, i + 1)

End Function


Attribute VB_Name = "basemacros"
Option Explicit
' ------------------------------
'
' Description:
'   Base Macro code for running a model through GAMS
'
'   There are six visual basic modules that are used in this application.
'   If you'd like to have a look at them, Select Macros from the Tool Menu, and
'   click on visual basic editor. In the project box click on modules and there they will be
'
'   The code which runs the transport application is in
'     trancode
'   Some base macros for starting up and managing the menu are in
'     basemacro
'   The code for running the GAMS job is included in
'     runGAMS, and GAMS_h
'   The code for managing file transfers between GAMS and Excel is in
'     utilities.
' ------------------------------

' Module Name: basemacros

' This code will not need to change much if you change applications

' Procedures/Functions:
'   Auto_Open           - setup environment on entering workbook
'   Auto_Close          - restore previous environment on exiting workbook
'   QuitApp             - forces execution of Auto_Close
'   RunApplication      - toggles edit mode to Run Application, ie without buttons, menu's
'   EditApplication     - toggles edit mode to Edit Application, ie with buttons, menu's
'   MapSheetGotoState   - go to specific state sheet from the main control form - MapSheet
'   GoToMapSheet        - go to the main control form - MapSheet
'
' See transport for model specific code.
' ------------------------------

' public variables to hold status of EXCEL environment when workbook opened.
'    Environment will be restored when workbook closed.
Public g_arToolbars(20) As String
Public g_varAppWindowState As Variant
Public g_bAppFormulaBar As Boolean
Public g_bAppStatusBar As Boolean


' instructions run automatically when workbook is opened
'   sets up environment when starting up workbook
Sub Auto_Open()
Attribute Auto_Open.VB_ProcData.VB_Invoke_Func = " \n14"
Dim nI As Integer
    Application.ScreenUpdating = False
    With Application
        .Caption = "Run GAMS from Excel spreadsheet "
        g_bAppFormulaBar = .DisplayFormulaBar
        g_bAppStatusBar = .DisplayStatusBar
        g_varAppWindowState = .WindowState
        .WindowState = xlNormal
        .Left = 37
        .Top = 22.75
        .Width = 683.75
        .Height = 542
    End With
    Call AppToggleEditMode(False)
    Application.ScreenUpdating = True
End Sub

' instructions run automatically when workbook closed.
'    this code resets Excel to the state it was in when this workbook opened.
Sub Auto_Close()
Attribute Auto_Close.VB_ProcData.VB_Invoke_Func = " \n14"
    Application.ScreenUpdating = False
    Call AppToggleEditMode(True)
    With Application
        .Caption = Empty
        .DisplayFormulaBar = g_bAppFormulaBar
        .DisplayStatusBar = g_bAppStatusBar
    End With
    Application.MenuBars(xlWorksheet).Reset
    Application.MenuBars(xlModule).Reset
    ActiveWorkbook.Save
    Application.ScreenUpdating = True
End Sub

' code called when Exit button clicked from main application control form.
'   forces execution of Auto_Close()
Sub QuitApp()
Attribute QuitApp.VB_ProcData.VB_Invoke_Func = " \n14"
    With ActiveWorkbook
        .RunAutoMacros xlAutoClose
        .Close
    End With
End Sub


' Runs Application
Sub RunApplication()
Attribute RunApplication.VB_ProcData.VB_Invoke_Func = " \n14"
    Application.ScreenUpdating = False
    Call AppToggleEditMode(False)
    Application.ScreenUpdating = True
End Sub


' Sets up to Edit Application, activating xl menus
Sub EditApplication()
Attribute EditApplication.VB_ProcData.VB_Invoke_Func = " \n14"
    Application.ScreenUpdating = False
    Call AppToggleEditMode(True)
    Application.ScreenUpdating = True
End Sub


' toggles between Edit and Run modes.  Run mode
'   hides buttons, and most all xl native menu options.
Sub AppToggleEditMode(bEdit As Boolean)
Attribute AppToggleEditMode.VB_ProcData.VB_Invoke_Func = " \n14"
Dim varMenu As Variant
Dim nI As Integer, nTBCnt As Integer

    ActiveWorkbook.Worksheets("MapSheet").Activate
    Application.DisplayFormulaBar = bEdit
    Application.DisplayStatusBar = bEdit
    With ActiveWindow
        .DisplayWorkbookTabs = bEdit
        .DisplayHorizontalScrollBar = bEdit
        .DisplayVerticalScrollBar = bEdit
        .WindowState = xlMaximized
    End With
    For nI = 1 To Toolbars.Count
        If nI <= UBound(g_arToolbars) Then
            If bEdit Then
                If g_arToolbars(nI) <> "" Then
                    Application.Toolbars(g_arToolbars(nI)).Visible = True
                End If
            Else
                If Toolbars(nI).Visible Then
                    g_arToolbars(nI) = Toolbars(nI).Name
                    Toolbars(nI).Visible = False
                Else
                    g_arToolbars(nI) = ""
                End If
            End If
        End If
    Next
    With Application
        With .MenuBars(xlWorksheet)
            If bEdit Then
                .Reset
            Else
                For Each varMenu In .Menus
                    varMenu.Delete
                Next
            End If
            .Menus.Add "&Edit GAMS Spreadsheet Link"
            With .Menus("Edit GAMS Spreadsheet Link")
                .MenuItems.Add "&Edit Application", "EditApplication"
                .MenuItems(1).Enabled = True
            End With
        End With
        If bEdit Then
            With .MenuBars(xlWorksheet)
                .Reset
                .Menus.Add "&Execute GAMS Spreadsheet Link"
                With .Menus("Execute GAMS Spreadsheet Link")
                    .MenuItems.Add "&Run Application", "RunApplication"
                    .MenuItems(1).Enabled = True
                End With
            End With
        End If
        With .MenuBars(xlModule)
            If bEdit Then
                .Reset
            Else
                For Each varMenu In .Menus
                    varMenu.Delete
                Next
            End If
            .Menus.Add "&Edit GAMS Spreadsheet Link"
            With .Menus("Edit GAMS Spreadsheet Link")
                .MenuItems.Add "&Edit Application", "EditApplication"
                .MenuItems(1).Enabled = True
            End With
        End With
    End With
End Sub



Attribute VB_Name = "ThisWorkbook"
Attribute VB_Base = "0{00020819-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet1"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet11"
Attribute VB_Base = "0{00020820-0000-0000-C000-000000000046}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Attribute VB_TemplateDerived = False
Attribute VB_Customizable = True

Attribute VB_Name = "Sheet3"
…