home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 4_2005-2006.ISO / data / Zips / Dilbert_Co2110674242008.psc / Dilbert / frmMain.frm < prev    next >
Text File  |  2008-04-24  |  8KB  |  237 lines
  1. VERSION 5.00
  2. Object = "{48E59290-9880-11CF-9754-00AA00C00908}#1.0#0"; "MSINET.OCX"
  3. Object = "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}#1.1#0"; "ieframe.dll"
  4. Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
  5. Begin VB.Form frmMain 
  6.    BackColor       =   &H00663300&
  7.    BorderStyle     =   1  'Fixed Single
  8.    Caption         =   "Dilbert Comic Reader"
  9.    ClientHeight    =   4980
  10.    ClientLeft      =   45
  11.    ClientTop       =   435
  12.    ClientWidth     =   9720
  13.    Icon            =   "frmMain.frx":0000
  14.    LinkTopic       =   "Form1"
  15.    MaxButton       =   0   'False
  16.    ScaleHeight     =   4980
  17.    ScaleWidth      =   9720
  18.    StartUpPosition =   2  'CenterScreen
  19.    Begin VB.CommandButton cmdDesktop 
  20.       Caption         =   "Set as Wallpaper"
  21.       Height          =   300
  22.       Left            =   8160
  23.       TabIndex        =   5
  24.       Top             =   120
  25.       Width           =   1455
  26.    End
  27.    Begin MSComCtl2.DTPicker dtpArchive 
  28.       Height          =   300
  29.       Left            =   8160
  30.       TabIndex        =   4
  31.       Top             =   480
  32.       Width           =   1455
  33.       _ExtentX        =   2566
  34.       _ExtentY        =   529
  35.       _Version        =   393216
  36.       Format          =   16515073
  37.       CurrentDate     =   39562
  38.    End
  39.    Begin VB.PictureBox picTemp 
  40.       Height          =   615
  41.       Left            =   4320
  42.       ScaleHeight     =   555
  43.       ScaleWidth      =   1155
  44.       TabIndex        =   3
  45.       Top             =   120
  46.       Visible         =   0   'False
  47.       Width           =   1215
  48.    End
  49.    Begin SHDocVwCtl.WebBrowser wbrDilbert 
  50.       Height          =   4095
  51.       Left            =   0
  52.       TabIndex        =   0
  53.       Top             =   885
  54.       Width           =   9720
  55.       ExtentX         =   17145
  56.       ExtentY         =   7223
  57.       ViewMode        =   0
  58.       Offline         =   0
  59.       Silent          =   0
  60.       RegisterAsBrowser=   0
  61.       RegisterAsDropTarget=   1
  62.       AutoArrange     =   0   'False
  63.       NoClientEdge    =   0   'False
  64.       AlignLeft       =   0   'False
  65.       NoWebView       =   0   'False
  66.       HideFileNames   =   0   'False
  67.       SingleClick     =   0   'False
  68.       SingleSelection =   0   'False
  69.       NoFolders       =   0   'False
  70.       Transparent     =   0   'False
  71.       ViewID          =   "{0057D0E0-3573-11CF-AE69-08002B2E1262}"
  72.       Location        =   "http:///"
  73.    End
  74.    Begin InetCtlsObjects.Inet InetDilbert 
  75.       Left            =   9000
  76.       Top             =   120
  77.       _ExtentX        =   1005
  78.       _ExtentY        =   1005
  79.       _Version        =   393216
  80.    End
  81.    Begin VB.PictureBox Picture1 
  82.       AutoSize        =   -1  'True
  83.       BorderStyle     =   0  'None
  84.       Height          =   885
  85.       Left            =   0
  86.       Picture         =   "frmMain.frx":08CA
  87.       ScaleHeight     =   885
  88.       ScaleWidth      =   3360
  89.       TabIndex        =   1
  90.       Top             =   0
  91.       Width           =   3360
  92.    End
  93.    Begin VB.Label lblChoose 
  94.       BackStyle       =   0  'Transparent
  95.       Caption         =   "Choose Date:"
  96.       ForeColor       =   &H00FFFFFF&
  97.       Height          =   255
  98.       Left            =   7080
  99.       TabIndex        =   2
  100.       Top             =   600
  101.       Width           =   1095
  102.    End
  103. End
  104. Attribute VB_Name = "frmMain"
  105. Attribute VB_GlobalNameSpace = False
  106. Attribute VB_Creatable = False
  107. Attribute VB_PredeclaredId = True
  108. Attribute VB_Exposed = False
  109.     Dim dtDate As String
  110.     Dim iPos As Long
  111.     Dim WebText As String
  112.     Dim WebURL As String
  113.     Dim sDay As String
  114.  
  115.     Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
  116.     Private Const SPI_SETDESKWALLPAPER = 20
  117.     Private Const SPIF_SENDWININICHANGE = &H2
  118.     Private Const SPIF_UPDATEINIFILE = &H1
  119.  
  120. Private Sub dtpArchive_Change()
  121.     Call dtpArchive_Click
  122. End Sub
  123.  
  124. Private Sub dtpArchive_Click()
  125. On Error GoTo Errhandler
  126.     Screen.MousePointer = vbHourglass
  127.     dtDate = Format(dtpArchive.Value, "yyyy-mm-dd")
  128.     WebURL = "http://dilbert.com/strips/comic/" & dtDate & "/"
  129.     Call GetHTML(WebURL)
  130.  
  131.     iPos = InStr(WebText, "/dyn/str_strip/")
  132.     If iPos = 0 Then
  133.         Screen.MousePointer = vbNormal
  134.         MsgBox "There is no comic strip for the date selected!", vbInformation + vbOKOnly, "No Comic Strip"
  135.         Exit Sub
  136.     End If
  137.     
  138.     Dim iPos2 As Integer
  139.     WebText = "http://dilbert.com" & Mid(WebText, iPos, 100)
  140.     iPos2 = InStr(WebText, ".gif")
  141.     If iPos2 <> 0 Then
  142.         WebText = Left(WebText, iPos2 + 3)
  143.     Else
  144.         iPos2 = InStr(WebText, ".jpg")
  145.         WebText = Left(WebText, iPos2 + 3)
  146.     End If
  147.  
  148.     Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2, 8800, 4500
  149.     
  150.     wbrDilbert.Navigate WebText
  151.     Call SaveDilbertPicture
  152.     Screen.MousePointer = vbNormal
  153.     Exit Sub
  154.  
  155. Errhandler:
  156.     Screen.MousePointer = vbNormal
  157.     MsgBox Err.Description, vbInformation + vbOKOnly, "Load Error"
  158. End Sub
  159.  
  160. Private Sub Form_Load()
  161. On Error GoTo Errhandler
  162.     
  163.     dtpArchive.Value = Date
  164.     
  165.     dtDate = Format(Date, "yyyy-mm-dd")
  166.     WebURL = "http://dilbert.com/strips/comic/" & dtDate & "/"
  167.     Call GetHTML(WebURL)
  168.  
  169.     iPos = InStr(WebText, "/dyn/str_strip/")
  170.     If iPos = 0 Then
  171.         Screen.MousePointer = vbNormal
  172.         MsgBox "There is no comic strip for the date selected!", vbInformation + vbOKOnly, "No Comic Strip"
  173.         Exit Sub
  174.     End If
  175.     
  176.     Dim iPos2 As Integer
  177.     WebText = "http://dilbert.com/" & Mid(WebText, iPos, 100)
  178.     iPos2 = InStr(WebText, ".gif")
  179.     If iPos2 <> 0 Then
  180.         WebText = Left(WebText, iPos2 + 3)
  181.     Else
  182.         iPos2 = InStr(WebText, ".jpg")
  183.         WebText = Left(WebText, iPos2 + 3)
  184.     End If
  185.        
  186.     Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2, 8800, 4500
  187.         
  188.     wbrDilbert.Navigate WebText
  189.     Call SaveDilbertPicture
  190.     Exit Sub
  191.  
  192. Errhandler:
  193.     MsgBox Err.Description, vbInformation + vbOKOnly, "Load Error"
  194. End Sub
  195.  
  196. Private Function GetHTML(url$) As String
  197.     Dim response$
  198.     Dim vData As Variant
  199.     
  200.     InetDilbert.Cancel
  201.     response = InetDilbert.OpenURL(url)
  202.     If response <> "" Then
  203.         Do
  204.             vData = InetDilbert.GetChunk(1024, icString)
  205.             DoEvents
  206.             If Len(vData) Then
  207.                 response = response & vData
  208.             End If
  209.         Loop While Len(vData)
  210.     End If
  211.     WebText = response
  212. End Function
  213.  
  214. Private Sub cmdDesktop_Click()
  215.     Dim WallPaper As Long
  216.     SavePicture picTemp.Picture, "c:\dilbert desktop.bmp"
  217.     WallPaper = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, "c:\dilbert desktop.bmp", SPIF_SENDWININICHANGE Or SPIF_UPDATEINIFILE)   'Change the wallpaper.
  218. End Sub
  219.  
  220. Private Sub SaveDilbertPicture()
  221.     Dim Dilbert() As Byte
  222.     Dilbert() = InetDilbert.OpenURL(WebText, icByteArray) ' Download picture.
  223.     Open "C:\dilbert.gif" For Binary Access Write As #1 ' Save the file.
  224.     Put #1, , Dilbert()
  225.     Close #1
  226.  
  227.     picTemp.Picture = LoadPicture("c:\dilbert.gif") 'Reload it To PictureBox
  228.     SavePicture picTemp.Picture, "c:\dilbert.bmp" 'Converted To bmp..
  229.     Kill "c:\dilbert.gif"
  230. End Sub
  231.  
  232. Private Sub Form_Resize()
  233.     cmdDesktop.Left = Me.Width - 1650
  234.     dtpArchive.Left = Me.Width - 1650
  235.     lblChoose.Left = Me.Width - 2730
  236. End Sub
  237.