AntiGuide: Turgot



PagePrincipale :: DerniersChangements :: ParametresUtilisateur :: Vous êtes 216.73.216.115 :: Signaler un abus :: le: 20250624 10:59:59
GAFFE c'est du VisualBasic 6.0 plus trop disponible .

scène du crime:
lire: http://fr.wikipedia.org/wiki/Plan_de_Turgot
solution: http://commons.wikimedia.org/wiki/Turgot_map_of_Paris_%28Kyoto_University_Library%29
ne s'ouvre pas en MsPaint ni la visionneuse de Windows Explorer, mais Ok pour IrfanView

d'autres plans plus anciens selon http://www.skyscrapercity.com/showthread.php?t=471396

lien mort: un zoom (trouver si mobile): http://s3.amazonaws.com/data.tumblr.com/tumblr_lvrb5qZR9P1r7g1jxo1_1280.jpg?AWSAccessKeyId=AKIAJ6IHWSU3BX3X7X3Q&Expires=1332835650&Signature=rQjrKh9wKkW6lo6zOfNsewqO9lc%3D
pour iPhone: http://www.ifreeware.net/download-historic-map-of-paris-turgot-1734.html
programme pour reconstruire le plan de Turgot à partir de sa publication morcelée (par un site japonais aujourd'hui disparu)
capturé ici : http://antiguide.free.fr/images/turgot/Turgot/index.html
(ajustez la fenêtre du navigateur, pour avoir quatre vignettes en largeur)

GAFFE: demande un max de mémoire vive!

le programme save4 est fait pour assembler deux ou quatre "morceaux"

(GAFFE: le texte de présentation dans la page ci dessous date d'une ancienne version)

mode d'emploi save4 -? (version historique de 2006)
1
ce que cet aide ne dit pas:

installé sur DellE520
bilan provisoire (version 2006)

20110115; GRRRRRRRRRRRRRRRRRRR,
retourné sur la machine source (william)
exécuté en interactif,
il apparait bien un bug qui disparait si je repasse autoredraw à false (trois fois) avant l'écriture
ceci dit le bug se produirait aussi au changement de fenêtre
trouvé deux exe save4 et save4w, pas trace de différence
mais impossible de créer .exe (il est ombré!)
bypass: utiliser l'assistant déploiement de projet!
ok en H
voir le nom de la form ?
design (bug) version 2011
feuille de route
- faudrait passer en .net!
source

développé en VB6 : VisualBAsic datant du siècle/millénaire dernier avant l'apparition de .NET et VisualStudio (utilisé pou le projet Ishtar ou l'Entd2007?
(peut-être survivant sur DellD600, Windows XP)

save4.frm
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1 
   Appearance      =   0  'Flat
   BackColor       =   &H80000005&
   Caption         =   "Form1"
   ClientHeight    =   5760
   ClientLeft      =   3150
   ClientTop       =   2940
   ClientWidth     =   7560
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   384
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   504
   Begin VB.HScrollBar hsb 
      Height          =   255
      Left            =   0
      TabIndex        =   9
      Top             =   5280
      Width           =   6975
   End
   Begin VB.VScrollBar vsb 
      Height          =   5175
      Left            =   7200
      TabIndex        =   8
      Top             =   0
      Width           =   255
   End
   Begin VB.PictureBox outerNW 
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   1815
      Left            =   240
      ScaleHeight     =   121
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   169
      TabIndex        =   6
      Top             =   240
      Width           =   2535
      Begin VB.PictureBox innerNw 
         Appearance      =   0  'Flat
         AutoRedraw      =   -1  'True
         AutoSize        =   -1  'True
         BackColor       =   &H80000005&
         BorderStyle     =   0  'None
         ForeColor       =   &H80000008&
         Height          =   240
         Left            =   -120
         Picture         =   "save4.frx":0000
         ScaleHeight     =   16
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   16
         TabIndex        =   7
         Top             =   0
         Width           =   240
      End
   End
   Begin VB.Timer Timer1 
      Interval        =   3000
      Left            =   2760
      Top             =   4680
   End
   Begin MSComDlg.CommonDialog CommonDialog1 
      Left            =   6120
      Top             =   960
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.PictureBox outerSE 
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   2055
      Left            =   3600
      ScaleHeight     =   137
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   161
      TabIndex        =   4
      Top             =   3120
      Width           =   2415
      Begin VB.PictureBox innerSE 
         Appearance      =   0  'Flat
         AutoRedraw      =   -1  'True
         AutoSize        =   -1  'True
         BackColor       =   &H80000005&
         BorderStyle     =   0  'None
         ForeColor       =   &H80000008&
         Height          =   240
         Left            =   -720
         Picture         =   "save4.frx":014A
         ScaleHeight     =   16
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   16
         TabIndex        =   5
         Top             =   -360
         Width           =   240
      End
   End
   Begin VB.PictureBox OuterSW 
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   2415
      Left            =   240
      ScaleHeight     =   161
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   153
      TabIndex        =   2
      Top             =   2640
      Width           =   2295
      Begin VB.PictureBox InnerSW 
         Appearance      =   0  'Flat
         AutoRedraw      =   -1  'True
         AutoSize        =   -1  'True
         BackColor       =   &H80000005&
         BorderStyle     =   0  'None
         ForeColor       =   &H80000008&
         Height          =   240
         Left            =   -240
         Picture         =   "save4.frx":0294
         ScaleHeight     =   16
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   16
         TabIndex        =   3
         Top             =   -240
         Width           =   240
      End
   End
   Begin VB.PictureBox OuterNE 
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   2415
      Left            =   4080
      ScaleHeight     =   161
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   193
      TabIndex        =   0
      Top             =   360
      Width           =   2895
      Begin VB.PictureBox InnerNE 
         Appearance      =   0  'Flat
         AutoRedraw      =   -1  'True
         AutoSize        =   -1  'True
         BackColor       =   &H80000005&
         BorderStyle     =   0  'None
         DrawStyle       =   1  'Dash
         ForeColor       =   &H80000008&
         Height          =   240
         Left            =   -960
         Picture         =   "save4.frx":03DE
         ScaleHeight     =   16
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   16
         TabIndex        =   1
         Top             =   120
         Width           =   240
      End
   End
   Begin VB.Menu menu_File 
      Caption         =   "File"
      Begin VB.Menu menuCharger 
         Caption         =   "Charger"
         Begin VB.Menu menuNW 
            Caption         =   "NW"
         End
         Begin VB.Menu menuNE 
            Caption         =   "NE"
         End
         Begin VB.Menu menuSW 
            Caption         =   "SW"
         End
         Begin VB.Menu menuSE 
            Caption         =   "SE"
         End
      End
      Begin VB.Menu menuSave 
         Caption         =   "Save to BMP 24 bits"
         Visible         =   0   'False
      End
      Begin VB.Menu menuSaveAs 
         Caption         =   "Save as "
      End
      Begin VB.Menu menu_Quit 
         Caption         =   "Quit"
      End
   End
   Begin VB.Menu menuOptions 
      Caption         =   "Options"
      Begin VB.Menu menucadre 
         Caption         =   "montrer les cadres"
      End
      Begin VB.Menu menuAutoSave 
         Caption         =   "AutoSave"
      End
      Begin VB.Menu menuAutoQuit 
         Caption         =   "AutoQuit"
      End
      Begin VB.Menu menuStartPaint 
         Caption         =   "Voir cible par MsPaint après sauvegarde"
      End
      Begin VB.Menu menuclip 
         Caption         =   "Fixer (Clip pou tous) "
      End
   End
   Begin VB.Menu PI 
      Caption         =   "?"
      Begin VB.Menu menuAide 
         Caption         =   "Aide"
      End
      Begin VB.Menu menuApropos 
         Caption         =   "A propos"
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'^$$$ en mode <> 4 position sc a 100
' de doresize
 Const Creele = "20060430"
 Dim dpi As Long
 Dim nw_w As Integer, nw_h As Integer
 Dim ne_w As Integer, ne_h As Integer
 Dim sw_w As Integer, sw_h As Integer
 Dim se_w As Integer, se_h As Integer
'
' Load
  Dim param As String
  Dim valeur As String

Dim universal_clip As Long
Dim asc_nb As Integer
Dim bac_w As Long, bac_h As Long
Dim cadre As Integer
Dim mode As String ' H V 4
Dim saved As Boolean
Dim NW As String, NE As String, SW As String, SE As String
Dim g As Boolean, h As Boolean
Dim outparam As String
Dim targetdone As Boolean

' oe de dosave avant éclatement
 Dim nbx As Long, ibx As Single
 Dim nby As Long, iby As Single
 Dim rgb As Long
 Dim istarty As Long
 ' plus grand cadre ccontenu l'image
 ' plus haut en haut ph est le nb de pixel au dessus de la ligne mediane
 Dim ph As Long
 Dim NWh As Long, NEh As Long
 Dim pb As Long ' au dessous
 Dim SWb As Long, SEb As Long
  Dim pg As Long
  Dim NWg As Long, SWg As Long
  Dim pd As Long
  Dim NEd As Long, SEd As Long


Private m_Vvalue(4) As Single
Private m_VMin(4) As Single
Private m_VMax(4) As Single
Private m_VLargeChange As Single
Private m_VSmallChange As Single

Private m_Hvalue(4) As Single
Private m_HMin(4) As Single
Private m_HMax(4) As Single
Private m_HLargeChange As Single
Private m_HSmallChange As Single
' a faire apress chargement
' $$$$$$$$$$$$$ min max sans cadre
Private Sub SetScrollingValues()
    ' Set scroll values.
    cadre = 0
    If menucadre.Checked Then cadre = 2
    m_VMax(1) = -1
    m_VMin(1) = outerNW.ScaleHeight - innerNw.Height + cadre
    m_VMax(2) = -1
    m_VMin(2) = OuterNE.ScaleHeight - InnerNE.Height + cadre
    m_VMax(3) = -1
    m_VMin(3) = OuterSW.ScaleHeight - InnerSW.Height + cadre
    m_VMax(4) = -1
    m_VMin(4) = outerSE.ScaleHeight - innerSE.Height + cadre
    m_VLargeChange = 20 'outerNW.ScaleY(20, vbPixels, outerNW.ScaleMode)
    m_VSmallChange = 1 'outerNW.ScaleY(1, vbPixels, outerNW.ScaleMode)

    m_HMax(1) = -1
    m_HMin(1) = outerNW.ScaleWidth - innerNw.Width + cadre
    m_HMax(2) = -1
    m_HMin(2) = OuterNE.ScaleWidth - InnerNE.Width + cadre
    m_HMax(3) = -1
    m_HMin(3) = OuterSW.ScaleWidth - InnerSW.Width + cadre
    m_HMax(4) = -1
    m_HMin(4) = outerSE.ScaleWidth - innerSE.Width + cadre
    m_HLargeChange = outerNW.ScaleX(20, vbPixels, outerNW.ScaleMode)
    m_HSmallChange = outerNW.ScaleX(1, vbPixels, outerNW.ScaleMode)
End Sub

Private Sub Form_KeyDown(keycode As Integer, shift As Integer)
' choose where
'MsgBox "shift=" & shift & " code=" & keycode
If (shift And 6) = 0 Then ' aucun shift
          If g Then
             If h Then
            sc 1, shift, keycode, outerNW, innerNw
              Else
            sc 3, shift, keycode, OuterSW, InnerSW
              End If
            Else
            If h Then
            sc 2, shift, keycode, OuterNE, InnerNE
            Else
            sc 4, shift, keycode, outerSE, innerSE
            End If
            
          End If
      End If
      
' $$$$$$$$$$$$$$ limiter les paires si en bout de course
If (shift And 4) <> 0 Then 'GoTo 1 ' droit et gauche
          If h Then
            sc 1, shift, keycode, outerNW, innerNw
            sc 2, shift, keycode, OuterNE, InnerNE
            Else
            sc 4, shift, keycode, outerSE, innerSE
            sc 3, shift, keycode, OuterSW, InnerSW
          End If
          End If
          
If (shift And 2) <> 0 Then ' 2 ' haut et bas
          If g Then
            sc 1, shift, keycode, outerNW, innerNw
            sc 3, shift, keycode, OuterSW, InnerSW
            Else
            sc 2, shift, keycode, OuterNE, InnerNE
            sc 4, shift, keycode, outerSE, innerSE
          End If
End If
End Sub
   
   Private Sub sc(p1a4 As Integer, shift As Integer, keycode As Integer, ByRef outer As PictureBox, ByRef inner As PictureBox)
   ' $$$$$$$$$$$$$$$$ qaund on bouge conserver la position in/out
' MsgBox shift
   saved = False
   Select Case keycode
        Case vbKeyDown
            If shift And vbShiftMask Then
                m_Vvalue(p1a4) = m_Vvalue(p1a4) - m_VLargeChange
            Else
                m_Vvalue(p1a4) = m_Vvalue(p1a4) - m_VSmallChange
            End If
            If m_Vvalue(p1a4) < m_VMin(p1a4) Then m_Vvalue(p1a4) = m_VMin(p1a4)
            inner.Top = m_Vvalue(p1a4)
        Case vbKeyUp
            If shift And vbShiftMask Then
                m_Vvalue(p1a4) = m_Vvalue(p1a4) + m_VLargeChange
            Else
                m_Vvalue(p1a4) = m_Vvalue(p1a4) + m_VSmallChange
            End If
            If m_Vvalue(p1a4) > m_VMax(p1a4) Then m_Vvalue(p1a4) = m_VMax(p1a4)
            inner.Top = m_Vvalue(p1a4)
        Case vbKeyLeft
            If shift And vbShiftMask Then
                m_Hvalue(p1a4) = m_Hvalue(p1a4) + m_HLargeChange
            Else
                m_Hvalue(p1a4) = m_Hvalue(p1a4) + m_HSmallChange
            End If
            If m_Hvalue(p1a4) > m_HMax(p1a4) Then m_Hvalue(p1a4) = m_HMax(p1a4)
            inner.Left = m_Hvalue(p1a4)
        Case vbKeyRight
            If shift And vbShiftMask Then
                m_Hvalue(p1a4) = m_Hvalue(p1a4) - m_HLargeChange
            Else
                m_Hvalue(p1a4) = m_Hvalue(p1a4) - m_HSmallChange
            End If
            If m_Hvalue(p1a4) < m_HMin(p1a4) Then m_Hvalue(p1a4) = m_HMin(p1a4)
            inner.Left = m_Hvalue(p1a4)
    Case Else
     Exit Sub ' sans dodim
    End Select
    
    
    dodim
End Sub
Private Sub center()
 targetdone = True
End Sub
Private Sub chknoval()
  If valeur <> "" Then
    MsgBox " le paramètre " & param & " ne doit pas être suivi d'une valeur"
    End
    End If
    
End Sub
Private Sub Form_Load()
  dpi = 450
  Dim u As String, c As String
  c = Trim(Command) & " "
  
    universal_clip = 0
      menuclip.Caption = "Fixer le nb de pixel à supprimer (actuel:" & universal_clip & ")"
 
Dim blanc As Integer
Dim deuxpoints As Integer

While Len(c) > 0
  blanc = InStr(c, " ")
  If blanc = 0 Then blanc = Len(c) + 1
  deuxpoints = InStr(c, ":")
  If deuxpoints = 0 Then deuxpoints = Len(c) + 1
  
  If Left(c, 1) <> "-" Then
    MsgBox "Erreur: le paramètre doit commencer par -"
    End
    End If
    
  'If (blanc > 0) And (blanc < deuxpoints) Then
  '   MsgBox "erreur deparametre (manque :)"
  '   End
  '   End If
     
  Dim lparam As Integer
  lparam = deuxpoints
  If lparam > blanc Then lparam = blanc
  param = Left(c, lparam - 1)
  
  
  If (lparam <> blanc) And (deuxpoints < Len(c)) Then
   ' ? un "
      If Mid$(c, deuxpoints + 1, 1) = """" Then
         blanc = InStr(deuxpoints + 2, c, """")
         If blanc = 0 Then
            MsgBox "unclosed "" in parameter param"
            End
            End If
          valeur = Mid$(c, deuxpoints + 2, blanc - deuxpoints - 2)
        Else
          valeur = Mid$(c, deuxpoints + 1, blanc - deuxpoints - 1)
        End If
      Else
      valeur = ""
      End If
      c = Trim(Mid$(c, blanc + 1))
      
  ' faire "
  
  Select Case UCase$(param)
  
  Case "-*"
  Case "-?"
     menuAide_Click
     End
   Case "-U"
    universal_clip = valeur
      menuclip.Caption = "Fixer le nb de pixel à supprimer (actuel:" & universal_clip & ")"
  Case "-DPI"
    dpi = Val(valeur)
  Case "-AUTO"
    chknoval
    menuAutoSave.Checked = True
  Case "-Q"
     chknoval
     menuAutoQuit.Checked = True
  Case "-P"
     chknoval
     menuStartPaint.Checked = True
  Case "-C"
     chknoval
     menucadre.Checked = True
  Case "-4"
     chknoval
     mode = 4
  Case "-V"
     chknoval
     mode = "V"
   Case "-H"
     chknoval
     mode = "H"
  Case "-NW", "-N", "-W"
      NW = valeur
  Case "-NE", "-E"
      NE = valeur
  Case "-SW", "S"
      SW = valeur
  Case "-SE"
      SE = valeur
  Case "-OUT"
   
 outparam = valeur
  menuSave.Caption = "Save BMP 24 bits to: " & outparam
  menuSave.Visible = True
  Case Else
    MsgBox "parametre inconnu:" & param
    End
  End Select
 Wend
If mode = "V" Then
   menuNW.Caption = "N"
   menuSW.Caption = "S"
   menuNE.Visible = False
   menuSE.Visible = False
   End If
If mode = "H" Then
   menuNW.Caption = "W"
   menuNE.Caption = "E"
   menuSW.Visible = False
   menuSE.Visible = False
   End If
   
   If mode = "" Then
     MsgBox "SPECIFIER LE Mode -V -H -4 "
     End
     End If
   If (mode = "V") And ((NE <> "") Or (SE <> "")) Then
      MsgBox "En mode Vertical, impossible de spécifier pages Est"
      End
      End If
   If (mode = "H") And ((SW <> "") Or (SE <> "")) Then
      MsgBox "En mode Vertical, impossible de spécifier pages Sud"
      End
      End If
      
  recharger
  
  init
  
  
End Sub
Private Sub init()
vsb.Min = 0
  vsb.Max = 100
  hsb.Left = 0
  hsb.Max = 100
 Select Case mode
 Case "4"
  hsb.Value = 50
  vsb.Value = 50
  Case "V"
  hsb.Value = 100
  vsb.Value = 50
  Case "H"
  hsb.Value = 50
  vsb.Value = 100
  End Select
  
  
  saved = True

End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
  Dim i As Integer
  If Not saved Then
    i = MsgBox("are you sure", vbOKCancel)
    If i = vbCancel Then Cancel = True
    End If
    
End Sub

Private Sub Form_Resize()
   doresize True
   End Sub
Private Sub doresize(fautrecharger As Boolean)
' equarrir
Dim menu As Integer
menu = 40
'  If mode = "V" Then hsb.Width = 0
'  If mode = "H" Then vsb.Width = 0

' dimension de l'image visible
  bac_w = Form1.Width \ 15 - vsb.Width - 6
  bac_h = Form1.Height \ 15 - hsb.Height - menu - 6
   If 2 * (bac_w \ 2) = bac_w Then bac_w = bac_w - 1
   If 2 * (bac_h \ 2) = bac_h Then bac_h = bac_h - 1
  
' placement des ascenceurs
  vsb.Top = 0
  vsb.Left = bac_w
  vsb.Height = bac_h
  hsb.Top = bac_h
  hsb.Width = bac_w
   Dim SW As Long
   Dim sh As Long
'   recharger
   Dim recouvrement As Integer
   ' si recouvrement=-1 les cadres sont cote a cote (deux pixels entre images)
   '                    et disposition réguliére
   ' si recouvrement = 0 les cadres sont superposes un seul pixel entre image
   ' si recouvrement =1 les images sont contigues une ligne cachée par le cadre)
   
If menucadre.Checked Then
    cadre = 1
   recouvrement = 0
    Else
    cadre = 0
    recouvrement = 0
    End If
    
    
    outerNW.BorderStyle = cadre
    OuterNE.BorderStyle = cadre
    OuterSW.BorderStyle = cadre
    outerSE.BorderStyle = cadre

   
 ' arranger les outer en fonction des ascenceur $$$$$$$$$$$$$$$$$$$$$$
 
 '
 ' calculer image externe
 dodim
 
 ' voir si le separateur est visible
 Dim decalx As Long, decaly As Long
    
   If mode = "4" Then
   decaly = nw_h
   decalx = nw_w
   nw_w = bac_w * (hsb.Value) / 100
   nw_h = bac_h * (vsb.Value) / 100
   nw_w = bac_w * (1 - (hsb.Value) / 100)
   nw_h = bac_h * (1 - (vsb.Value) / 100)
    outerNW.Move 1, 1, nw_w, nw_h
   innerNw.Top = innerNw.Top - decaly + nw_h
   innerNw.Left = innerNw.Left - decalx + nw_w
  '
   decaly = ne_h
   decalx = ne_w
  
    ne_w = bac_w * (100 - hsb.Value) / 100
    ne_h = bac_h * (vsb.Value) / 100
    ne_w = bac_w * (1 - (100 - hsb.Value) / 100)
    ne_h = bac_h * (1 - (vsb.Value) / 100)
    OuterNE.Move nw_w + recouvrement, 1, ne_w, ne_h
    InnerNE.Top = InnerNE.Top - decaly + ne_h
   '
   decaly = sw_h
   decalx = sw_w
   sw_w = bac_w * (hsb.Value) / 100
   sw_h = bac_h * (100 - vsb.Value) / 100
   sw_w = bac_w * (1 - (hsb.Value) / 100)
   sw_h = bac_h * (1 - (100 - vsb.Value) / 100)
    OuterSW.Move 1, nw_h + recouvrement, sw_w, sw_h
   InnerSW.Left = InnerSW.Left - decalx + sw_w
 '
   decaly = se_h
   decalx = se_w
   se_w = bac_w * (100 - hsb.Value) / 100
   se_h = bac_h * (100 - vsb.Value) / 100
   se_w = bac_w * (1 - (100 - hsb.Value) / 100)
   se_h = bac_h * (1 - (100 - vsb.Value) / 100)
    
    outerSE.Move nw_w + recouvrement, nw_h + recouvrement, se_w, se_h
     
    End If
   
   If mode = "V" Then
   decaly = nw_h
   nw_w = bac_w
   nw_h = bac_h * (vsb.Value) / 100
   nw_h = bac_h * (1 - (vsb.Value) / 100)
    outerNW.Move 1, 1, nw_w, nw_h
    innerNw.Top = innerNw.Top - decaly + nw_h
   sw_w = bac_w
   sw_h = bac_h * (100 - vsb.Value) / 100
   sw_h = bac_h * (1 - (100 - vsb.Value) / 100)
    OuterSW.Move 1, nw_h + recouvrement, sw_w, sw_h

    OuterNE.Visible = False
    outerSE.Visible = False
    End If
   
   If mode = "H" Then
    decalx = nw_w
    nw_w = bac_w * (hsb.Value) / 100
    nw_w = bac_w * (1 - (hsb.Value) / 100)
    nw_h = bac_h
    innerNw.Left = innerNw.Left - decalx + nw_w
    outerNW.Move 1, 1, nw_w, nw_h
   ne_w = bac_w * (100 - hsb.Value) / 100
   ne_w = bac_w * (1 - (100 - hsb.Value) / 100)
   ne_h = bac_h
    OuterNE.Move nw_w + recouvrement, 1, ne_w, ne_h
'
    OuterSW.Visible = False
    outerSE.Visible = False
    End If
'
If fautrecharger Then recharger
      SetScrollingValues
'   If Not targetdone Then center
  
End Sub
Private Sub doscroll_new(fautrecharger As Boolean)
' equarrir
Dim menu As Integer
menu = 40
'  If mode = "V" Then hsb.Width = 0
'  If mode = "H" Then vsb.Width = 0


' dimension de l'image visible
  bac_w = Form1.Width \ 15 - vsb.Width - 6
  bac_h = Form1.Height \ 15 - hsb.Height - menu - 6
   If 2 * (bac_w \ 2) = bac_w Then bac_w = bac_w - 1
   If 2 * (bac_h \ 2) = bac_h Then bac_h = bac_h - 1
  
' placement des ascenceurs
  vsb.Top = 0
  vsb.Left = bac_w
  vsb.Height = bac_h
  hsb.Top = bac_h
  hsb.Width = bac_w
   Dim SW As Long
   Dim sh As Long
'   recharger
   Dim recouvrement As Integer
   ' si recouvrement=-1 les cadres sont cote a cote (deux pixels entre images)
   '                    et disposition réguliére
   ' si recouvrement = 0 les cadres sont superposes un seul pixel entre image
   ' si recouvrement =1 les images sont contigues une ligne cachée par le cadre)
   
If menucadre.Checked Then
    cadre = 1
   recouvrement = 0
    Else
    cadre = 0
    recouvrement = 0
    End If
    
    
    outerNW.BorderStyle = cadre
    OuterNE.BorderStyle = cadre
    OuterSW.BorderStyle = cadre
    outerSE.BorderStyle = cadre

   
 ' arranger les outer en fonction des ascenceur $$$$$$$$$$$$$$$$$$$$$$
 
 '
 ' calculer image externe
 dodim
 
 ' voir si le separateur est visible
 Dim decalx As Long, decaly As Long
    
   If mode = "4" Then
   decaly = nw_h
   decalx = nw_w
   nw_w = bac_w * (hsb.Value) / 100
   nw_h = bac_h * (vsb.Value) / 100
   nw_w = bac_w * (1 - (hsb.Value) / 100)
   nw_h = bac_h * (1 - (vsb.Value) / 100)
    outerNW.Move 1, 1, nw_w, nw_h
   innerNw.Top = innerNw.Top - decaly + nw_h
   innerNw.Left = innerNw.Left - decalx + nw_w
  '
   decaly = ne_h
   decalx = ne_w
  
    ne_w = bac_w * (100 - hsb.Value) / 100
    ne_h = bac_h * (vsb.Value) / 100
    ne_w = bac_w * (1 - (100 - hsb.Value) / 100)
    ne_h = bac_h * (1 - (vsb.Value) / 100)
    OuterNE.Move nw_w + recouvrement, 1, ne_w, ne_h
    InnerNE.Top = InnerNE.Top - decaly + ne_h
   '
   decaly = sw_h
   decalx = sw_w
   sw_w = bac_w * (hsb.Value) / 100
   sw_h = bac_h * (100 - vsb.Value) / 100
   sw_w = bac_w * (1 - (hsb.Value) / 100)
   sw_h = bac_h * (1 - (100 - vsb.Value) / 100)
    OuterSW.Move 1, nw_h + recouvrement, sw_w, sw_h
   InnerSW.Left = InnerSW.Left - decalx + sw_w
 '
   decaly = se_h
   decalx = se_w
   se_w = bac_w * (100 - hsb.Value) / 100
   se_h = bac_h * (100 - vsb.Value) / 100
   se_w = bac_w * (1 - (100 - hsb.Value) / 100)
   se_h = bac_h * (1 - (100 - vsb.Value) / 100)
    
    outerSE.Move nw_w + recouvrement, nw_h + recouvrement, se_w, se_h
     
    End If
   
   If mode = "V" Then
   decaly = nw_h
   nw_w = bac_w
   nw_h = bac_h * (vsb.Value) / 100
   nw_h = bac_h * (1 - (vsb.Value) / 100)
    outerNW.Move 1, 1, nw_w, nw_h
    innerNw.Top = innerNw.Top - decaly + nw_h
   sw_w = bac_w
   sw_h = bac_h * (100 - vsb.Value) / 100
   sw_h = bac_h * (1 - (100 - vsb.Value) / 100)
    OuterSW.Move 1, nw_h + recouvrement, sw_w, sw_h

    OuterNE.Visible = False
    outerSE.Visible = False
    End If
   
   If mode = "H" Then
    decalx = nw_w
    nw_w = bac_w * (hsb.Value) / 100
    nw_w = bac_w * (1 - (hsb.Value) / 100)
    nw_h = bac_h
    innerNw.Left = innerNw.Left - decalx + nw_w
    outerNW.Move 1, 1, nw_w, nw_h
   ne_w = bac_w * (100 - hsb.Value) / 100
   ne_w = bac_w * (1 - (100 - hsb.Value) / 100)
   ne_h = bac_h
    OuterNE.Move nw_w + recouvrement, 1, ne_w, ne_h
'
    OuterSW.Visible = False
    outerSE.Visible = False
    End If
'
If fautrecharger Then recharger
      SetScrollingValues
'   If Not targetdone Then center
  
End Sub

Private Sub InnerRight_Click()

End Sub

Private Sub hsb_Change()
Select Case mode
Case "H"
     doresize False
Case "V"
     innerNw.Left = -(innerNw.Width - outerNW.Width) * hsb.Value / 100
     InnerSW.Left = -(InnerSW.Width - OuterSW.Width) * hsb.Value / 100
     doresize False
Case Else
  doresize False
End Select
End Sub

Private Sub innersw_Click()
  g = True
  h = False
End Sub

Private Sub innersw_MouseMove(Button As Integer, shift As Integer, x As Single, y As Single)
mm "SW", SW, InnerSW, OuterSW, shift, x, y
  End Sub


Private Sub innerNE_MouseMove(Button As Integer, shift As Integer, x As Single, y As Single)
mm "NE", NE, InnerNE, OuterNE, shift, x, y

End Sub

Private Sub innerse_MouseMove(Button As Integer, shift As Integer, x As Single, y As Single)
mm "SE", SE, innerSE, outerSE, shift, x, y

End Sub
Private Sub innerNE_Click()
  g = False
  h = True
End Sub

Private Sub innerNw_Click()
  g = True
  h = True
End Sub

Private Sub Innerse_Click()
  g = False
  h = False
End Sub

Private Sub innerNw_MouseMove(Button As Integer, shift As Integer, x As Single, y As Single)
mm "NW", NW, innerNw, outerNW, shift, x, y
End Sub

Private Sub mm(coin As String, n As String, p As PictureBox, o As PictureBox, shift As Integer, x As Single, y As Single)
Dim p1 As Long, p2 As Long, p3 As Long
Dim d256 As Long
Dim d255 As Long
d256 = 256
d255 = 255
Dim rgb As Long
rgb = p.Point(x, y)
p2 = (rgb \ d256) And d255
p3 = (rgb \ (d256 * d256)) And d255
p1 = rgb And d255
  Form1.Caption = x & "*" & y & "=" & p1 & " " & p2 & " " & p3
  
  Dim pw As String
' $$$$ a corriger pour tenir compte d'un eventuel decalage des images
  Select Case coin
  Case "NW"
  pw = n & " W=" & -p.Left + o.Width & " H=" & -p.Top + o.Height
  Case "NE"
  pw = n & " W=" & p.Width + p.Left & " H=" & -p.Top + o.Height
  Case "SW"
  pw = n & " W=" & -p.Left + o.Width & " H=" & p.Height + p.Top
  Case "SE"
  pw = n & " W=" & p.Height + p.Left & " H=" & p.Height + p.Top
  
  End Select
p.ToolTipText = pw & " / " & nbx & "*" & nby
End Sub


Private Sub menu_Quit_Click()
  End
End Sub

Private Sub menuAide_Click()
Dim mes As String
   mes = "Assemblage de 4 images " & vbCrLf & _
    "appel:" & vbCrLf & _
    "save4    paramètres " & vbCrLf & vbCrLf & _
    "Choix du mode " & vbCrLf & _
    " -H  juxtaposer deux images horizontalement" & vbCrLf & _
    " -V  juxtaposer deux images verticalement" & vbCrLf & _
    " -4  juxtaposer quatre images " & vbCrLf & vbCrLf & _
    " désignation des fichiers : " & vbCrLf & _
    " -NW:nom  fichier pour l'image haut gauche" & vbCrLf & _
    " -NE:nom fichier pour l'image haut droite" & vbCrLf & _
    " -SW:nom fichier pour l'image bas gauche" & vbCrLf & _
    " -SE:nom fichier pour l'image bas droit" & vbCrLf
    
   mes = mes & _
     " -N:nom fichier pour l'image haut si -H " & vbCrLf & _
    " -S:nom fichier pour l'image bas si -H" & vbCrLf & _
    " -W:nom fichier pour l'image gauche si -V" & vbCrLf & _
    " -E:nom fichier pour l'image droite si -H" & vbCrLf & _
    " -OUT:nom fichier de sortie (avec .bmp), obligatoire si -AUTO." & vbCrLf & _
    " " & vbCrLf & _
    "Options: " & vbCrLf & _
    " -U:nnn nb de pixel à retirer de CHAQUE image " & vbCrLf & _
    " -P  lancer MsPaint" & vbCrLf & _
    " -AUTO  exécuter la suavegarde immédiatement " & vbCrLf & _
    " -Q  Quitter après la sauvegarde " & vbCrLf & _
    " -C : afficher le cadre " & vbCrLf
mes = mes & vbCrLf & _
   "References: " & vbCrLf & _
   "http://www.vb-helper.com/howto_scroll_with_arrows.html" & vbCrLf & _
   "http://www.commentcamarche.net/video/format-bmp.php3" & vbCrLf & _
   "Source:" & vbCrLf & "http://www.flavigny.net/Turgot" & vbCrLf & _
   "mailto:flavigny@inrets.fr"
   MsgBox mes
End Sub
Private Sub w1(n As Long)
  Print #1, Chr$(n And &HFF);
End Sub
Private Sub n1(n As Long)
  w1 n
  Exit Sub
  If n > 160 Then
    w1 255
    Else
    w1 0
    End If
End Sub
Private Sub w2(n As Long)
  Dim p As Long, q As Long
  p = (n And &HFF00) \ 256
  w1 n
  w1 p
End Sub
Private Sub w4(n As Long)
  Dim p As Long, q As Long
  Dim p256 As Long
  p256 = 256
  p = (n And &H7FFF0000) \ (p256 * p256)
  w2 n
  w2 p
End Sub
Private Sub w3(n As Long)
  Dim r As Integer, v As Integer, b As Integer
  Dim p256 As Long
  Dim i As Integer
  p256 = 256
  b = (n And &HFF)
  n = n \ p256
  v = (n And &HFF)
  n = n \ p256
  r = (n And &HFF)
  Print #1, Chr$(r); Chr$(v); Chr$(b);
  End Sub
Private Sub pp(ByRef p As Long, ByRef da As Long, ByRef db As Long, a As Long, b As Long)
 If a < b Then
     p = a
     da = 0
     db = b - a
     Else
     p = b
     da = a - b
     db = 0
    End If
End Sub

Private Sub menuApropos_Click()
  MsgBox Creele & vbCrLf & _
  "Version " & App.Major & "." & App.Minor & ".0." & App.Revision & vbCrLf & _
  "mailto:flavigny@inrets.fr"
  
End Sub

Private Sub menuAutoQuit_Click()
menuAutoQuit.Checked = Not menuAutoQuit.Checked

End Sub

Private Sub menuAutoSave_Click()
  menuAutoSave.Checked = Not menuAutoSave.Checked
End Sub

Private Sub menucadre_Click()
  menucadre.Checked = Not menucadre.Checked
  doresize False
End Sub

Private Sub menuclip_Click()
  universal_clip = Val(InputBox("Nombre de pixel à supprimer"))
  menuclip.Caption = "Fixer le nb de pixel à supprimer (actuel:" & universal_clip & ")"
  doresize True
  dodim
End Sub

Private Sub MenuSave_Click()
  dosave outparam
  
End Sub
Private Sub dodim()
pd = 0
 pg = 0
 
If mode = "V" Then
    ph = outerNW.Height - innerNw.Top
    NWh = 0
    Else
   pp ph, NWh, NEh, outerNW.Height - innerNw.Top, OuterNE.Height - InnerNE.Top
   End If
   
     ' plus bas
 If mode = "V" Then
   pb = InnerSW.Height + InnerSW.Top
   SWb = 0
   Else
   pp pb, SWb, SEb, InnerSW.Height + InnerSW.Top, innerSE.Height + innerSE.Top
   If mode = "H" Then pb = 0
   End If
   
  ' gauche
 If mode = "H" Then
   pg = outerNW.Width - innerNw.Left
   NWg = 0
   Else
   pp pg, NWg, SWg, outerNW.Width - innerNw.Left, OuterSW.Width - InnerSW.Left
   End If
   
   
  ' droite
  If mode = "H" Then
  pd = InnerNE.Width + InnerNE.Left
  NEd = 0
  Else
    pp pd, NEd, SEd, InnerNE.Width + InnerNE.Left, innerSE.Width + innerSE.Left
    If mode = "V" Then pd = 0
  End If
   nbx = pg + pd
   nby = ph + pb
   'troncquer
 
End Sub
Private Sub dosave(out As String)
  Dim i As Single, j As Single
   ' calcul dim
 If menucadre.Checked Then
   MsgBox "Sauvegarde impossible quand cadre affiché"
   Exit Sub
   End If
 ' apriori pour si pas là
   dodim
   
 '
  If out = "" Then
  CommonDialog1.FileName = ""
  CommonDialog1.ShowSave
   out = CommonDialog1.FileName '
   If out = "" Then Exit Sub
   End If
  menu_File.Enabled = False
  menuSave.Enabled = False
  'menuSaveXY.Enabled = False
  menuCharger.Enabled = False
  On Error GoTo noopen
  GoTo ouvrir
noopen:
    MsgBox "le fichier n'existe pas"
    Exit Sub
ouvrir:
  Open out For Output As #1
On Error GoTo 0
  Screen.MousePointer = vbHourglass
   w1 &H42
   w1 &H4D
   Dim ttot As Long
   ttot = 3 * nbx * nby
   w4 ttot + &H36 ' taille fichier
   w4 0
   Dim deca As Long
   deca = &H36 ' 14 + &H28
   w4 deca
   ' en tete
   w4 &H28
   w4 nbx
   w4 nby
   w2 1
   w2 24 ' nb bits
   w4 0 ' pas compressé
   w4 ttot ' taille de l'image
   Dim dpm As Long
   dpm = dpi * 1000 / 254
   w4 dpm ' &HEC4  '300 ' dpi x
   w4 dpm '&HEC4  '30
   w4 0 ' palette
   w4 0
   
Dim s As String
Dim xused As Long
Dim yused As Long
For iby = nby - 1 To 0 Step -1 '-1
 Dim co As Integer
 co = 0
 For ibx = 0 To nbx - 1
 If False Then
   MsgBox ibx & iby & InnerSW.Height & InnerSW.Width
   End If
   Dim trucagey As Long
 'MsgBox innerNw.Width
   If ibx < pg Then
       ' ouest
       If iby < ph Then
         'NW
         s = "NW"
         xused = ibx + NWg
         yused = iby + NWh
         rgb = innerNw.Point(xused, yused)
       Else
         ' SW
         s = "SW"
'         MsgBox InnerSW.Height
         xused = ibx + SWg
         yused = iby - ph - InnerSW.Top ' +swb
         rgb = InnerSW.Point(xused, yused)
       End If
       
     Else
      'est
     If iby < ph Then
        ' NE
         s = "NE"
         xused = ibx - pg - InnerNE.Left + NEd
         yused = iby + NEh
         rgb = InnerNE.Point(xused, yused)
       Else
         'Se
         s = "SE"
         xused = ibx - pg - innerSE.Left
         yused = iby - ph - innerSE.Top ' + SEb
         rgb = innerSE.Point(xused, yused)
       End If
       End If
     If rgb = -1 Then rgb = &HFFFFFF
       If False Then
'        Stop
        Close #1
        MsgBox "abandon -1 en " & ibx & "*" & iby & vbCrLf & " source=" & s & " " & xused & "*" & yused
        Screen.MousePointer = 1
        Exit Sub
        End If
Dim p1 As Long, p2 As Long, p3 As Long
Dim b As Long, r As Long, v As Long
Dim d256 As Long
Dim d255 As Long
If False Then
d256 = 256
d255 = 255
'p1 = rgb
v = (rgb \ d256) And d255
r = (rgb \ (d256 * d256)) And d255
b = rgb And d255
 n1 b
 n1 v
 n1 r
 Else
 w3 rgb
 End If
 co = co + 3
 ' DoEvents
 Next ibx
 DoEvents
 ' pad
 ibx = (co + 3) \ 4
 ibx = 4 * ibx - co
    While ibx > 0
     w1 0
     ibx = ibx - 1
   Wend
   Form1.Caption = Int(100 * ((nby - iby) / nby)) & " %"
Next iby
 
  Close #1
  Screen.MousePointer = 1
  menuSave.Enabled = True
  'menuSaveXY.Enabled = True
  menuCharger.Enabled = True
  menu_File.Enabled = True
  
  If menuStartPaint.Checked Then
  Shell "mspaint """ & out & """", vbNormalNoFocus
  End If
  saved = True
  If menuAutoQuit.Checked Then End
End Sub
Private Sub charger(hv4 As String, p As String, pp As PictureBox, n As String)
  
  If n = "" Then
 '  CommonDialog1.Action = 2
  CommonDialog1.Filter = "Tous les fichiers (*.*)|*.*|Jpeg|*.jpg|Bitmap|*.bmp"
  CommonDialog1.ShowOpen
   n = CommonDialog1.FileName
   If n = "" Then Exit Sub
   End If
   pp.Picture = LoadPicture(n)
   pp.ToolTipText = n
   Dim securiteh As Integer, securitev As Integer
   
   securitev = 0
   If hv4 <> "H" Then securitev = universal_clip
   securiteh = 0
   If hv4 <> "V" Then securiteh = universal_clip
   
  Select Case p
  Case "NW"
  innerNw.Left = -innerNw.Width + outerNW.Width + securiteh
  innerNw.Top = -innerNw.Height + outerNW.Height + securitev
  m_Vvalue(1) = innerNw.Top
  m_Hvalue(1) = innerNw.Left
  
  Case "NE"
  InnerNE.Left = 0 - securiteh
  InnerNE.Top = -InnerNE.Height + OuterNE.Height + securitev
  m_Vvalue(2) = InnerNE.Top
  m_Hvalue(2) = InnerNE.Left
  
  Case "SW"
  InnerSW.Left = -InnerSW.Width + OuterSW.Width + securiteh
  InnerSW.Top = 0 - securitev
  m_Vvalue(3) = InnerSW.Top
  m_Hvalue(3) = InnerSW.Left
  
  
  Case "SE"
  innerSE.Left = 0 - securiteh
  innerSE.Top = 0 - securitev
  m_Vvalue(4) = innerSE.Top
  m_Hvalue(4) = innerSE.Left
  
  End Select

' MsgBox pp.Width & " " & pp.Height

End Sub


Private Sub menuSaveAs_Click()
 dosave ""
End Sub

Private Sub menuSE_Click()
  charger mode, "SE", innerSE, ""
End Sub

Private Sub menuStartPaint_Click()
  menuStartPaint.Checked = Not menuStartPaint.Checked
End Sub

Private Sub menuSW_Click()
   charger mode, "SW", InnerSW, ""
End Sub
Private Sub menuNE_Click()
  charger mode, "NE", InnerNE, ""
End Sub
   
Private Sub menuNW_Click()
  charger mode, "NW", innerNw, ""
End Sub

Private Sub Timer1_Timer()

Timer1.Interval = 0
  If outparam = "" Then
    MsgBox "autosave exige out="
    End
    End If
    
  If menuAutoSave.Checked Then dosave outparam
End Sub
Private Sub recharger()
   charger mode, "NW", innerNw, NW
   If mode <> "V" Then charger mode, "NE", InnerNE, NE
   If mode <> "H" Then charger mode, "SW", InnerSW, SW
   If mode = "4" Then charger mode, "SE", innerSE, SE

End Sub

Private Sub vsb_Change()
  
  ' calcul hauteur totale
'  MsgBox vsb.Value
' la position des cadres est prise en charge par doresize
Select Case mode
Case "H"
   ' move images vertically
     innerNw.Top = -(innerNw.Height - outerNW.Height) * vsb.Value / 100
     InnerNE.Top = -(InnerNE.Height - OuterNE.Height) * vsb.Value / 100
Case "V"
   ' determiner si la barre est visible
   dodim
   
   '  innerNw.Left = -(innerNw.Width - outerNW.Width) * hsb.Value \ 100
   '  InnerSW.Left = -(InnerSW.Width - OuterSW.Width) * hsb.Value \ 100
     doresize False
Case Else
  '   innerNw.Top = -(innerNw.Height - outerNW.Height) * vsb.Value \ 100
  '   InnerNE.Top = -(InnerNE.Height - OuterNE.Height) * vsb.Value \ 100
  '   innerNw.Left = -(innerNw.Width - outerNW.Width) * hsb.Value \ 100
  '   InnerSW.Left = -(InnerSW.Width - OuterSW.Width) * hsb.Value \ 100
  doresize False
End Select
  
 End Sub


save4.vbp
Type=Exe
Form=save4.frm
Object={F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0; COMDLG32.OCX
Object={38911DA0-E448-11D0-84A3-00DD01104159}#1.1#0; comct332.ocx
IconForm="Form1"
Startup="Form1"
HelpFile=""
Title="Project1"
ExeName32="save4.exe"
Command32="-4  -nw:..\jpg\0004.jpg -ne:..\jpg\0005.jpg -sw:..\jpg\0008.jpg -se:..\jpg\0009.jpg -out:Big.bmp"
Name="Save4"
HelpContextID="0"
CompatibleMode="0"
MajorVer=0
MinorVer=9
RevisionVer=20
AutoIncrementVer=1
ServerSupportFiles=0
VersionCompanyName="Rocky Mountain Computer Consulting, Inc."
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1

[MS Transaction Server]
AutoRefresh=1
2020-03-30 08:18:25 :: Propriétaire : PoF :: Commenter :: Recherche :
Recherche par Google (en travaux):
XHTML 1.0 valide ? :: CSS valide ? :: -- Fonctionne avec WikiNi 0.4.4 (interwiki)