home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / Enigma_Cod19480211132005.psc / frmCreate.frm < prev    next >
Text File  |  2005-11-12  |  16KB  |  441 lines

  1. VERSION 5.00
  2. Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
  3. Begin VB.Form frmCreate 
  4.    BorderStyle     =   3  'Fixed Dialog
  5.    Caption         =   " Create Codebook"
  6.    ClientHeight    =   5625
  7.    ClientLeft      =   45
  8.    ClientTop       =   330
  9.    ClientWidth     =   7110
  10.    ControlBox      =   0   'False
  11.    Icon            =   "frmCreate.frx":0000
  12.    LinkTopic       =   "Form2"
  13.    MaxButton       =   0   'False
  14.    MinButton       =   0   'False
  15.    ScaleHeight     =   5625
  16.    ScaleWidth      =   7110
  17.    ShowInTaskbar   =   0   'False
  18.    StartUpPosition =   1  'CenterOwner
  19.    Begin VB.PictureBox picTextWidth 
  20.       Height          =   330
  21.       Left            =   720
  22.       ScaleHeight     =   270
  23.       ScaleWidth      =   270
  24.       TabIndex        =   15
  25.       TabStop         =   0   'False
  26.       Top             =   5160
  27.       Visible         =   0   'False
  28.       Width           =   330
  29.    End
  30.    Begin VB.CommandButton cmdCancel 
  31.       Cancel          =   -1  'True
  32.       Caption         =   "&Cancel"
  33.       Height          =   375
  34.       Left            =   5880
  35.       TabIndex        =   1
  36.       Top             =   5160
  37.       Width           =   1095
  38.    End
  39.    Begin VB.CommandButton cmdCreate 
  40.       Caption         =   "C&reate"
  41.       Default         =   -1  'True
  42.       Height          =   375
  43.       Left            =   4560
  44.       TabIndex        =   0
  45.       Top             =   5160
  46.       Width           =   1215
  47.    End
  48.    Begin VB.Frame frameModel 
  49.       Caption         =   "Enigma Model"
  50.       Height          =   2655
  51.       Left            =   120
  52.       TabIndex        =   9
  53.       Top             =   2400
  54.       Width           =   6855
  55.       Begin MSComctlLib.ProgressBar ProgressBar 
  56.          Height          =   255
  57.          Left            =   600
  58.          TabIndex        =   16
  59.          Top             =   2160
  60.          Visible         =   0   'False
  61.          Width           =   5415
  62.          _ExtentX        =   9551
  63.          _ExtentY        =   450
  64.          _Version        =   393216
  65.          Appearance      =   1
  66.          Max             =   12
  67.          Scrolling       =   1
  68.       End
  69.       Begin VB.ComboBox cmbModel 
  70.          Height          =   315
  71.          Left            =   600
  72.          Style           =   2  'Dropdown List
  73.          TabIndex        =   7
  74.          Top             =   480
  75.          Width           =   5415
  76.       End
  77.       Begin VB.Label lblDescription 
  78.          BackStyle       =   0  'Transparent
  79.          Height          =   1095
  80.          Left            =   600
  81.          TabIndex        =   10
  82.          Top             =   960
  83.          Width           =   5415
  84.       End
  85.    End
  86.    Begin VB.Frame frameCodebook 
  87.       Caption         =   "Codebook"
  88.       Height          =   2175
  89.       Left            =   120
  90.       TabIndex        =   8
  91.       Top             =   120
  92.       Width           =   6855
  93.       Begin VB.CommandButton cmdSelect 
  94.          Caption         =   "..."
  95.          Height          =   300
  96.          Left            =   6120
  97.          TabIndex        =   6
  98.          Top             =   1440
  99.          Width           =   375
  100.       End
  101.       Begin VB.TextBox txtYear 
  102.          Height          =   285
  103.          Left            =   3840
  104.          MaxLength       =   5
  105.          TabIndex        =   4
  106.          Text            =   "1900"
  107.          Top             =   960
  108.          Width           =   495
  109.       End
  110.       Begin VB.ComboBox cmbMonth 
  111.          Height          =   315
  112.          Left            =   1680
  113.          Style           =   2  'Dropdown List
  114.          TabIndex        =   3
  115.          Top             =   960
  116.          Width           =   1455
  117.       End
  118.       Begin VB.TextBox txtCodeName 
  119.          Height          =   285
  120.          Left            =   1680
  121.          TabIndex        =   2
  122.          Top             =   600
  123.          Width           =   2655
  124.       End
  125.       Begin VB.Label lblFolder 
  126.          BackColor       =   &H80000005&
  127.          BorderStyle     =   1  'Fixed Single
  128.          Height          =   300
  129.          Left            =   1680
  130.          TabIndex        =   5
  131.          Top             =   1440
  132.          Width           =   4335
  133.       End
  134.       Begin VB.Label Label 
  135.          Alignment       =   1  'Right Justify
  136.          BackStyle       =   0  'Transparent
  137.          Caption         =   "Save Folder"
  138.          Height          =   255
  139.          Index           =   4
  140.          Left            =   360
  141.          TabIndex        =   14
  142.          Top             =   1475
  143.          Width           =   1215
  144.       End
  145.       Begin VB.Label Label 
  146.          Alignment       =   1  'Right Justify
  147.          BackStyle       =   0  'Transparent
  148.          Caption         =   "Year"
  149.          Height          =   255
  150.          Index           =   3
  151.          Left            =   3000
  152.          TabIndex        =   13
  153.          Top             =   1020
  154.          Width           =   735
  155.       End
  156.       Begin VB.Label Label 
  157.          Alignment       =   1  'Right Justify
  158.          BackStyle       =   0  'Transparent
  159.          Caption         =   "Month"
  160.          Height          =   255
  161.          Index           =   2
  162.          Left            =   360
  163.          TabIndex        =   12
  164.          Top             =   1025
  165.          Width           =   1215
  166.       End
  167.       Begin VB.Label Label 
  168.          Alignment       =   1  'Right Justify
  169.          BackStyle       =   0  'Transparent
  170.          Caption         =   "Codename Net"
  171.          Height          =   255
  172.          Index           =   1
  173.          Left            =   240
  174.          TabIndex        =   11
  175.          Top             =   650
  176.          Width           =   1335
  177.       End
  178.    End
  179. End
  180. Attribute VB_Name = "frmCreate"
  181. Attribute VB_GlobalNameSpace = False
  182. Attribute VB_Creatable = False
  183. Attribute VB_PredeclaredId = True
  184. Attribute VB_Exposed = False
  185. Option Explicit
  186.  
  187. Private Sub Form_Activate()
  188. Me.txtCodeName.SetFocus
  189. End Sub
  190.  
  191. Private Sub txtCodeName_GotFocus()
  192. Me.txtCodeName.SelStart = 0
  193. Me.txtCodeName.SelLength = Len(Me.txtCodeName.Text)
  194. End Sub
  195.  
  196. Private Sub txtCodeName_KeyPress(KeyAscii As Integer)
  197. KeyAscii = Asc(UCase(Chr(KeyAscii)))
  198. End Sub
  199.  
  200. Private Sub txtYear_GotFocus()
  201. Me.txtYear.SelStart = 0
  202. Me.txtYear.SelLength = Len(Me.txtYear.Text)
  203. End Sub
  204.  
  205. Private Sub cmbModel_Click()
  206. Select Case Me.cmbModel.ListIndex + 1
  207. Case 1
  208.     '3-rotor Wehrmacht/Luftwaffe
  209.     Me.lblDescription.Caption = "This is the basic 3 rotor Enigma machine, used by Wehrmacht and Luftwaffe. Issued with a set of five rotors, from I to V, and two reflectors, B and C."
  210. Case 2
  211.     '3-rotor M3 Kriegsmarine
  212.     Me.lblDescription.Caption = "This is the 3 rotor Kriegsmarine M3 Enigma machine, also called Funkschlussel M. Issued with a set of eight rotors, from I to VIII, and two reflectors, B and C."
  213. Case 3
  214.     '4-rotor M4 Kriegsmarine
  215.     Me.lblDescription.Caption = "This is the 4 rotor Kriegsmarine M4 Enigma machine. Issued with a set of eight rotors, from I to VIII, two special thin rotors called Beta and Gamma (which don't advance), and two thin reflectors, B and C."
  216. Case 4
  217.     '4-rotor M4 Kriegsmarine (M3 and Wehrmacht/Luftwaffe Compatible)
  218.     Me.lblDescription.Caption = "This is the 4 rotor Kriegsmarine M4 Enigma machine in compatible configuration for communication with M3 or Wehrmacht/Luftwaffe models.. Uses only the first five rotors, from I to V, reflector B together with Beta rotor or reflector C together with Gamma rotor. Beta and Gamma must have ringsetting A and remain in startposition A, to be compatible."
  219. Case 5
  220.     '4-rotor M4 Kriegsmarine (M3 Compatible)
  221.     Me.lblDescription.Caption = "This is the 4 rotor Kriegsmarine M4 Enigma machine in compatible configuration for communication with M3 models. Uses all issued rotors, from I to VIII, reflector B together with Beta rotor or reflector C together with Gamma rotor. Beta and Gamma must have ringsetting A and remain in startposition A, to be compatible with M3 model."
  222. End Select
  223. End Sub
  224.  
  225. Private Sub cmdCancel_Click()
  226. Me.Hide
  227. End Sub
  228.  
  229. Private Sub cmdSelect_Click()
  230. 'select default folder
  231. Dim tmp As String
  232. tmp = Browse("Select default Folder to Save...")
  233. If tmp <> "" Then
  234.     gstrSaveFolder = tmp
  235.     Me.lblFolder.Caption = TrimPath(tmp, Me.lblFolder.Width)
  236.     End If
  237. End Sub
  238.  
  239. Private Sub cmdCreate_Click()
  240. 'create codebook
  241. Dim fileO As Integer
  242. Dim strFileName As String
  243. Dim k As Integer
  244. Dim j As Integer
  245. Dim i As Integer
  246. Dim sp As Integer
  247.  
  248. Dim tmp As String
  249. Dim intMonth As Integer
  250. Dim M4model As Boolean
  251. Dim Compatible As Boolean
  252. Dim intRotorChoice As Integer
  253. Dim intTotalSheets As Integer
  254. Dim strPairs As String
  255. Dim strCurrentMonth As String
  256. Dim intCurrentMonth As Integer
  257.  
  258. 'check codename
  259. tmp = Trim(Me.txtCodeName.Text)
  260. If tmp = "" Then
  261.     MsgBox "Please enter Codename Net.", vbCritical
  262.     Exit Sub
  263.     End If
  264. If InStr(1, tmp, "\") Or InStr(1, tmp, "/") Or InStr(1, tmp, ":") Or InStr(1, tmp, "*") Or InStr(1, tmp, "?") Or _
  265.     InStr(1, tmp, Chr(34)) Or InStr(1, tmp, "<") Or InStr(1, tmp, ">") Or InStr(1, tmp, "|") Then
  266.     MsgBox "Following characters are not allowed in Codename: \ / : * ? " & Chr(34) & " < > |", vbCritical
  267.     Exit Sub
  268.     End If
  269.  
  270. 'check year
  271. If Val(Me.txtYear.Text) < 1000 Or Val(Me.txtYear.Text) > 2999 Then
  272.     MsgBox "Please enter a valid year.", vbCritical
  273.     Exit Sub
  274.     End If
  275.  
  276. Screen.MousePointer = 11
  277. Me.frameCodebook.Enabled = False
  278. Me.frameModel.Enabled = False
  279. Me.ProgressBar.Value = 0
  280. gstrCodeBook = ""
  281.  
  282. 'select model
  283. Select Case Me.cmbModel.ListIndex + 1
  284. Case 1
  285.     '3-rotor Wehrmacht/Luftwaffe
  286.     M4model = False
  287.     Compatible = False
  288.     intRotorChoice = 5
  289. Case 2
  290.     '3-rotor M3 Kriegsmarine
  291.     M4model = False
  292.     Compatible = False
  293.     intRotorChoice = 8
  294. Case 3
  295.     '4-rotor M4 Kriegsmarine
  296.     M4model = True
  297.     Compatible = False
  298.     intRotorChoice = 8
  299. Case 4
  300.     '4-rotor M4 Kriegsmarine (M3 and Wehrmacht/Luftwaffe Compatible)
  301.     M4model = True
  302.     Compatible = True
  303.     intRotorChoice = 5
  304. Case 5
  305.     '4-rotor M4 Kriegsmarine (M3 Compatible)
  306.     M4model = True
  307.     Compatible = True
  308.     intRotorChoice = 8
  309. End Select
  310.  
  311. 'selec 1 sheet/whole year
  312. intMonth = Me.cmbMonth.ListIndex
  313. If intMonth <> 0 Then
  314.     intTotalSheets = 1
  315.     Else
  316.     intTotalSheets = 12
  317.     Me.ProgressBar.Visible = True
  318.     End If
  319.  
  320. Randomize
  321. 'compose codebook sheet(s)
  322. For i = 1 To intTotalSheets
  323.     Me.ProgressBar.Value = i
  324.     If intMonth <> 0 Then
  325.         'one sheet
  326.         strCurrentMonth = gstrMonthName(intMonth)
  327.         intCurrentMonth = intMonth
  328.             tmp = Trim(Str(intMonth)): If Len(tmp) = 1 Then tmp = "0" & tmp
  329.         strFileName = Me.txtCodeName.Text & " " & Me.txtYear.Text & " " & tmp & ".txt"
  330.         Else
  331.         '12 sheets
  332.         strCurrentMonth = gstrMonthName(i)
  333.         intCurrentMonth = i
  334.         tmp = Trim(Str(i)): If Len(tmp) = 1 Then tmp = "0" & tmp
  335.         strFileName = Me.txtCodeName.Text & " " & Me.txtYear.Text & " " & tmp & ".txt"
  336.         End If
  337.     
  338.     gstrCodeBook = vbCrLf
  339.     If M4model Then gstrCodeBook = gstrCodeBook & "   "
  340.     gstrCodeBook = gstrCodeBook & " GEHEIM!                SONDER-MASCHINENSCHLUSSEL: "
  341.     tmp = Left(Trim(Me.txtCodeName.Text), 15)
  342.     gstrCodeBook = gstrCodeBook & tmp
  343.     If Not M4model Then
  344.         gstrCodeBook = gstrCodeBook & Space(37 - Len(tmp) - Len(strCurrentMonth)) & strCurrentMonth & " " & Me.txtYear & vbCrLf & vbCrLf
  345.         Else
  346.         gstrCodeBook = gstrCodeBook & Space(29 - Len(tmp) - Len(strCurrentMonth)) & strCurrentMonth & " " & Me.txtYear & vbCrLf & vbCrLf
  347.         End If
  348.     
  349.     'set codesheet header
  350.     If Not M4model Then
  351.         gstrCodeBook = gstrCodeBook & " --------------------------------------------------------------------------------------------" & vbCrLf
  352.         gstrCodeBook = gstrCodeBook & " |Tag |UKW|     Walzenlage   |Ringstellung|      Steckerverbindungen      |   Kenngruppen   |" & vbCrLf
  353.         gstrCodeBook = gstrCodeBook & " --------------------------------------------------------------------------------------------" & vbCrLf
  354.         Else
  355.         gstrCodeBook = gstrCodeBook & "    ------------------------------------------------------------------------------------" & vbCrLf
  356.         gstrCodeBook = gstrCodeBook & "    |Tag |UKW|        Walzenlage       | Ringstellung  |      Steckerverbindungen      |" & vbCrLf
  357.         gstrCodeBook = gstrCodeBook & "    ------------------------------------------------------------------------------------" & vbCrLf
  358.         End If
  359.         
  360.     'loop thourgh all days of a month - reverse order!!!
  361.     For k = gintDaysInMonth(intCurrentMonth) To 1 Step -1
  362.         tmp = Trim(Str(k))
  363.         If Len(tmp) = 1 Then tmp = "0" & tmp
  364.         If M4model Then gstrCodeBook = gstrCodeBook & "   "
  365.         gstrCodeBook = gstrCodeBook & " | " & tmp & " | "
  366.         'get reflectors and 4th rotor
  367.         gstrCodeBook = gstrCodeBook & GetRefAndFourth(M4model, Compatible)
  368.         'get normal rotors
  369.         gstrCodeBook = gstrCodeBook & "  " & GetRotors(intRotorChoice)
  370.         'get rings
  371.         gstrCodeBook = gstrCodeBook & " |  " & GetRings(M4model, Compatible) & " | "
  372.         'get plugs
  373.         strPairs = ""
  374.         For j = 1 To 10
  375.             tmp = GetNewPair(strPairs)
  376.             Call InsertPair(tmp, strPairs)
  377.         Next
  378.         gstrCodeBook = gstrCodeBook & strPairs & "|"
  379.        'get kenngruppen
  380.         If Not M4model Then
  381.             gstrCodeBook = gstrCodeBook & " " & GetKennGruppen & "|" & vbCrLf
  382.             Else
  383.             gstrCodeBook = gstrCodeBook & vbCrLf
  384.             End If
  385.     Next k
  386.     If Not M4model Then
  387.         gstrCodeBook = gstrCodeBook & " --------------------------------------------------------------------------------------------" & vbCrLf
  388.         Else
  389.         gstrCodeBook = gstrCodeBook & "    ------------------------------------------------------------------------------------" & vbCrLf
  390.         End If
  391.     'add remarks for compatible models
  392.     If Me.cmbModel.ListIndex + 1 = 4 Then
  393.         gstrCodeBook = gstrCodeBook & "    ACHTUNG! UKW B mit Beta  auf startposition A = M3 oder Wehrmacht/Luftwaffe mit UKW B" & vbCrLf
  394.         gstrCodeBook = gstrCodeBook & "             UKW C mit Gamma auf startposition A = M3 oder Wehrmacht/Luftwaffe mit UKW C" & vbCrLf
  395.     ElseIf Me.cmbModel.ListIndex + 1 = 5 Then
  396.         gstrCodeBook = gstrCodeBook & "    ACHTUNG! UKW B mit Beta  auf startposition A = M3 mit UKW B" & vbCrLf
  397.         gstrCodeBook = gstrCodeBook & "             UKW C mit Gamma auf startposition A = M3 mit UKW C" & vbCrLf
  398.         End If
  399.     
  400.     'save codebook
  401.     strFileName = gstrSaveFolder & strFileName
  402.     On Error GoTo errHandler
  403.     Screen.MousePointer = 11
  404.     fileO = FreeFile
  405.     Open strFileName For Output As #fileO
  406.     Print #fileO, gstrCodeBook
  407.     Close #fileO
  408.  
  409. Next i
  410.  
  411. Me.frameCodebook.Enabled = True
  412. Me.frameModel.Enabled = True
  413. Me.ProgressBar.Value = 0
  414. Me.ProgressBar.Visible = False
  415. Screen.MousePointer = 0
  416. Me.Hide
  417.  
  418. If intMonth <> 0 Then
  419.     frmMain.txtCodeBook.Text = gstrCodeBook
  420.     Else
  421.     frmMain.txtCodeBook.Text = vbCrLf & " Succesfully created 12 codesheets named " & Me.txtCodeName.Text & vbCrLf & vbCrLf & " The codesheets are saved in " & gstrSaveFolder
  422.     End If
  423.     
  424. If gblnPrinterPresent = True And gstrCodeBook <> "" Then
  425.     frmMain.mnuPrint.Enabled = True
  426.     Else
  427.     frmMain.mnuPrint.Enabled = True
  428.     End If
  429.  
  430. Exit Sub
  431. errHandler:
  432. If Err Then MsgBox "Failed saving codesheet." & vbCrLf & vbCrLf & "Error: " & Err.Description, vbCritical
  433. frmMain.txtCodeBook.Text = vbCrLf & " Failed creating codesheets!"
  434. Screen.MousePointer = 0
  435. Me.frameCodebook.Enabled = True
  436. Me.frameModel.Enabled = True
  437. Me.ProgressBar.Value = 0
  438. Me.ProgressBar.Visible = False
  439. End Sub
  440.  
  441.